109 lines
3.8 KiB
Common Lisp
109 lines
3.8 KiB
Common Lisp
(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 t))))))
|
|
|
|
(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) () t))
|
|
(("cr") (conns-t (0 7) () t))
|
|
(("swlst" "swlcr") (conns-t (0 8 7) () t))
|
|
(("swrst" "swrcr") (conns-t (0 8 9) () t))))
|
|
|
|
(defmacro register-y-turnout-tracks (prefix)
|
|
`(register-rotatable-track-with-preset
|
|
,prefix
|
|
(("l" "r") (conns-t (0 7 9) () t))))
|
|
|
|
(defmacro register-3way-turnout-tracks (prefix)
|
|
`(register-rotatable-track-with-preset
|
|
,prefix
|
|
(("l" "s" "r") (conns-t (0 7 8 9) () t))))
|
|
|
|
(defmacro register-slope-tracks (prefix)
|
|
`(register-rotatable-track-with-preset
|
|
,prefix
|
|
(("vst1" "vst31" "vst32") (conns-t (8 0) (0 0) t))
|
|
(("vst2" "vst33") (conns-t (8 0) (0 1) t))))
|
|
|
|
(defmacro register-straightonly-tracks (prefix)
|
|
`(register-rotatable-track-with-preset
|
|
,prefix
|
|
(("st") (conns-t (0 8) () t))))
|
|
|
|
(defmacro register-perp-xing-tracks (prefix)
|
|
`(register-rotatable-track-with-preset
|
|
,prefix
|
|
(("st") (conns-x (0 8 4 12) () t))))
|
|
|
|
(defmacro register-90+x-xing-tracks (prefix)
|
|
`(register-track-with-preset
|
|
,prefix
|
|
(("30l") (conns-x (0 8 1 9) () t))
|
|
(("45l") (conns-x (0 8 2 10) () t))
|
|
(("60l") (conns-x (0 8 3 11) () t))
|
|
(("60r") (conns-x (0 8 5 13) () t))
|
|
(("45r") (conns-x (0 8 6 14) () t))
|
|
(("30r") (conns-x (0 8 7 15) () t))))
|
|
|
|
(defmacro register-diag-xing-tracks (prefix)
|
|
`(register-track-with-preset
|
|
,prefix
|
|
(("30l45r") (conns-x (1 9 6 14) () t))
|
|
(("60l30l") (conns-x (3 11 1 9) () t))
|
|
(("60l45r") (conns-x (3 11 6 14) () t))
|
|
(("60l60r") (conns-x (3 11 5 13) () t))
|
|
(("60r45l") (conns-x (5 13 2 10) () t))
|
|
(("60r30r") (conns-x (5 13 7 15) () t))
|
|
(("30r45l") (conns-x (7 15 2 10) () t))))
|
|
|
|
(defun init-tracks ()
|
|
(init-shared-dirs)
|
|
(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*)))
|