Redo track system to handle more complicated situations
y5nw
parent
57b3578a33
commit
26d10de5dd
|
|
@ -88,9 +88,9 @@
|
|||
append (loop with side = (atil:make-tcbside :pos pos :side 1)
|
||||
for i across (atil:tcbdata-routes (atil:tcb-side-b tcb))
|
||||
append (list side (atil:route-next i))))))
|
||||
(ywsw:safe-graphviz-route
|
||||
graph-tracks ("/graph/tracks" :method :get) ()
|
||||
("Return a simple graph of tracks")
|
||||
(ywsw:safe-text-route
|
||||
graph-tracks ("/graph/paths" :method :get) ()
|
||||
("Return a simple graph of paths")
|
||||
(tracks:gvdump *trackdb*))
|
||||
(ywsw:defsafe
|
||||
docroute-master ("/doc" :method :get) ()
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(:nicknames :helpers :aux)
|
||||
(:export :parse-lua-number :adj-vector-of
|
||||
:v3d :make-v3d :v3d-x :v3d-y :v3d-z :v3d-p
|
||||
:string-to-v3d :hash-table-to-v3d
|
||||
:string-to-v3d :hash-table-to-v3d :v3d-dist
|
||||
:with-integrally-indexed-entries :collect-integrally-indexed-entries
|
||||
:collect-integrally-indexed-non-nil
|
||||
:with-entries-in-hash-table))
|
||||
|
|
@ -61,6 +61,13 @@
|
|||
,obj
|
||||
(format nil "(~a,~a,~a)" ,x ,y ,z))))
|
||||
|
||||
(defmacro v3d-dist (from to)
|
||||
(alexandria:once-only
|
||||
(from to)
|
||||
`(sqrt (+ (expt (- (v3d-x ,from) (v3d-x ,to)) 2)
|
||||
(expt (- (v3d-y ,from) (v3d-y ,to)) 2)
|
||||
(expt (- (v3d-z ,from) (v3d-z ,to)) 2)))))
|
||||
|
||||
(defmacro with-integrally-indexed-entries ((hash-table key value start) &body body)
|
||||
(let ((i (gensym)) (k (or key (gensym))) (v (or value (gensym))) (ht (gensym)))
|
||||
`(let ((,ht ,hash-table))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,8 @@
|
|||
`(loop with ,names = (car ,db) and ,nodes = (cdr ,db)
|
||||
for ,k being the hash-keys of ,nodes using (hash-value ,v)
|
||||
for ,id = (ash ,v -2)
|
||||
for ,pos = ,k and ,name = (gethash ,id ,names) and ,param2 = (mod ,v 4) ,@body))))
|
||||
for ,pos = ,k and ,name = (gethash ,id ,names) and ,param2 = (mod ,v 4)
|
||||
do (progn ,@body)))))
|
||||
|
||||
;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html
|
||||
(defun import-data (fn)
|
||||
|
|
|
|||
246
tracks.lisp
246
tracks.lisp
|
|
@ -1,246 +0,0 @@
|
|||
(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)))
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
(in-package :tracks)
|
||||
|
||||
(defstruct trackside
|
||||
(:pos (error "no coordinates specified") :type aux:v3d)
|
||||
(:side (error "no side specified") :type (integer 0 15)))
|
||||
|
||||
(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 (aref *dirnames* 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 conns-list-dirs (clist)
|
||||
(alexandria:with-gensyms (i)
|
||||
`(remove-duplicates (loop for ,i in ,clist collect (conns-from ,i) collect (conns-to ,i))
|
||||
:test #'equalp)))
|
||||
|
||||
(defmacro dir-length (dir)
|
||||
(alexandria:with-gensyms (h)
|
||||
(alexandria:once-only
|
||||
(dir)
|
||||
`(let ((,h (aref *hdiff* (dir-c ,dir))))
|
||||
(sqrt (+ (expt (car ,h) 2) (expt (cdr ,h) 2) (expt (dir-r ,dir) 2) 0.0))))))
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
(in-package :tracks)
|
||||
|
||||
(defmacro make-empty-connects () `(make-array 16 :element-type 'list :initial-element nil))
|
||||
|
||||
;; The each list in the connects array is:
|
||||
;; nil - the direction does not exist in the conns table of the track, or
|
||||
;; a list with the CAR representing the position of the connecting track
|
||||
;; CADR representing the distance to the connecting track (or 0)
|
||||
;; CDDR representing the list of directions the train can move in
|
||||
(defstruct track
|
||||
(connects (make-empty-connects) :type (vector list 16))
|
||||
(special nil :type list))
|
||||
|
||||
(defmacro make-track-database ()
|
||||
`(make-hash-table :test #'equalp))
|
||||
|
||||
(defmacro get-track (trackdb pos)
|
||||
`(gethash ,pos ,trackdb))
|
||||
|
||||
(defun import-data (ndb)
|
||||
(let ((tdb (make-track-database))
|
||||
;; temporary track database to read in data to
|
||||
(tmpdb (make-hash-table :test #'equalp)))
|
||||
(ndb:loopdb
|
||||
(ndb pos node param2)
|
||||
(alexandria:when-let ((clist (gethash node *track->conns*)))
|
||||
(setf (gethash pos tmpdb) (adjust-conns-list-with-param2 clist param2))))
|
||||
(loop for pos being the hash-keys of tmpdb using (hash-value clist)
|
||||
for dirs = (conns-list-dirs clist)
|
||||
for connects = (make-empty-connects) do
|
||||
(labels
|
||||
((dir-pos-connection (from-c to-pos)
|
||||
(let ((td (conns-list-dirs (gethash to-pos tmpdb)))
|
||||
(to-c (mod (+ 8 from-c) 16)))
|
||||
(if (member to-c td :test #'equal :key #'dir-c)
|
||||
(make-trackside :pos to-pos :side to-c)))))
|
||||
;; collect a list of directions a train can move in after reaching the track
|
||||
(loop for i in clist do
|
||||
(let ((from (dir-c (conns-from i)))
|
||||
(to (dir-c (conns-to i))))
|
||||
(push from (aref connects to))
|
||||
(push to (aref connects from))))
|
||||
;; collect coordinates (or nil) of connecting tracks
|
||||
(loop for i in dirs for c = (dir-c i)
|
||||
for adj = (if (zerop (dir-r i))
|
||||
(let* ((dp (apply-dir-to-v3d pos i))
|
||||
(sp (aux:make-v3d :x (aux:v3d-x dp)
|
||||
:y (1- (aux:v3d-y dp))
|
||||
:z (aux:v3d-z dp))))
|
||||
(or (dir-pos-connection c dp)
|
||||
(dir-pos-connection c sp)))
|
||||
(let ((p (apply-dir-to-v3d pos i)))
|
||||
(dir-pos-connection c p)))
|
||||
for dist = (if adj (aux:v3d-dist pos (trackside-pos adj))
|
||||
(/ (dir-length i) 2))
|
||||
do
|
||||
(push dist (aref connects (dir-c i)))
|
||||
(push adj (aref connects (dir-c i))))
|
||||
(setf (get-track tdb pos) (make-track :connects connects))))
|
||||
tdb))
|
||||
|
||||
(defun gvdump (tdb)
|
||||
(with-output-to-string (stream)
|
||||
(princ "digraph{" stream)
|
||||
(loop for pos being the hash-keys of tdb using (hash-value track)
|
||||
for connections = (track-connects track) do
|
||||
(loop for i from 0 to 15 for connects = (aref connections i)
|
||||
for trackside = (make-trackside :pos pos :side i) do
|
||||
(labels ((draw-connection (from to dist)
|
||||
(format stream "\"~a\"->\"~a\"[label=\"~a\"];" from to dist)))
|
||||
(loop for j in (cddr connects)
|
||||
for target = (aref connections j)
|
||||
do (draw-connection trackside (car target) (cadr target))))))
|
||||
(write-char #\} stream)))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(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))
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
(in-package :tracks)
|
||||
|
||||
(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*)))
|
||||
|
|
@ -10,7 +10,13 @@
|
|||
(:file "graphviz")
|
||||
(:file "serialize-lib")
|
||||
(:file "nodedb")
|
||||
(:file "tracks")
|
||||
(:module "tracks"
|
||||
:serial t
|
||||
:components ((:file "package")
|
||||
(:file "conns")
|
||||
(:file "registration")
|
||||
(:file "database")
|
||||
(:file "path")))
|
||||
(:file "interlocking")
|
||||
(:file "server-wrapper")
|
||||
(:file "dataserver"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue