Parse node database; allow slightly easier debugging
y5nw
parent
3a3a9d2020
commit
57b3578a33
17
LICENSE
17
LICENSE
|
|
@ -35,3 +35,20 @@ You should have received a copy of the GNU Affero General Public License
|
|||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
================================================================================
|
||||
|
||||
ywatds has certain code written based on advtrains, which has the following
|
||||
license statement:
|
||||
|
||||
Copyright (C) 2016-2020 Moritz Blei (orwell96) and contributors
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Affero General Public License as
|
||||
published by the Free Software Foundation, either version 3 of the
|
||||
License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Affero General Public License for more details.
|
||||
|
||||
================================================================================
|
||||
|
|
|
|||
|
|
@ -4,6 +4,8 @@
|
|||
(in-package :ywatds)
|
||||
|
||||
(defparameter *ildb* nil)
|
||||
(defparameter *nodedb* nil)
|
||||
(defparameter *trackdb* nil)
|
||||
|
||||
(defun program-entry ()
|
||||
(let* ((argv (uiop:command-line-arguments))
|
||||
|
|
@ -13,6 +15,7 @@
|
|||
:want-existing t
|
||||
:ensure-absolute t))
|
||||
(serverport (parse-integer (cadr argv)))
|
||||
(debugp (member "--debug" (cddr argv) :test #'string=))
|
||||
(server (make-instance 'easy-routes:routes-acceptor
|
||||
:port serverport)))
|
||||
(macrolet ((savefilepath (n)
|
||||
|
|
@ -20,6 +23,9 @@
|
|||
(load-data ()
|
||||
`(progn
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
||||
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
||||
(setf *trackdb* (tracks:import-data *nodedb*))
|
||||
(if (not debugp) (setf *nodedb* nil))
|
||||
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
||||
(ywsw:safe-text-route
|
||||
dumpser
|
||||
|
|
@ -31,6 +37,11 @@
|
|||
("/pretty_dump/interlocking" :method :get) ()
|
||||
("Return the interlocking database that is in use")
|
||||
(format nil "~s" *ildb*))
|
||||
(ywsw:safe-text-route
|
||||
pretty-dump-registered-tracks
|
||||
("/pretty_dump/registered_tracks" :method :get) ()
|
||||
("Return the list of tracks known to the server")
|
||||
(tracks:dump-track-definitions))
|
||||
(ywsw:safe-json-route
|
||||
tcbinfo
|
||||
("/tcbinfo" :method :get) ()
|
||||
|
|
@ -77,6 +88,10 @@
|
|||
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")
|
||||
(tracks:gvdump *trackdb*))
|
||||
(ywsw:defsafe
|
||||
docroute-master ("/doc" :method :get) ()
|
||||
(let ((entries (loop for i being the hash-keys of easy-routes::*routes*
|
||||
|
|
@ -89,7 +104,7 @@
|
|||
`("ul" () ,@(loop for i in (stable-sort entries #'string<)
|
||||
collect `("li" () ("a" ("href" ,(format nil "/doc/http_~a" i))
|
||||
,i)))))))
|
||||
|
||||
(tracks:init-tracks)
|
||||
(hunchentoot:start server)
|
||||
(hunchentoot:acceptor-log-message server :info "~s"
|
||||
(with-output-to-string (s)
|
||||
|
|
@ -98,7 +113,9 @@
|
|||
(handler-case (loop do
|
||||
(load-data)
|
||||
(sleep 20))
|
||||
(t (c) (format t "~&~a~%" c)))
|
||||
(t (c)
|
||||
(format t "~&~a~%" c)
|
||||
(when debugp (uiop:handle-fatal-condition c))))
|
||||
(ignore-errors
|
||||
(hunchentoot:stop server)
|
||||
(uiop:quit)))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,40 @@
|
|||
(defpackage :nodedb
|
||||
(:nicknames :ndb)
|
||||
(:use :cl)
|
||||
(:export :import-data :loopdb))
|
||||
(in-package :ndb)
|
||||
|
||||
(defmacro loopdb ((db pos name param2) &body body)
|
||||
(alexandria:with-gensyms (nodes names k v id)
|
||||
(alexandria:once-only
|
||||
(db)
|
||||
`(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))))
|
||||
|
||||
;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html
|
||||
(defun import-data (fn)
|
||||
(with-open-file (stream fn :element-type '(unsigned-byte 8))
|
||||
(labels ((read-u8 () (read-byte stream nil nil))
|
||||
(read-u16 () (let ((msb (read-u8)) (lsb (read-u8)))
|
||||
(if (and msb lsb) (+ (* 256 msb) lsb))))
|
||||
(read-int () (let ((i (read-u16))) (if i (- i 32768))))
|
||||
(read-ln ()
|
||||
(with-output-to-string (s)
|
||||
(loop for c = (read-u8) while c for char = (code-char c)
|
||||
until (char= char #\Newline) do (write-char char s))))
|
||||
(read-node-entry ()
|
||||
(let ((x (read-int)) (y (read-int)) (z (read-int)) (v (read-int)))
|
||||
(if (and x y z v) (cons (aux:make-v3d :x x :y y :z z) v))))
|
||||
(validp (ent nodelist)
|
||||
(and ent (gethash (ash (cdr ent) -2) nodelist))))
|
||||
(assert (= (read-u8) 1))
|
||||
(let ((nodelist (make-hash-table :test #'equal))
|
||||
(nodes (make-hash-table :test #'equalp)))
|
||||
(loop repeat (read-int)
|
||||
for id = (read-int) for name = (read-ln)
|
||||
do (setf (gethash id nodelist) name))
|
||||
(loop for ent = (read-node-entry) while (validp ent nodelist)
|
||||
do (setf (gethash (car ent) nodes) (cdr ent)))
|
||||
(cons nodelist nodes)))))
|
||||
|
|
@ -0,0 +1,246 @@
|
|||
(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)))
|
||||
|
|
@ -9,6 +9,8 @@
|
|||
:components ((:file "helpers")
|
||||
(:file "graphviz")
|
||||
(:file "serialize-lib")
|
||||
(:file "nodedb")
|
||||
(:file "tracks")
|
||||
(:file "interlocking")
|
||||
(:file "server-wrapper")
|
||||
(:file "dataserver"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue