Further code cleanup

dataserver.lisp

@@ -19,7 +19,8 @@
 		 `(uiop:subpathname worldpath (format nil "advtrains_~a" ,n)))
 	       (load-data ()
 		 `(progn
-		    (setf *ildb* (atil:import-data (savefilepath "interlocking.ls"))))))
+		    (setf *ildb* (atil:import-data (savefilepath "interlocking.ls")))
+		    (hunchentoot:acceptor-log-message server :info "Database updated"))))
       (ywsw:safe-text-route
        dumpser
        ("/dumpser/:p" :method :get) (&path (p 'string))

helpers.lisp

@@ -4,7 +4,9 @@
   (:export :parse-lua-number :adj-vector-of
 	   :v3d :make-v3d :v3d-x :v3d-y :v3d-z :v3d-p
 	   :string-to-v3d :hash-table-to-v3d
-	   :with-integrally-indexed-entries :with-entries-in-hash-table))
+	   :with-integrally-indexed-entries :collect-integrally-indexed-entries
+	   :collect-integrally-indexed-non-nil
+	   :with-entries-in-hash-table))
 (in-package :aux)
 
 (defmacro adj-vector-of (element-type)
@@ -60,16 +62,25 @@
        (format nil "(~a,~a,~a)" ,x ,y ,z))))
 
 (defmacro with-integrally-indexed-entries ((hash-table key value start) &body body)
-  (alexandria:with-gensyms (ht k v)
+  (let ((i (gensym)) (k (or key (gensym))) (v (or value (gensym))) (ht (gensym)))
     `(let ((,ht ,hash-table))
-       (when (hash-table-p ,ht)
+       (when ,ht
-	 (loop
+	 (do* ((,i ,start (1+ ,i)) (,k ,i ,i) (,v (gethash ,i ,ht) (gethash ,i ,ht)))
-	    for ,k = ,start then (1+ ,k)
+	      ((not ,v))
-	    for ,v = (gethash ,k ,ht)
+	   ,@body)))))
-	    while ,v
+
-	    for ,(or key (gensym)) = ,k
+(defmacro collect-integrally-indexed-entries ((result-type &body options) &body body)
-	    and ,(or value (gensym)) = ,v
+  (alexandria:with-gensyms (l)
-	    do (progn ,@body))))))
+    `(let ((,l nil))
+       (with-integrally-indexed-entries ,options (push (progn ,@body) ,l))
+       (coerce (nreverse ,l) (quote ,result-type)))))
+
+(defmacro collect-integrally-indexed-non-nil ((result-type &body options) &body body)
+  (alexandria:with-gensyms (l e)
+    `(let ((,l nil))
+       (with-integrally-indexed-entries ,options
+	 (let ((,e (progn ,@body))) (when ,e (push ,e ,l))))
+       (coerce (nreverse ,l) (quote ,result-type)))))
 
 (defmacro with-entries-in-hash-table ((hash-table &body indices) &body body)
   (alexandria:once-only
@@ -77,4 +88,4 @@
    `(when (hash-table-p ,hash-table)
       (let ,(loop for i in indices
 		  collect `(,(car i) (gethash ,(cadr i) ,hash-table ,(caddr i))))
-	  ,@body))))
+	,@body))))

interlocking.lisp

@@ -13,48 +13,40 @@
 (in-package :atil)
 
 (defstruct ars-rule
-  (match-mode (error "no ARS mode speified") :type (or (eql :ln) (eql :rc)))
+  (type (error "no ARS mode speified") :type (or (eql :ln) (eql :rc)))
-  (match-string "" :type string)
+  (match "" :type string)
-  (invert-match nil :type boolean))
+  (invertp nil :type boolean))
 
 (defmethod print-object ((obj ars-rule) *standard-output*)
-  (with-accessors ((mode ars-rule-match-mode)
+  (with-accessors ((mode ars-rule-type)
-		   (match ars-rule-match-string)
+		   (match ars-rule-match)
-		   (neg ars-rule-invert-match))
+		   (neg ars-rule-invertp))
       obj
     (print-unreadable-object (obj *standard-output*)
-      (ecase mode
+      (format t "~:[~;NOT ~]~a ~s" neg (ecase mode (:ln "LINE") (:rc "RC")) match))))
-	(:ln (format t "~:[~;NOT ~] LINE ~s" neg match))
-	(:rc (format t "~:[~;NOT ~] RC ~s" neg match))))))
 
 (defmethod json:encode-json ((obj ars-rule) &optional json:*json-output*)
-  (with-accessors ((mode ars-rule-match-mode)
+  (with-accessors ((mode ars-rule-type)
-		   (match ars-rule-match-string)
+		   (match ars-rule-match)
-		   (neg ars-rule-invert-match))
+		   (neg ars-rule-invertp))
       obj
-    (json:encode-json (ecase mode
+    (json:encode-json (list (cons "mode" (ecase mode (:ln "ln") (:rc "rc")))
-			(:ln (list (cons "mode" "ln")
+			    (cons "match" match)
-				   (cons "ln" match)
+			    (cons "n" neg)))))
-				   (cons "n" neg)))
-			(:rc (list (cons "mode" "rc")
-				   (cons "rc" match)
-				   (cons "n" neg)))))))
 
 (defstruct tcbside
   (:pos (error "No coordinates specified") :type aux:v3d)
-  (:side (error "No side specified") :type symbol))
+  (:side (error "No side specified") :type (integer 0 1)))
 
 (defmethod print-object ((obj tcbside) s)
   (with-accessors ((p tcbside-pos) (side tcbside-side))
       obj
-    (let ((tside (ecase side (:a "A") (:b "B"))))
+    (print-unreadable-object (obj s)
-      (print-unreadable-object (obj s)
+      (format s "SIDE ~a OF ~a" side p))))
-	(format s "SIDE ~a OF ~a" tside p)))))
 
 (defmethod json:encode-json ((obj tcbside) &optional json:*json-output*)
   (with-accessors ((p tcbside-pos) (side tcbside-side)) obj
-    (let ((tside (ecase side (:a "a") (:b "B"))))
+    (json:encode-json (list (cons "p" p) (cons "s" side)))))
-      (json:encode-json (list (cons "p" p) (cons "s" tside))))))
 
 (defstruct path-entry
   (next nil :type (or null tcbside))
@@ -150,9 +142,9 @@
 	  (loop
 	     with ,r = nil
 	     for ,i across ,ars-rules
-	     for ,s = (ars-rule-match-string ,i)
+	     for ,s = (ars-rule-match ,i)
-	     for ,n = (ars-rule-invert-match ,i)
+	     for ,n = (ars-rule-invertp ,i)
-	     do (when (ecase (ars-rule-match-mode ,i)
+	     do (when (ecase (ars-rule-type ,i)
 			(:ln (if ,n (string/= ,s ,ln) (string= ,s ,ln)))
 			(:rc (if ,n (not (search ,rc ,s)) (search ,rc ,s))))
 		  (setf ,r t))
@@ -200,56 +192,43 @@
 	finally (return ,locks))))
 
 (defmacro parse-path (pathht)
-  (alexandria:with-gensyms (ht i ent path next p s locks tcbs)
+  (alexandria:with-gensyms (ent next p s locks)
-    `(loop
+    `(aux:collect-integrally-indexed-non-nil
-	with ,ht = (or ,pathht (make-hash-table))
+      ((vector path-entry) ,pathht nil ,ent 1)
-	and ,path = (aux:adj-vector-of 'path-entry)
+      (aux:with-entries-in-hash-table (,ent (,next "next") (,locks "locks"))
-	for ,i = 1 then (1+ ,i)
+	(aux:with-entries-in-hash-table (,next (,p "p") (,s "s"))
-	for ,ent = (gethash ,i ,ht)
+	  (make-path-entry :next (make-tcbside :pos (aux:hash-table-to-v3d ,p)
-	while ,ent
+					       :side (1- ,s))
-	for ,next = (gethash "next" ,ent)
+			   :locks (parse-route-locks ,locks)))))))
-	for ,p = (if ,next (aux:hash-table-to-v3d (gethash "p" ,next)) nil)
-	and ,s = (if ,next (ecase (gethash "s" ,next) (1 :a) (2 :b)) nil)
-	and ,locks = (parse-route-locks (gethash "locks" ,ent))
-	for ,tcbs = (if (and ,p ,s) (make-tcbside :pos ,p :side ,s) nil)
-	do (vector-push-extend (make-path-entry :next ,tcbs :locks ,locks)
-			       ,path)
-	finally (return ,path))))
 
 (defmacro parse-ars-rules (rulesht)
-  (alexandria:with-gensyms (ht rules ent neg ln rc ftype match)
+  (alexandria:with-gensyms (ent neg ln rc ftype match)
-    `(let ((,rules (aux:adj-vector-of 'ars-rule)) (,ht ,rulesht))
+    (alexandria:once-only
-       (cond
+     (rulesht)
-	 ((not (hash-table-p ,ht)) ,rules)
+     `(cond
-	 ((gethash "default" ,ht) t)
+	((not (hash-table-p ,rulesht)) (aux:adj-vector-of 'ars-rule))
-	 (t (progn
+	((gethash "default" ,rulesht) t)
-	      (aux:with-integrally-indexed-entries (,ht nil ,ent 1)
+	(t (aux:collect-integrally-indexed-non-nil
-		(aux:with-entries-in-hash-table (,ent (,neg "n") (,ln "ln") (,rc "rc"))
+	    ((vector ars-rule) ,rulesht nil ,ent 1)
-		  (alexandria:when-let ((,ftype (cond (,ln :ln) (,rc :rc) (t nil)))
+	    (aux:with-entries-in-hash-table (,ent (,ln "ln") (,rc "rc") (,neg "n"))
-					(,match (or ,ln ,rc)))
+	      (alexandria:when-let ((,ftype (cond (,ln :ln) (,rc :rc) (t nil)))
-		    (vector-push-extend (make-ars-rule :match-mode ,ftype
+				    (,match (or ,ln ,rc)))
-						       :match-string ,match
+		(make-ars-rule :type ,ftype :match ,match :invertp ,neg)))))))))
-						       :invert-match ,neg)
-					,rules))))
-	      ,rules))))))
 
 (defmacro parse-route (routeinfo)
-  (alexandria:with-gensyms (rname rars rpath)
+  (alexandria:with-gensyms (name ars)
     (alexandria:once-only
      (routeinfo)
-     `(let ((,rname (gethash "name" ,routeinfo))
+     `(aux:with-entries-in-hash-table (,routeinfo (,name "name") (,ars "ars"))
-	    (,rars (parse-ars-rules (gethash "ars" ,routeinfo)))
+	(make-route :name ,name
-	    (,rpath (parse-path ,routeinfo)))
+		    :ars-rules (parse-ars-rules ,ars)
-	(make-route :name ,rname
+		    :path (parse-path ,routeinfo))))))
-		    :ars-rules ,rars
-		    :path ,rpath)))))
 
 (defmacro read-routes (routeht)
-  (alexandria:with-gensyms (routelist ent)
+  (alexandria:with-gensyms (ent)
-    `(let ((,routelist (aux:adj-vector-of 'route)))
+    `(aux:collect-integrally-indexed-entries
-       (aux:with-integrally-indexed-entries (,routeht nil ,ent 1)
+      ((vector route) ,routeht nil ,ent 1)
-	 (vector-push-extend (parse-route ,ent) ,routelist))
+      (parse-route ,ent))))
-       ,routelist)))
 
 (defmacro read-tcb-side (side)
   (alexandria:with-gensyms (ts spos sname routes)