228 lines
8.1 KiB
Common Lisp
228 lines
8.1 KiB
Common Lisp
(defpackage :advtrains-interlocking
|
|
(:use :cl)
|
|
(:nicknames :atil)
|
|
(:export :load-ildb
|
|
:ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
|
|
:tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
|
|
:route :route-p :route-name :route-ars-rules :route-path
|
|
:tcbdata :tcbdata-p :tcbdata-signal-pos :tcbdata-signal-name :tcbdata-routes
|
|
:tcb :tcb-p :tcb-pos :tcb-side-a :tcb-side-b
|
|
:ildb :ildb-p :ildb-tcbs
|
|
:match-ars-p :match-route :route-next :find-tcb-at))
|
|
(in-package :atil)
|
|
|
|
(defstruct ars-rule
|
|
(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-type)
|
|
(match ars-rule-match)
|
|
(neg ars-rule-invertp))
|
|
obj
|
|
(print-unreadable-object (obj *standard-output*)
|
|
(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-type)
|
|
(match ars-rule-match)
|
|
(neg ars-rule-invertp))
|
|
obj
|
|
(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 (integer 0 1)))
|
|
|
|
(defmethod print-object ((obj tcbside) s)
|
|
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "~a/~a" p side))))
|
|
|
|
(defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
|
|
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
|
(json:encode-json (list (cons "p" p) (cons "s" side)))))
|
|
|
|
(defstruct route
|
|
(name "" :type string)
|
|
(ars-rules (aux:adj-vector-of 'ars-rule) :type (or (eql t) (vector ars-rule)))
|
|
(path (aux:adj-vector-of '(or tcbside null)) :type (vector (or tcbside null))))
|
|
|
|
(defmethod print-object ((obj route) s)
|
|
(with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "ROUTE ~:_~:i~s" name)
|
|
(cond
|
|
((eql ars t) (format s " ~:_MATCHING EVERY TRAIN"))
|
|
((> (length ars) 0) (format s " ~:_MATCHING ~a" ars)))
|
|
(when (> (length path) 0)
|
|
(pprint-indent :block 1 s)
|
|
(loop for i across path do (format s " ~_~a" i))))))
|
|
|
|
(defmethod json:encode-json ((obj route) &optional json:*json-output*)
|
|
(with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj
|
|
(json:encode-json (list (cons "name" name)
|
|
(cons "ars" ars)
|
|
(cons "path" path)))))
|
|
|
|
(defstruct tcbdata
|
|
(ts nil :type (or string null))
|
|
(signal-pos nil :type (or aux:v3d null))
|
|
(routes (aux:adj-vector-of 'route) :type (vector route)))
|
|
|
|
(defmethod print-object ((obj tcbdata) s)
|
|
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "~:i~:[EOI~;~:*IN SECTION ~a~]~@[ SIGNALING AT ~a~]" ts spos)
|
|
(when (> (length routelist) 0)
|
|
(pprint-indent :block 1 s)
|
|
(loop for i across routelist do (format s " ~_~a" i))))))
|
|
|
|
(defmethod json:encode-json ((obj tcbdata) &optional json:*json-output*)
|
|
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj
|
|
(json:encode-json (list (cons "in_section" ts)
|
|
(cons "signal_pos" spos)
|
|
(cons "routes" routelist)))))
|
|
|
|
(defstruct tcb
|
|
(pos (error "no position specified") :type aux:v3d)
|
|
(side-a (error "TCB has no side A") :type tcbdata)
|
|
(side-b (error "TCB has no side B") :type tcbdata))
|
|
|
|
(defmethod print-object ((obj tcb) s)
|
|
(with-accessors ((pos tcb-pos) (a tcb-side-a) (b tcb-side-b)) obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "TCB AT ~a ~_SIDE A ~a ~_SIDE B ~a" pos a b))))
|
|
|
|
(defmethod json:encode-json ((obj tcb) &optional json:*json-output*)
|
|
(with-accessors ((pos tcb-pos) (a tcb-side-a) (b tcb-side-b)) obj
|
|
(json:encode-json (list (cons "pos" pos)
|
|
(cons "a" a)
|
|
(cons "b" b)))))
|
|
|
|
(defstruct ildb
|
|
(tcbs (error "no TCB data") :type hash-table))
|
|
|
|
(defmethod print-object ((obj ildb) s)
|
|
(with-accessors ((tcbs ildb-tcbs)) obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "TCBS ~s" (alexandria:hash-table-alist tcbs)))))
|
|
|
|
(defmethod json:encode-json ((obj ildb) &optional json:*json-output*)
|
|
(with-accessors ((tcbs ildb-tcbs)) obj
|
|
(json:encode-json (list (cons "tcbs" (alexandria:hash-table-alist tcbs))))))
|
|
|
|
(defmacro match-ars-p (ars-rules ln rc)
|
|
(alexandria:with-gensyms (i r s n)
|
|
(alexandria:once-only
|
|
(ars-rules ln rc)
|
|
`(if (eql ,ars-rules t) t
|
|
(loop
|
|
with ,r = nil
|
|
for ,i across ,ars-rules
|
|
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))
|
|
until ,r
|
|
finally (return ,r))))))
|
|
|
|
(defmacro match-route (routelist ln rc)
|
|
(alexandria:with-gensyms (i r)
|
|
(alexandria:once-only
|
|
(routelist ln rc)
|
|
`(loop
|
|
with ,r = nil
|
|
while (not ,r)
|
|
for ,i across ,routelist
|
|
when (match-ars-p (route-ars-rules ,i) ,ln ,rc)
|
|
do (setf ,r ,i)
|
|
finally (return ,r)))))
|
|
|
|
(defmacro route-next (route)
|
|
(alexandria:with-gensyms (p l)
|
|
(alexandria:once-only
|
|
(route)
|
|
`(let* ((,p (route-path ,route)) (,l (length ,p)))
|
|
(if (> ,l 0) (aref ,p (1- ,l)))))))
|
|
|
|
(defmacro find-tcb-at (ildb pos)
|
|
`(gethash ,pos (ildb-tcbs ,ildb)))
|
|
|
|
(defmacro parse-route-locks (locksht)
|
|
(alexandria:with-gensyms (ht locks k v pos st)
|
|
`(loop
|
|
with ,ht = (or ,locksht (make-hash-table))
|
|
and ,locks = (aux:adj-vector-of '(cons aux:v3d string))
|
|
for ,k being the hash-keys of ,ht using (hash-value ,v)
|
|
for ,pos = (aux:string-to-v3d ,k)
|
|
and ,st = (format nil "~a" ,v)
|
|
do (vector-push-extend (cons ,pos ,st) ,locks)
|
|
finally (return ,locks))))
|
|
|
|
(defmacro parse-path (pathht)
|
|
(alexandria:with-gensyms (ent next p s)
|
|
`(aux:collect-integrally-indexed-entries
|
|
((vector (or tcbside null)) ,pathht nil ,ent 1)
|
|
(let ((,next (gethash "next" ,ent)))
|
|
(if ,next (aux:with-entries-in-hash-table (,next (,p "p") (,s "s"))
|
|
(make-tcbside :pos (aux:hash-table-to-v3d ,p) :side (1- ,s))))))))
|
|
|
|
(defmacro parse-ars-rules (rulesht)
|
|
(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)))
|
|
(make-ars-rule :type ,ftype :match ,match :invertp ,neg)))))))))
|
|
|
|
(defmacro parse-route (routeinfo)
|
|
(alexandria:with-gensyms (name ars)
|
|
(alexandria:once-only
|
|
(routeinfo)
|
|
`(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 (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 routes)
|
|
(alexandria:once-only
|
|
(side)
|
|
`(let ((,ts (gethash "ts_id" ,side nil))
|
|
(,spos (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side))))
|
|
(,routes (read-routes (gethash "routes" ,side (make-hash-table)))))
|
|
(make-tcbdata :ts ,ts
|
|
:signal-pos ,spos
|
|
:routes ,routes)))))
|
|
|
|
(defun load-ildb (fn)
|
|
(atsl:with-data-from-file (ht fn :hash-table :only "tcbs")
|
|
(let ((tcbs (make-hash-table :test #'equalp)))
|
|
(loop
|
|
for poss being each hash-key of (gethash "tcbs" ht)
|
|
using (hash-value tcb)
|
|
for pos = (aux:string-to-v3d poss)
|
|
and side-a = (read-tcb-side (gethash 1 tcb))
|
|
and side-b = (read-tcb-side (gethash 2 tcb))
|
|
for tcbobj = (make-tcb :pos pos :side-a side-a :side-b side-b)
|
|
do (setf (gethash pos tcbs) tcbobj))
|
|
(make-ildb :tcbs tcbs))))
|