Implement simple track size reduction; fix conns code
parent
26d10de5dd
commit
186c0c9dae
|
@ -6,6 +6,7 @@
|
|||
(defparameter *ildb* nil)
|
||||
(defparameter *nodedb* nil)
|
||||
(defparameter *trackdb* nil)
|
||||
(defparameter *trackdb-temp* nil)
|
||||
|
||||
(defun program-entry ()
|
||||
(let* ((argv (uiop:command-line-arguments))
|
||||
|
@ -21,12 +22,17 @@
|
|||
(macrolet ((savefilepath (n)
|
||||
`(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
|
||||
(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"))))
|
||||
(alexandria:with-gensyms (tf tl)
|
||||
`(progn
|
||||
(setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
|
||||
(setf *nodedb* (ndb:import-data (savefilepath "ndb4.ls")))
|
||||
(multiple-value-bind (,tf ,tl) (tracks:import-data *nodedb*)
|
||||
(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
|
||||
dumpser
|
||||
("/dumpser/:p" :method :get) (&path (p 'string))
|
||||
|
@ -88,7 +94,7 @@
|
|||
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-text-route
|
||||
(ywsw:safe-graphviz-route
|
||||
graph-tracks ("/graph/paths" :method :get) ()
|
||||
("Return a simple graph of paths")
|
||||
(tracks:gvdump *trackdb*))
|
||||
|
@ -110,12 +116,7 @@
|
|||
(with-output-to-string (s)
|
||||
(describe easy-routes:*routes-mapper* s)))
|
||||
;; loop until an error occurs
|
||||
(handler-case (loop do
|
||||
(load-data)
|
||||
(sleep 20))
|
||||
(t (c)
|
||||
(format t "~&~a~%" c)
|
||||
(when debugp (uiop:handle-fatal-condition c))))
|
||||
(if debugp (mainloop) (ignore-errors (mainloop)))
|
||||
(ignore-errors
|
||||
(hunchentoot:stop server)
|
||||
(uiop:quit)))))
|
||||
|
|
|
@ -36,7 +36,7 @@
|
|||
`(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)
|
||||
``(,,@(loop for c in cb and ri = rb then (cdr ri) for r = (car ri)
|
||||
collect `(conns ,c1 ,c ,r1 ,r))))
|
||||
|
||||
(defmacro conns-x ((&body cb) (&body rb))
|
||||
|
|
|
@ -17,6 +17,47 @@
|
|||
(defmacro get-track (trackdb pos)
|
||||
`(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)
|
||||
(let ((tdb (make-track-database))
|
||||
;; temporary track database to read in data to
|
||||
|
@ -57,7 +98,8 @@
|
|||
(push dist (aref connects (dir-c i)))
|
||||
(push adj (aref connects (dir-c i))))
|
||||
(setf (get-track tdb pos) (make-track :connects connects))))
|
||||
tdb))
|
||||
(optimize-track-database tdb)
|
||||
(values tdb tmpdb)))
|
||||
|
||||
(defun gvdump (tdb)
|
||||
(with-output-to-string (stream)
|
||||
|
|
Loading…
Reference in New Issue