186 lines
6.3 KiB
Common Lisp
186 lines
6.3 KiB
Common Lisp
(defpackage :advtrains-interlocking
|
|
(:use :cl)
|
|
(:nicknames :atil)
|
|
(:export :import-data))
|
|
(in-package :atil)
|
|
|
|
(defstruct ars-rule
|
|
(match-mode :default :type symbol)
|
|
(match-string "" :type string)
|
|
(invert-match 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))
|
|
obj
|
|
(print-unreadable-object (obj *standard-output*)
|
|
(ecase mode
|
|
(:default (princ "ARS RULE MATCHING EVERYTHING"))
|
|
(:comment (format t "ARS COMMENT ~s" match))
|
|
(:ln (format t "ARS RULE~:[~; NOT~] MATCHING LINE ~s" neg match))
|
|
(:rc (format t "ARS RULE~:[~; NOT~] MATCHING RC ~s" neg match))))))
|
|
|
|
(defstruct tcbside
|
|
(:pos (error "No coordinates specified") :type aux:v3d)
|
|
(:side (error "No side specified") :type symbol))
|
|
|
|
(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)))))
|
|
|
|
(defstruct path-entry
|
|
(next (error "No coordinates specified for path") :type tcbside)
|
|
(locks (aux:adj-vector-of '(cons aux:v3d string)) :type (vector (cons aux:v3d string))))
|
|
|
|
(defmethod print-object ((obj path-entry) s)
|
|
(with-accessors ((next path-entry-next) (locks path-entry-locks))
|
|
obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "TO ~a" next)
|
|
(loop for (pos . st) across locks do
|
|
(format s " ~_LOCKING ~a TO ~s" pos st)))))
|
|
|
|
(defstruct route
|
|
(name "" :type string)
|
|
(ars-rules (aux:adj-vector-of 'ars-rule) :type (vector ars-rule))
|
|
(path (aux:adj-vector-of 'path-entry) :type (vector path-entry)))
|
|
|
|
(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~[~*~:; ~:_WITH ~a~]"
|
|
name (length ars) ars)
|
|
(when (> (length path) 0)
|
|
(pprint-indent :block 1 s)
|
|
(loop for i across path do (format s " ~_~a" i))))))
|
|
|
|
(defstruct tcbdata
|
|
(ts nil :type (or string null))
|
|
(signal-pos nil :type (or aux:v3d null))
|
|
(signal-name nil :type (or string 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) (sname tcbdata-signal-name)
|
|
(routelist tcbdata-routes))
|
|
obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "~:i~:[EOI~;~:*IN SECTION ~a~]~:[~*~; ~:_~:*SIGNALING AT ~a NAMED ~s~]"
|
|
ts spos sname)
|
|
(when (> (length routelist) 0)
|
|
(pprint-indent :block 1 s)
|
|
(loop for i across routelist do (format s " ~_~a" i))))))
|
|
|
|
(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))))
|
|
|
|
(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 (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)
|
|
while ,next
|
|
for ,p = (aux:hash-table-to-v3d (gethash "p" ,next))
|
|
and ,s = (ecase (gethash "s" ,next) (1 :a) (2 :b))
|
|
and ,locks = (parse-route-locks (gethash "locks" ,ent))
|
|
for ,tcbs = (make-tcbside :pos ,p :side ,s)
|
|
do (vector-push-extend (make-path-entry :next ,tcbs :locks ,locks)
|
|
,path)
|
|
finally (return ,path))))
|
|
|
|
(defmacro parse-ars-rules (rulesht)
|
|
(alexandria:with-gensyms (ht rules i ent neg def ln rc c ftype match)
|
|
`(loop
|
|
with ,rules = (aux:adj-vector-of 'ars-rule)
|
|
and ,ht = (or ,rulesht (make-hash-table))
|
|
for ,i = 1 then (1+ ,i)
|
|
for ,ent = (gethash ,i ,ht)
|
|
while ,ent
|
|
for ,neg = (gethash "n" ,ent nil)
|
|
and ,def = (gethash "default" ,ent nil)
|
|
and ,ln = (gethash "ln" ,ent nil)
|
|
and ,rc = (gethash "rc" ,ent nil)
|
|
and ,c = (gethash "c" ,ent nil)
|
|
for ,ftype = (cond (,def :default) (,ln :ln) (,rc :rc) (,c :comment) (t nil))
|
|
and ,match = (if ,def "" (or ,ln ,rc ,c))
|
|
when ,ftype
|
|
do (vector-push-extend (make-ars-rule :match-mode ,ftype
|
|
:match-string ,match
|
|
:invert-match ,neg)
|
|
,rules)
|
|
finally (return ,rules))))
|
|
|
|
(defmacro parse-route (routeinfo)
|
|
(alexandria:with-gensyms (rname rars rpath)
|
|
(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)))))
|
|
|
|
(defmacro read-routes (routeht)
|
|
(alexandria:with-gensyms (routelist i ent)
|
|
`(loop
|
|
with ,routelist = (aux:adj-vector-of 'route)
|
|
for ,i = 1 then (1+ ,i)
|
|
for ,ent = (gethash ,i ,routeht nil)
|
|
while ,ent
|
|
do (vector-push-extend (parse-route ,ent) ,routelist)
|
|
finally (return ,routelist))))
|
|
|
|
(defmacro read-tcb-side (side)
|
|
(alexandria:with-gensyms (ts spos sname routes)
|
|
(alexandria:once-only
|
|
(side)
|
|
`(let ((,ts (gethash "ts_id" ,side nil))
|
|
(,spos (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side))))
|
|
(,sname (gethash "signal_name" ,side))
|
|
(,routes (read-routes (gethash "routes" ,side (make-hash-table)))))
|
|
(make-tcbdata :ts ,ts
|
|
:signal-pos ,spos
|
|
:signal-name ,sname
|
|
:routes ,routes)))))
|
|
|
|
(defun import-data (fn)
|
|
(let ((ht (atsl:from-file fn :hash-table)))
|
|
(let ((tcbs (aux:adj-vector-of 'tcb)))
|
|
(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 (vector-push-extend tcbobj tcbs))
|
|
tcbs)))
|