diff --git a/LICENSE b/LICENSE index 8a47f74..d5817b6 100644 --- a/LICENSE +++ b/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 . ================================================================================ + +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. + +================================================================================ diff --git a/dataserver.lisp b/dataserver.lisp index 97a53ee..196e197 100644 --- a/dataserver.lisp +++ b/dataserver.lisp @@ -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))))) diff --git a/nodedb.lisp b/nodedb.lisp new file mode 100644 index 0000000..4164cb7 --- /dev/null +++ b/nodedb.lisp @@ -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))))) diff --git a/tracks.lisp b/tracks.lisp new file mode 100644 index 0000000..970d960 --- /dev/null +++ b/tracks.lisp @@ -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))) diff --git a/ywatds.asd b/ywatds.asd index 4d92d21..1778a7d 100644 --- a/ywatds.asd +++ b/ywatds.asd @@ -9,6 +9,8 @@ :components ((:file "helpers") (:file "graphviz") (:file "serialize-lib") + (:file "nodedb") + (:file "tracks") (:file "interlocking") (:file "server-wrapper") (:file "dataserver"))