From ca333c555ee854aa523aa747932d272f1f4e9ec8 Mon Sep 17 00:00:00 2001 From: y5nw Date: Tue, 17 Aug 2021 00:07:37 +0200 Subject: [PATCH] Parse more route information --- helpers.lisp | 7 +- interlocking.lisp | 167 +++++++++++++++++++++++++++++++++++++++++---- serialize-lib.lisp | 4 +- 3 files changed, 159 insertions(+), 19 deletions(-) diff --git a/helpers.lisp b/helpers.lisp index 5f0bb63..5af23e1 100644 --- a/helpers.lisp +++ b/helpers.lisp @@ -34,9 +34,10 @@ `(cl-ppcre:register-groups-bind (,xs ,ys ,zs) ("^\\((-?[0-9]+),(-?[0-9]+),(-?[0-9]+)\\)$" ,str) - (make-v3d :x (parse-integer ,xs) - :y (parse-integer ,ys) - :z (parse-integer ,zs))))) + (when (and ,xs ,ys ,zs) + (make-v3d :x (parse-integer ,xs) + :y (parse-integer ,ys) + :z (parse-integer ,zs)))))) (defmacro hash-table-to-v3d (ht) (alexandria:once-only diff --git a/interlocking.lisp b/interlocking.lisp index fa0d48d..ccaad07 100644 --- a/interlocking.lisp +++ b/interlocking.lisp @@ -4,33 +4,172 @@ (: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-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) stream) - (let ((*standard-output* stream)) - (with-accessors ((pos tcb-pos) (a tcb-side-a) (b tcb-side-b)) obj - (print-unreadable-object (obj stream) - (format stream "TCB AT ~a " pos) - (pprint-newline :mandatory) - (pprint-indent :current 0) - (format stream "SIDE A ~a " a) - (pprint-newline :mandatory) - (format stream "SIDE B ~a" b))))) +(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) + (alexandria:with-gensyms (ts spos sname routes) (alexandria:once-only (side) - `(let ((,ts (gethash "ts_id" ,side nil))) + `(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 (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side)))))))) + :signal-pos ,spos + :signal-name ,sname + :routes ,routes))))) (defun import-data (fn) (let ((ht (atsl:from-file fn :hash-table))) diff --git a/serialize-lib.lisp b/serialize-lib.lisp index a68b4f7..a0ccd6b 100644 --- a/serialize-lib.lisp +++ b/serialize-lib.lisp @@ -23,8 +23,8 @@ (#\T ,(if table-allow `'table `(error "table not allowed"))) (#\N (aux:parse-lua-number ,restdata)) (#\B (ecase (parse-integer ,restdata) - (0 t) - (1 nil))) + (0 nil) + (1 t))) (#\S (unescape ,restdata)))))) (defmacro adjust-line (line)