(defpackage :tracks
  (:use :cl)
  (:export :init-tracks :import-data
	   :dump-track-definitions :gvdump))
(in-package :tracks)

(defparameter *hdiff*
  '#((0 . 1) (1 . 2) (1 . 1) (2 . 1) (1 . 0) (2 . -1) (1 . -1) (1 . -2)
     (0 . -1) (-1 . -2) (-1 . -1) (-2 . -1) (-1 . 0) (-2 . 1) (-1 . 1) (-1 . 2)))

(defparameter *dirnames* #("N" "NNE" "NE" "ENE" "E" "ESE" "SE" "SSE"
			   "S" "SSW" "SW" "WSW" "W" "WNW" "NW" "NNW"))

(defparameter *track->conns* (make-hash-table :test #'equal))

(defstruct trackside
  (:pos (error "no coordinates specified") :type aux:v3d)
  (:side 0 :type (integer 0 *)))

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

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

(defstruct dir
  (:c 0 :type (integer 0 15))
  (:r 0 :type (integer 0 1)))

(defmethod print-object ((obj dir) s)
  (print-unreadable-object (obj s)
    (format s "~a~@d" (aref *dirnames* (dir-c obj)) (dir-r obj))))

(defstruct conns
  (:from (error "from-field not specified for conns entry") :type dir)
  (:to (error "to-field not specified for conns entry") :type dir))

(defmethod print-object ((obj conns) s)
  (print-unreadable-object (obj s)
    (format s "FROM ~a TO ~a" (conns-from obj) (conns-to obj))))

(defmacro dir (c &optional r)
  `(make-dir :c (or ,c 0) :r (or ,r 0)))

(defmacro conns (c1 c2 &optional r1 r2)
  `(make-conns :from (dir ,c1 ,r1) :to (dir ,c2 ,r2)))

(defmacro conns-t ((c1 &body cb) (&optional r1 &body rb))
  ``(,,@(loop for c in cb and ri = rb then (cdr rb) for r = (car r)
	   collect `(conns ,c1 ,c ,r1 ,r))))

(defmacro conns-x ((&body cb) (&body rb))
  ``(,,@(loop for (c1 c2) on cb by #'cddr and r = rb then (cddr rb)
	   for r1 = (car r) and r2 = (cadr r)
	   collect `(conns ,c1 ,c2 ,r1 ,r2))))

(defmacro adjust-dir (dir diff)
  (alexandria:once-only
   (dir)
   `(dir (mod (+ 16 (or ,diff 0) (dir-c ,dir)) 16) (dir-r ,dir))))

(defmacro adjust-conns (conns diff)
  (alexandria:once-only
   (conns diff)
   `(make-conns :from (adjust-dir (conns-from ,conns) ,diff)
		:to (adjust-dir (conns-to ,conns) ,diff))))

(defmacro adjust-conns-list (clist diff)
  (alexandria:with-gensyms (i)
    (alexandria:once-only
     (diff)
     `(loop for ,i in ,clist collect (adjust-conns ,i ,diff)))))

(defmacro adjust-dir-with-param2 (dir param2)
  `(adjust-dir ,dir (* 4 ,param2)))

(defmacro adjust-conns-with-param2 (conns param2)
  `(adjust-conns ,conns (* 4 ,param2)))

(defmacro adjust-conns-list-with-param2 (clist param2)
  `(adjust-conns-list ,clist (* 4 ,param2)))

(defmacro apply-dir-to-v3d (pos dir)
  (alexandria:with-gensyms (h)
    (alexandria:once-only
     (pos dir)
     `(let ((,h (aref *hdiff* (dir-c ,dir))))
	(aux:make-v3d :x (+ (aux:v3d-x ,pos) (car ,h))
		      :y (+ (aux:v3d-y ,pos) (dir-r ,dir))
		      :z (+ (aux:v3d-z ,pos) (cdr ,h)))))))

(defmacro apply-conns-to-v3d (pos conns)
  (alexandria:once-only
   (pos conns)
   `(list (apply-dir-to-v3d ,pos (conns-from ,conns))
	  (apply-dir-to-v3d ,pos (conns-to ,conns)))))

(defmacro get-adjacent (pos clist)
  (alexandria:with-gensyms (i)
    `(remove-duplicates (loop for ,i in ,clist append (apply-conns-to-v3d ,pos ,i))
			:test #'equalp)))

(defmacro connectsp (tdb pos to)
  (alexandria:with-gensyms (pc tc)
    (alexandria:once-only
     (tdb pos to)
     `(alexandria:when-let ((,pc (gethash ,pos ,tdb)) (,tc (gethash ,to ,tdb)))
	(and (member ,to (get-adjacent ,pos ,pc) :test #'equalp)
	     (member ,pos (get-adjacent ,to ,tc) :test #'equalp))))))

(defmacro get-connecting (tdb pos)
  (alexandria:with-gensyms (pc i)
    (alexandria:once-only
     (tdb pos)
     `(alexandria:when-let ((,pc (gethash ,pos ,tdb)))
	(loop for ,i in (get-adjacent ,pos ,pc)
	   when (member ,pos (get-adjacent ,i (gethash ,i ,tdb)) :test #'equalp)
	   collect ,i)))))

(defmacro register-track (name conns)
  `(setf (gethash ,name *track->conns*) ,conns))

(defmacro register-tracks (names conns)
  (alexandria:with-gensyms (c i)
    `(loop with ,c = ,conns for ,i in ,names do (register-track ,i ,c))))

(defmacro register-rotatable-tracks (names conns)
  (alexandria:with-gensyms (i s j n)
    (alexandria:once-only
     (names conns)
     `(loop for ,i = 0 then (1+ ,i) for ,s in `("" "_30" "_45" "_60")
	 for ,n = (loop for ,j in ,names collect (concatenate 'string ,j ,s))
	 do (register-tracks ,n (adjust-conns-list ,conns ,i))))))

(defmacro prefix-names (prefix &body names)
  (alexandria:once-only
   (prefix)
   `(list ,@(loop for i in names collect `(concatenate 'string ,prefix "_" ,i)))))

(defmacro register-track-with-preset (prefix &body defs)
  (alexandria:once-only
   (prefix)
   `(progn ,@(loop for i in defs
		collect `(register-tracks (prefix-names ,prefix ,@(car i)) ,(cadr i))))))

(defmacro register-rotatable-track-with-preset (prefix &body defs)
  (alexandria:once-only
   (prefix)
   `(progn ,@(loop for i in defs collect
		  `(register-rotatable-tracks (prefix-names ,prefix ,@(car i)) ,(cadr i))))))

(defmacro register-default-tracks (prefix)
  `(register-rotatable-track-with-preset
    ,prefix
    (("st") (conns-t (0 8) ()))
    (("cr") (conns-t (0 7) ()))
    (("swlst" "swlcr") (conns-t (0 8 7) ()))
    (("swrst" "swrcr") (conns-t (0 8 9) ()))))

(defmacro register-y-turnout-tracks (prefix)
  `(register-rotatable-track-with-preset
    ,prefix
    (("l" "r") (conns-t (0 7 9) ()))))

(defmacro register-3way-turnout-tracks (prefix)
  `(register-rotatable-track-with-preset
    ,prefix
    (("l" "s" "r") (conns-t (0 7 8 9) ()))))

(defmacro register-slope-tracks (prefix)
  `(register-rotatable-track-with-preset
    ,prefix
    (("vst1" "vst31" "vst32") (conns-t (8 0) (0 0)))
    (("vst2" "vst33") (conns-t (8 0) (0 1)))))

(defmacro register-straightonly-tracks (prefix)
  `(register-rotatable-track-with-preset
    ,prefix
    (("st") (conns-t (0 8) ()))))

(defmacro register-perp-xing-tracks (prefix)
  `(register-rotatable-track-with-preset
    ,prefix
    (("st") (conns-x (0 8 4 12) ()))))

(defmacro register-90+x-xing-tracks (prefix)
  `(register-track-with-preset
    ,prefix
    (("30l") (conns-x (0 8 1 9) ()))
    (("45l") (conns-x (0 8 2 10) ()))
    (("60l") (conns-x (0 8 3 11) ()))
    (("60r") (conns-x (0 8 5 13) ()))
    (("45r") (conns-x (0 8 6 14) ()))
    (("30r") (conns-x (0 8 7 15) ()))))

(defmacro register-diag-xing-tracks (prefix)
  `(register-track-with-preset
    ,prefix
    (("30l45r") (conns-x (1 9 6 14) ()))
    (("60l30l") (conns-x (3 11 1 9) ()))
    (("60l45r") (conns-x (3 11 6 14) ()))
    (("60l60r") (conns-x (3 11 5 13) ()))
    (("60r45l") (conns-x (5 13 2 10) ()))
    (("60r30r") (conns-x (5 13 7 15) ()))
    (("30r45l") (conns-x (7 15 2 10) ()))))

(defun init-tracks ()
  (setf *track->conns* (make-hash-table :test #'equal))
  (register-default-tracks "advtrains:dtrack")
  (register-y-turnout-tracks "advtrains:dtrack_sy")
  (register-3way-turnout-tracks "advtrains:dtrack_s3")
  (register-perp-xing-tracks "advtrains:dtrack_xing")
  (register-90+x-xing-tracks "advtrains:dtrack_xing90plusx")
  (register-diag-xing-tracks "advtrains:dtrack_xingdiag")
  (register-slope-tracks "advtrains:dtrack")
  (register-straightonly-tracks "advtrains:dtrack_bumper")
  (register-straightonly-tracks "advtrains:dtrack_atc")
  (register-straightonly-tracks "advtrains:dtrack_unload")
  (register-straightonly-tracks "advtrains:dtrack_load")
  (register-straightonly-tracks "advtrains:dtrack_detector_off")
  (register-straightonly-tracks "advtrains:dtrack_detector_on"))

(defun dump-track-definitions ()
  (format nil "~s" (alexandria:hash-table-alist *track->conns*)))

(defun import-data (ndb)
  (let ((tdb (make-hash-table :test #'equalp)))
    (ndb:loopdb
     (ndb pos node param2)
     for conns = (gethash node *track->conns*)
     when conns do (setf (gethash pos tdb) (adjust-conns-list-with-param2 conns param2)))
    tdb))

(defun gvdump (tdb)
  (with-output-to-string (stream)
    (format stream "graph{")
    (loop with visited = (make-hash-table :test #'equalp)
       for pos being the hash-keys of tdb do
         (loop for i in (get-connecting tdb pos)
	    when (not (gethash i visited))
	    do (format stream "\"~a\"--\"~a\";" pos i))
	 (setf (gethash pos visited) t))
    (write-char #\} stream)))