ywatds/interlocking.lisp

(defpackage :advtrains-interlocking
  (:use :cl)
  (:nicknames :atil)
  (:export :import-data
	   :ars-rule :ars-rule-p :ars-rule-match-mode :ars-rule-match-string
	   :ars-rule-invert-match
	   :tcbside :tcbside-p :tcbside-pos :tcbside-side
	   :path-entry :path-entry-p :path-entry-next :path-entry-locks
	   :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
	   :match-ars-p :match-route :route-next :find-tcb-at))
(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))

(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
	(:ln (format t "~:[~;NOT ~] LINE ~s" neg match))
	(:rc (format t "~:[~;NOT ~] RC ~s" neg 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))
      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)))))))

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

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

(defstruct path-entry
  (next nil :type (or null 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" (or next "EOI"))
      (loop for (pos . st) across locks do
	   (format s " ~_LOCKING ~a TO ~s" pos st)))))

(defmethod json:encode-json ((obj path-entry) &optional json:*json-output*)
  (with-accessors ((next path-entry-next) (locks path-entry-locks)) obj
    (json:encode-json-alist (list (cons "next" next)
				  (cons "locks" (loop with ht = (make-hash-table)
						   for i across locks
						   for (pos . st) = i
						   do (setf (gethash pos ht) st)
						   finally (return ht)))))))

(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 '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" 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))
  (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))))))

(defmethod json:encode-json ((obj tcbdata) &optional json:*json-output*)
  (with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (sname tcbdata-signal-name)
		   (routelist tcbdata-routes))
      obj
    (json:encode-json (list (cons "in_section" ts)
			    (cons "signal_pos" spos)
			    (cons "signal_name" sname)
			    (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)))))

(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-string ,i)
	     for ,n = (ars-rule-invert-match ,i)
	     do (when (ecase (ars-rule-match-mode ,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)
    (alexandria:once-only
     (route)
     `(let ((,p (route-path ,route)))
	(path-entry-next (aref ,p (length ,p)))))))

(defmacro find-tcb-at (data pos)
  (alexandria:with-gensyms (i r)
    (alexandria:once-only
     (data pos)
     `(loop with ,r = nil while (not ,r)
	 for ,i across ,data
	 when (equalp (tcb-pos ,i) ,pos)
	 do (setf ,r ,i)
	 finally (return ,r)))))

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

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

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

(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)
  (atsl:with-data-from-file (ht 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)))