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