Further code cleanup
parent
97eac0ca15
commit
c41f1be44a
|
@ -19,7 +19,8 @@
|
|||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
||||
(load-data ()
|
||||
`(progn
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls"))))))
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
||||
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
||||
(ywsw:safe-text-route
|
||||
dumpser
|
||||
("/dumpser/:p" :method :get) (&path (p 'string))
|
||||
|
|
31
helpers.lisp
31
helpers.lisp
|
@ -4,7 +4,9 @@
|
|||
(:export :parse-lua-number :adj-vector-of
|
||||
:v3d :make-v3d :v3d-x :v3d-y :v3d-z :v3d-p
|
||||
:string-to-v3d :hash-table-to-v3d
|
||||
:with-integrally-indexed-entries :with-entries-in-hash-table))
|
||||
:with-integrally-indexed-entries :collect-integrally-indexed-entries
|
||||
:collect-integrally-indexed-non-nil
|
||||
:with-entries-in-hash-table))
|
||||
(in-package :aux)
|
||||
|
||||
(defmacro adj-vector-of (element-type)
|
||||
|
@ -60,16 +62,25 @@
|
|||
(format nil "(~a,~a,~a)" ,x ,y ,z))))
|
||||
|
||||
(defmacro with-integrally-indexed-entries ((hash-table key value start) &body body)
|
||||
(alexandria:with-gensyms (ht k v)
|
||||
(let ((i (gensym)) (k (or key (gensym))) (v (or value (gensym))) (ht (gensym)))
|
||||
`(let ((,ht ,hash-table))
|
||||
(when (hash-table-p ,ht)
|
||||
(loop
|
||||
for ,k = ,start then (1+ ,k)
|
||||
for ,v = (gethash ,k ,ht)
|
||||
while ,v
|
||||
for ,(or key (gensym)) = ,k
|
||||
and ,(or value (gensym)) = ,v
|
||||
do (progn ,@body))))))
|
||||
(when ,ht
|
||||
(do* ((,i ,start (1+ ,i)) (,k ,i ,i) (,v (gethash ,i ,ht) (gethash ,i ,ht)))
|
||||
((not ,v))
|
||||
,@body)))))
|
||||
|
||||
(defmacro collect-integrally-indexed-entries ((result-type &body options) &body body)
|
||||
(alexandria:with-gensyms (l)
|
||||
`(let ((,l nil))
|
||||
(with-integrally-indexed-entries ,options (push (progn ,@body) ,l))
|
||||
(coerce (nreverse ,l) (quote ,result-type)))))
|
||||
|
||||
(defmacro collect-integrally-indexed-non-nil ((result-type &body options) &body body)
|
||||
(alexandria:with-gensyms (l e)
|
||||
`(let ((,l nil))
|
||||
(with-integrally-indexed-entries ,options
|
||||
(let ((,e (progn ,@body))) (when ,e (push ,e ,l))))
|
||||
(coerce (nreverse ,l) (quote ,result-type)))))
|
||||
|
||||
(defmacro with-entries-in-hash-table ((hash-table &body indices) &body body)
|
||||
(alexandria:once-only
|
||||
|
|
|
@ -13,48 +13,40 @@
|
|||
(in-package :atil)
|
||||
|
||||
(defstruct ars-rule
|
||||
(match-mode (error "no ARS mode speified") :type (or (eql :ln) (eql :rc)))
|
||||
(match-string "" :type string)
|
||||
(invert-match nil :type boolean))
|
||||
(type (error "no ARS mode speified") :type (or (eql :ln) (eql :rc)))
|
||||
(match "" :type string)
|
||||
(invertp nil :type boolean))
|
||||
|
||||
(defmethod print-object ((obj ars-rule) *standard-output*)
|
||||
(with-accessors ((mode ars-rule-match-mode)
|
||||
(match ars-rule-match-string)
|
||||
(neg ars-rule-invert-match))
|
||||
(with-accessors ((mode ars-rule-type)
|
||||
(match ars-rule-match)
|
||||
(neg ars-rule-invertp))
|
||||
obj
|
||||
(print-unreadable-object (obj *standard-output*)
|
||||
(ecase mode
|
||||
(:ln (format t "~:[~;NOT ~] LINE ~s" neg match))
|
||||
(:rc (format t "~:[~;NOT ~] RC ~s" neg match))))))
|
||||
(format t "~:[~;NOT ~]~a ~s" neg (ecase mode (:ln "LINE") (:rc "RC")) match))))
|
||||
|
||||
(defmethod json:encode-json ((obj ars-rule) &optional json:*json-output*)
|
||||
(with-accessors ((mode ars-rule-match-mode)
|
||||
(match ars-rule-match-string)
|
||||
(neg ars-rule-invert-match))
|
||||
(with-accessors ((mode ars-rule-type)
|
||||
(match ars-rule-match)
|
||||
(neg ars-rule-invertp))
|
||||
obj
|
||||
(json:encode-json (ecase mode
|
||||
(:ln (list (cons "mode" "ln")
|
||||
(cons "ln" match)
|
||||
(cons "n" neg)))
|
||||
(:rc (list (cons "mode" "rc")
|
||||
(cons "rc" match)
|
||||
(cons "n" neg)))))))
|
||||
(json:encode-json (list (cons "mode" (ecase mode (:ln "ln") (:rc "rc")))
|
||||
(cons "match" match)
|
||||
(cons "n" neg)))))
|
||||
|
||||
(defstruct tcbside
|
||||
(:pos (error "No coordinates specified") :type aux:v3d)
|
||||
(:side (error "No side specified") :type symbol))
|
||||
(:side (error "No side specified") :type (integer 0 1)))
|
||||
|
||||
(defmethod print-object ((obj tcbside) s)
|
||||
(with-accessors ((p tcbside-pos) (side tcbside-side))
|
||||
obj
|
||||
(let ((tside (ecase side (:a "A") (:b "B"))))
|
||||
(print-unreadable-object (obj s)
|
||||
(format s "SIDE ~a OF ~a" tside p)))))
|
||||
(format s "SIDE ~a OF ~a" side p))))
|
||||
|
||||
(defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
|
||||
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
||||
(let ((tside (ecase side (:a "a") (:b "B"))))
|
||||
(json:encode-json (list (cons "p" p) (cons "s" tside))))))
|
||||
(json:encode-json (list (cons "p" p) (cons "s" side)))))
|
||||
|
||||
(defstruct path-entry
|
||||
(next nil :type (or null tcbside))
|
||||
|
@ -150,9 +142,9 @@
|
|||
(loop
|
||||
with ,r = nil
|
||||
for ,i across ,ars-rules
|
||||
for ,s = (ars-rule-match-string ,i)
|
||||
for ,n = (ars-rule-invert-match ,i)
|
||||
do (when (ecase (ars-rule-match-mode ,i)
|
||||
for ,s = (ars-rule-match ,i)
|
||||
for ,n = (ars-rule-invertp ,i)
|
||||
do (when (ecase (ars-rule-type ,i)
|
||||
(:ln (if ,n (string/= ,s ,ln) (string= ,s ,ln)))
|
||||
(:rc (if ,n (not (search ,rc ,s)) (search ,rc ,s))))
|
||||
(setf ,r t))
|
||||
|
@ -200,56 +192,43 @@
|
|||
finally (return ,locks))))
|
||||
|
||||
(defmacro parse-path (pathht)
|
||||
(alexandria:with-gensyms (ht i ent path next p s locks tcbs)
|
||||
`(loop
|
||||
with ,ht = (or ,pathht (make-hash-table))
|
||||
and ,path = (aux:adj-vector-of 'path-entry)
|
||||
for ,i = 1 then (1+ ,i)
|
||||
for ,ent = (gethash ,i ,ht)
|
||||
while ,ent
|
||||
for ,next = (gethash "next" ,ent)
|
||||
for ,p = (if ,next (aux:hash-table-to-v3d (gethash "p" ,next)) nil)
|
||||
and ,s = (if ,next (ecase (gethash "s" ,next) (1 :a) (2 :b)) nil)
|
||||
and ,locks = (parse-route-locks (gethash "locks" ,ent))
|
||||
for ,tcbs = (if (and ,p ,s) (make-tcbside :pos ,p :side ,s) nil)
|
||||
do (vector-push-extend (make-path-entry :next ,tcbs :locks ,locks)
|
||||
,path)
|
||||
finally (return ,path))))
|
||||
(alexandria:with-gensyms (ent next p s locks)
|
||||
`(aux:collect-integrally-indexed-non-nil
|
||||
((vector path-entry) ,pathht nil ,ent 1)
|
||||
(aux:with-entries-in-hash-table (,ent (,next "next") (,locks "locks"))
|
||||
(aux:with-entries-in-hash-table (,next (,p "p") (,s "s"))
|
||||
(make-path-entry :next (make-tcbside :pos (aux:hash-table-to-v3d ,p)
|
||||
:side (1- ,s))
|
||||
:locks (parse-route-locks ,locks)))))))
|
||||
|
||||
(defmacro parse-ars-rules (rulesht)
|
||||
(alexandria:with-gensyms (ht rules ent neg ln rc ftype match)
|
||||
`(let ((,rules (aux:adj-vector-of 'ars-rule)) (,ht ,rulesht))
|
||||
(cond
|
||||
((not (hash-table-p ,ht)) ,rules)
|
||||
((gethash "default" ,ht) t)
|
||||
(t (progn
|
||||
(aux:with-integrally-indexed-entries (,ht nil ,ent 1)
|
||||
(aux:with-entries-in-hash-table (,ent (,neg "n") (,ln "ln") (,rc "rc"))
|
||||
(alexandria:with-gensyms (ent neg ln rc ftype match)
|
||||
(alexandria:once-only
|
||||
(rulesht)
|
||||
`(cond
|
||||
((not (hash-table-p ,rulesht)) (aux:adj-vector-of 'ars-rule))
|
||||
((gethash "default" ,rulesht) t)
|
||||
(t (aux:collect-integrally-indexed-non-nil
|
||||
((vector ars-rule) ,rulesht nil ,ent 1)
|
||||
(aux:with-entries-in-hash-table (,ent (,ln "ln") (,rc "rc") (,neg "n"))
|
||||
(alexandria:when-let ((,ftype (cond (,ln :ln) (,rc :rc) (t nil)))
|
||||
(,match (or ,ln ,rc)))
|
||||
(vector-push-extend (make-ars-rule :match-mode ,ftype
|
||||
:match-string ,match
|
||||
:invert-match ,neg)
|
||||
,rules))))
|
||||
,rules))))))
|
||||
(make-ars-rule :type ,ftype :match ,match :invertp ,neg)))))))))
|
||||
|
||||
(defmacro parse-route (routeinfo)
|
||||
(alexandria:with-gensyms (rname rars rpath)
|
||||
(alexandria:with-gensyms (name ars)
|
||||
(alexandria:once-only
|
||||
(routeinfo)
|
||||
`(let ((,rname (gethash "name" ,routeinfo))
|
||||
(,rars (parse-ars-rules (gethash "ars" ,routeinfo)))
|
||||
(,rpath (parse-path ,routeinfo)))
|
||||
(make-route :name ,rname
|
||||
:ars-rules ,rars
|
||||
:path ,rpath)))))
|
||||
`(aux:with-entries-in-hash-table (,routeinfo (,name "name") (,ars "ars"))
|
||||
(make-route :name ,name
|
||||
:ars-rules (parse-ars-rules ,ars)
|
||||
:path (parse-path ,routeinfo))))))
|
||||
|
||||
(defmacro read-routes (routeht)
|
||||
(alexandria:with-gensyms (routelist ent)
|
||||
`(let ((,routelist (aux:adj-vector-of 'route)))
|
||||
(aux:with-integrally-indexed-entries (,routeht nil ,ent 1)
|
||||
(vector-push-extend (parse-route ,ent) ,routelist))
|
||||
,routelist)))
|
||||
(alexandria:with-gensyms (ent)
|
||||
`(aux:collect-integrally-indexed-entries
|
||||
((vector route) ,routeht nil ,ent 1)
|
||||
(parse-route ,ent))))
|
||||
|
||||
(defmacro read-tcb-side (side)
|
||||
(alexandria:with-gensyms (ts spos sname routes)
|
||||
|
|
Loading…
Reference in New Issue