From 26d10de5dd0f3bcdf2a280338c368237aa96e0bb Mon Sep 17 00:00:00 2001 From: y5nw Date: Sun, 22 Aug 2021 15:58:32 +0200 Subject: [PATCH] Redo track system to handle more complicated situations --- dataserver.lisp | 6 +- helpers.lisp | 9 +- nodedb.lisp | 3 +- tracks.lisp | 246 --------------------------------------- tracks/conns.lisp | 92 +++++++++++++++ tracks/database.lisp | 74 ++++++++++++ tracks/package.lisp | 14 +++ tracks/path.lisp | 0 tracks/registration.lisp | 107 +++++++++++++++++ ywatds.asd | 8 +- 10 files changed, 307 insertions(+), 252 deletions(-) delete mode 100644 tracks.lisp create mode 100644 tracks/conns.lisp create mode 100644 tracks/database.lisp create mode 100644 tracks/package.lisp create mode 100644 tracks/path.lisp create mode 100644 tracks/registration.lisp diff --git a/dataserver.lisp b/dataserver.lisp index 196e197..f09bf9f 100644 --- a/dataserver.lisp +++ b/dataserver.lisp @@ -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) () diff --git a/helpers.lisp b/helpers.lisp index ced7ded..2aef819 100644 --- a/helpers.lisp +++ b/helpers.lisp @@ -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)) diff --git a/nodedb.lisp b/nodedb.lisp index 4164cb7..8fe63b6 100644 --- a/nodedb.lisp +++ b/nodedb.lisp @@ -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) diff --git a/tracks.lisp b/tracks.lisp deleted file mode 100644 index 970d960..0000000 --- a/tracks.lisp +++ /dev/null @@ -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))) diff --git a/tracks/conns.lisp b/tracks/conns.lisp new file mode 100644 index 0000000..7561531 --- /dev/null +++ b/tracks/conns.lisp @@ -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)))))) diff --git a/tracks/database.lisp b/tracks/database.lisp new file mode 100644 index 0000000..4ba2b67 --- /dev/null +++ b/tracks/database.lisp @@ -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))) diff --git a/tracks/package.lisp b/tracks/package.lisp new file mode 100644 index 0000000..91cc38b --- /dev/null +++ b/tracks/package.lisp @@ -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)) diff --git a/tracks/path.lisp b/tracks/path.lisp new file mode 100644 index 0000000..e69de29 diff --git a/tracks/registration.lisp b/tracks/registration.lisp new file mode 100644 index 0000000..837bb2a --- /dev/null +++ b/tracks/registration.lisp @@ -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*))) diff --git a/ywatds.asd b/ywatds.asd index 1778a7d..a843a94 100644 --- a/ywatds.asd +++ b/ywatds.asd @@ -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"))