Parse more route information

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

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)))

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)