Implement simple track size reduction; fix conns code
parent
26d10de5dd
commit
186c0c9dae
|
@ -6,6 +6,7 @@
|
||||||
(defparameter *ildb* nil)
|
(defparameter *ildb* nil)
|
||||||
(defparameter *nodedb* nil)
|
(defparameter *nodedb* nil)
|
||||||
(defparameter *trackdb* nil)
|
(defparameter *trackdb* nil)
|
||||||
|
(defparameter *trackdb-temp* nil)
|
||||||
|
|
||||||
(defun program-entry ()
|
(defun program-entry ()
|
||||||
(let* ((argv (uiop:command-line-arguments))
|
(let* ((argv (uiop:command-line-arguments))
|
||||||
|
@ -21,12 +22,17 @@
|
||||||
(macrolet ((savefilepath (n)
|
(macrolet ((savefilepath (n)
|
||||||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
||||||
(load-data ()
|
(load-data ()
|
||||||
`(progn
|
(alexandria:with-gensyms (tf tl)
|
||||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
`(progn
|
||||||
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
||||||
(setf *trackdb* (tracks:import-data *nodedb*))
|
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
||||||
(if (not debugp) (setf *nodedb* nil))
|
(multiple-value-bind (,tf ,tl) (tracks:import-data *nodedb*)
|
||||||
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
(setf *trackdb* ,tf)
|
||||||
|
(if debugp (setf *trackdb-temp* ,tl)))
|
||||||
|
(if (not debugp) (setf *nodedb* nil))
|
||||||
|
(hunchentoot:acceptor-log-message server :info "Database updated"))))
|
||||||
|
(mainloop ()
|
||||||
|
`(loop (load-data) (sleep 20))))
|
||||||
(ywsw:safe-text-route
|
(ywsw:safe-text-route
|
||||||
dumpser
|
dumpser
|
||||||
("/dumpser/:p" :method :get) (&path (p 'string))
|
("/dumpser/:p" :method :get) (&path (p 'string))
|
||||||
|
@ -88,7 +94,7 @@
|
||||||
append (loop with side = (atil:make-tcbside :pos pos :side 1)
|
append (loop with side = (atil:make-tcbside :pos pos :side 1)
|
||||||
for i across (atil:tcbdata-routes (atil:tcb-side-b tcb))
|
for i across (atil:tcbdata-routes (atil:tcb-side-b tcb))
|
||||||
append (list side (atil:route-next i))))))
|
append (list side (atil:route-next i))))))
|
||||||
(ywsw:safe-text-route
|
(ywsw:safe-graphviz-route
|
||||||
graph-tracks ("/graph/paths" :method :get) ()
|
graph-tracks ("/graph/paths" :method :get) ()
|
||||||
("Return a simple graph of paths")
|
("Return a simple graph of paths")
|
||||||
(tracks:gvdump *trackdb*))
|
(tracks:gvdump *trackdb*))
|
||||||
|
@ -110,12 +116,7 @@
|
||||||
(with-output-to-string (s)
|
(with-output-to-string (s)
|
||||||
(describe easy-routes:*routes-mapper* s)))
|
(describe easy-routes:*routes-mapper* s)))
|
||||||
;; loop until an error occurs
|
;; loop until an error occurs
|
||||||
(handler-case (loop do
|
(if debugp (mainloop) (ignore-errors (mainloop)))
|
||||||
(load-data)
|
|
||||||
(sleep 20))
|
|
||||||
(t (c)
|
|
||||||
(format t "~&~a~%" c)
|
|
||||||
(when debugp (uiop:handle-fatal-condition c))))
|
|
||||||
(ignore-errors
|
(ignore-errors
|
||||||
(hunchentoot:stop server)
|
(hunchentoot:stop server)
|
||||||
(uiop:quit)))))
|
(uiop:quit)))))
|
||||||
|
|
|
@ -36,7 +36,7 @@
|
||||||
`(make-conns :from (dir ,c1 ,r1) :to (dir ,c2 ,r2)))
|
`(make-conns :from (dir ,c1 ,r1) :to (dir ,c2 ,r2)))
|
||||||
|
|
||||||
(defmacro conns-t ((c1 &body cb) (&optional r1 &body rb))
|
(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)
|
``(,,@(loop for c in cb and ri = rb then (cdr ri) for r = (car ri)
|
||||||
collect `(conns ,c1 ,c ,r1 ,r))))
|
collect `(conns ,c1 ,c ,r1 ,r))))
|
||||||
|
|
||||||
(defmacro conns-x ((&body cb) (&body rb))
|
(defmacro conns-x ((&body cb) (&body rb))
|
||||||
|
|
|
@ -17,6 +17,47 @@
|
||||||
(defmacro get-track (trackdb pos)
|
(defmacro get-track (trackdb pos)
|
||||||
`(gethash ,pos ,trackdb))
|
`(gethash ,pos ,trackdb))
|
||||||
|
|
||||||
|
(defmacro with-track-at-ts ((trackdb trackside &optional pos dir track) &body body)
|
||||||
|
(alexandria:once-only
|
||||||
|
(trackdb trackside)
|
||||||
|
(let ((pos (or pos (gensym))) (dir (or dir (gensym))) (track (or track (gensym))))
|
||||||
|
`(when ,trackside
|
||||||
|
(with-accessors ((,pos trackside-pos) (,dir trackside-side)) ,trackside
|
||||||
|
(let ((,track (get-track ,trackdb ,pos)))
|
||||||
|
(when ,track ,@body)))))))
|
||||||
|
|
||||||
|
(defun optimize-track-database (tdb)
|
||||||
|
(loop for pos in (loop for i being the hash-keys of tdb collect i)
|
||||||
|
for track = (gethash pos tdb)
|
||||||
|
when (and track (not (track-special track))) do
|
||||||
|
(let ((connections (track-connects track))
|
||||||
|
(unused (make-array 16 :initial-element nil)))
|
||||||
|
(labels
|
||||||
|
((ndirs (c)
|
||||||
|
(count-if-not #'null c))
|
||||||
|
(connect-dirs (from to dist)
|
||||||
|
(with-track-at-ts (tdb from nil dir track)
|
||||||
|
(let ((c (aref (track-connects track) dir)))
|
||||||
|
(setf (car c) to)
|
||||||
|
(setf (cadr c) dist)))
|
||||||
|
(with-track-at-ts (tdb to nil dir track)
|
||||||
|
(let ((c (aref (track-connects track) dir)))
|
||||||
|
(setf (car c) from)
|
||||||
|
(setf (cadr c) dist))))
|
||||||
|
(merge-2way (c)
|
||||||
|
(when (= (ndirs c) 2)
|
||||||
|
(let ((collapsed (coerce (remove-if #'null c) 'list)))
|
||||||
|
(connect-dirs (caar collapsed) (caadr collapsed)
|
||||||
|
(+ (cadar collapsed) (cadadr collapsed))))
|
||||||
|
(setf unused (make-array 16 :initial-element t))))
|
||||||
|
(removable-p ()
|
||||||
|
(loop for i across unused always i)))
|
||||||
|
(loop for dir from 0 to 15 for i across connections
|
||||||
|
when (null i) do (setf (aref unused dir) t))
|
||||||
|
(merge-2way connections)
|
||||||
|
(when (removable-p)
|
||||||
|
(remhash pos tdb))))))
|
||||||
|
|
||||||
(defun import-data (ndb)
|
(defun import-data (ndb)
|
||||||
(let ((tdb (make-track-database))
|
(let ((tdb (make-track-database))
|
||||||
;; temporary track database to read in data to
|
;; temporary track database to read in data to
|
||||||
|
@ -57,7 +98,8 @@
|
||||||
(push dist (aref connects (dir-c i)))
|
(push dist (aref connects (dir-c i)))
|
||||||
(push adj (aref connects (dir-c i))))
|
(push adj (aref connects (dir-c i))))
|
||||||
(setf (get-track tdb pos) (make-track :connects connects))))
|
(setf (get-track tdb pos) (make-track :connects connects))))
|
||||||
tdb))
|
(optimize-track-database tdb)
|
||||||
|
(values tdb tmpdb)))
|
||||||
|
|
||||||
(defun gvdump (tdb)
|
(defun gvdump (tdb)
|
||||||
(with-output-to-string (stream)
|
(with-output-to-string (stream)
|
||||||
|
|
Loading…
Reference in New Issue