Implement simple track size reduction; fix conns code

dataserver.lisp

@@ -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)))))

tracks/conns.lisp

@@ -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))

tracks/database.lisp

@@ -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)