247 lines
8.3 KiB
Common Lisp
247 lines
8.3 KiB
Common Lisp
(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)))
|