(defpackage :advtrains-interlocking
  (:use :cl)
  (:nicknames :atil)
  (:export :load-ildb
	   :ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
	   :tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
	   :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
	   :ildb :ildb-p :ildb-tcbs
	   :match-ars-p :match-route :route-next :find-tcb-at))
(in-package :atil)

(defstruct ars-rule
  (type (error "no ARS mode speified") :type (or (eql :ln) (eql :rc)))
  (match "" :type string)
  (invertp nil :type boolean))

(defmethod print-object ((obj ars-rule) *standard-output*)
  (with-accessors ((mode ars-rule-type)
		   (match ars-rule-match)
		   (neg ars-rule-invertp))
      obj
    (print-unreadable-object (obj *standard-output*)
      (format t "~:[~;NOT ~]~a ~s" neg (ecase mode (:ln "LINE") (:rc "RC")) match))))

(defmethod json:encode-json ((obj ars-rule) &optional json:*json-output*)
  (with-accessors ((mode ars-rule-type)
		   (match ars-rule-match)
		   (neg ars-rule-invertp))
      obj
    (json:encode-json (list (cons "mode" (ecase mode (:ln "ln") (:rc "rc")))
			    (cons "match" match)
			    (cons "n" neg)))))

(defstruct tcbside
  (:pos (error "No coordinates specified") :type aux:v3d)
  (:side (error "No side specified") :type (integer 0 1)))

(defmethod print-object ((obj tcbside) s)
  (with-accessors ((p tcbside-pos) (side tcbside-side)) obj
    (print-unreadable-object (obj s)
      (format s "~a/~a" p side))))

(defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
  (with-accessors ((p tcbside-pos) (side tcbside-side)) obj
    (json:encode-json (list (cons "p" p) (cons "s" side)))))

(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 '(or tcbside null)) :type (vector (or tcbside null))))

(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))
  (routes (aux:adj-vector-of 'route) :type (vector route)))

(defmethod print-object ((obj tcbdata) s)
  (with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj
    (print-unreadable-object (obj s)
      (format s "~:i~:[EOI~;~:*IN SECTION ~a~]~@[ SIGNALING AT ~a~]" ts spos)
      (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) (routelist tcbdata-routes)) obj
    (json:encode-json (list (cons "in_section" ts)
			    (cons "signal_pos" spos)
			    (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)))))

(defstruct ildb
  (tcbs (error "no TCB data") :type hash-table))

(defmethod print-object ((obj ildb) s)
  (with-accessors ((tcbs ildb-tcbs)) obj
    (print-unreadable-object (obj s)
      (format s "TCBS ~s" (alexandria:hash-table-alist tcbs)))))

(defmethod json:encode-json ((obj ildb) &optional json:*json-output*)
  (with-accessors ((tcbs ildb-tcbs)) obj
    (json:encode-json (list (cons "tcbs" (alexandria:hash-table-alist tcbs))))))

(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 ,i)
	     for ,n = (ars-rule-invertp ,i)
	     do (when (ecase (ars-rule-type ,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 l)
    (alexandria:once-only
     (route)
     `(let* ((,p (route-path ,route)) (,l (length ,p)))
	(if (> ,l 0) (aref ,p (1- ,l)))))))

(defmacro find-tcb-at (ildb pos)
  `(gethash ,pos (ildb-tcbs ,ildb)))

(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 (ent next p s)
    `(aux:collect-integrally-indexed-entries
      ((vector (or tcbside null)) ,pathht nil ,ent 1)
      (let ((,next (gethash "next" ,ent)))
	(if ,next (aux:with-entries-in-hash-table (,next (,p "p") (,s "s"))
		    (make-tcbside :pos (aux:hash-table-to-v3d ,p) :side (1- ,s))))))))

(defmacro parse-ars-rules (rulesht)
  (alexandria:with-gensyms (ent neg ln rc ftype match)
    (alexandria:once-only
     (rulesht)
     `(cond
	((not (hash-table-p ,rulesht)) (aux:adj-vector-of 'ars-rule))
	((gethash "default" ,rulesht) t)
	(t (aux:collect-integrally-indexed-non-nil
	    ((vector ars-rule) ,rulesht nil ,ent 1)
	    (aux:with-entries-in-hash-table (,ent (,ln "ln") (,rc "rc") (,neg "n"))
	      (alexandria:when-let ((,ftype (cond (,ln :ln) (,rc :rc) (t nil)))
				    (,match (or ,ln ,rc)))
		(make-ars-rule :type ,ftype :match ,match :invertp ,neg)))))))))

(defmacro parse-route (routeinfo)
  (alexandria:with-gensyms (name ars)
    (alexandria:once-only
     (routeinfo)
     `(aux:with-entries-in-hash-table (,routeinfo (,name "name") (,ars "ars"))
	(make-route :name ,name
		    :ars-rules (parse-ars-rules ,ars)
		    :path (parse-path ,routeinfo))))))

(defmacro read-routes (routeht)
  (alexandria:with-gensyms (ent)
    `(aux:collect-integrally-indexed-entries
      ((vector route) ,routeht nil ,ent 1)
      (parse-route ,ent))))

(defmacro read-tcb-side (side)
  (alexandria:with-gensyms (ts spos routes)
    (alexandria:once-only
     (side)
     `(let ((,ts (gethash "ts_id" ,side nil))
	    (,spos (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side))))
	    (,routes (read-routes (gethash "routes" ,side (make-hash-table)))))
	(make-tcbdata :ts ,ts
		      :signal-pos ,spos
		      :routes ,routes)))))

(defun load-ildb (fn)
  (atsl:with-data-from-file (ht fn :hash-table :only "tcbs")
    (let ((tcbs (make-hash-table :test #'equalp)))
      (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 (setf (gethash pos tcbs) tcbobj))
      (make-ildb :tcbs tcbs))))