Cleanup code

helpers.lisp

@@ -3,7 +3,8 @@
   (:nicknames :helpers :aux)
   (: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))
+	   :string-to-v3d :hash-table-to-v3d
+	   :with-integrally-indexed-entries :with-entries-in-hash-table))
 (in-package :aux)
 
 (defmacro adj-vector-of (element-type)
@@ -57,3 +58,23 @@
     `(with-accessors ((,x v3d-x) (,y v3d-y) (,z v3d-z))
 	 ,obj
        (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 ((,ht ,hash-table))
+       (when (hash-table-p ,ht)
+	 (loop
+	    for ,k = ,start then (1+ ,k)
+	    for ,v = (gethash ,k ,ht)
+	    while ,v
+	    for ,(or key (gensym)) = ,k
+	    and ,(or value (gensym)) = ,v
+	    do (progn ,@body))))))
+
+(defmacro with-entries-in-hash-table ((hash-table &body indices) &body body)
+  (alexandria:once-only
+   (hash-table)
+   `(when (hash-table-p ,hash-table)
+      (let ,(loop for i in indices
+		  collect `(,(car i) (gethash ,(cadr i) ,hash-table ,(caddr i))))
+	  ,@body))))

interlocking.lisp

@@ -13,7 +13,7 @@
 (in-package :atil)
 
 (defstruct ars-rule
-  (match-mode :default :type symbol)
+  (match-mode (error "no ARS mode speified") :type (or (eql :ln) (eql :rc)))
   (match-string "" :type string)
   (invert-match nil :type boolean))
 
@@ -24,10 +24,8 @@
       obj
     (print-unreadable-object (obj *standard-output*)
       (ecase mode
-	(:default (princ "ARS RULE MATCHING EVERYTHING"))
-	(:comment (format t "ARS COMMENT ~s" match))
-	(:ln (format t "ARS RULE~:[~; NOT~] MATCHING LINE ~s" neg match))
-	(:rc (format t "ARS RULE~:[~; NOT~] MATCHING RC ~s" neg 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)
@@ -35,9 +33,6 @@
 		   (neg ars-rule-invert-match))
       obj
     (json:encode-json (ecase mode
-			(:default (list (cons "mode" "default")))
-			(:comment (list (cons "mode" "comment")
-					(cons "comment" match)))
 			(:ln (list (cons "mode" "ln")
 				   (cons "ln" match)
 				   (cons "n" neg)))
@@ -84,15 +79,17 @@
 
 (defstruct route
   (name "" :type string)
-  (ars-rules (aux:adj-vector-of 'ars-rule) :type (vector ars-rule))
+  (ars-rules (aux:adj-vector-of 'ars-rule) :type (or (eql t) (vector ars-rule)))
   (path (aux:adj-vector-of 'path-entry) :type (vector path-entry)))
 
 (defmethod print-object ((obj route) s)
   (with-accessors ((name route-name) (ars route-ars-rules) (path route-path))
       obj
     (print-unreadable-object (obj s)
-      (format s "ROUTE ~:_~:i~s~[~*~:; ~:_WITH ~a~]"
-	      name (length ars) ars)
+      (format s "ROUTE ~:_~:i~s" name)
+      (cond
+	((eql ars t) (format s " ~:_MATCHING EVERY TRAIN"))
+	((> (length ars) 0) (format s " ~:_MATCHING ~a" ars)))
       (when (> (length path) 0)
 	(pprint-indent :block 1 s)
 	(loop for i across path do (format s " ~_~a" i))))))
@@ -149,18 +146,18 @@
   (alexandria:with-gensyms (i r s n)
     (alexandria:once-only
      (ars-rules ln rc)
-     `(loop
-	 with ,r = nil
-	 while (not ,r)
-	 for ,i across ,ars-rules
-	 for ,s = (ars-rule-match-string ,i)
-	 for ,n = (ars-rule-invert-match ,i)
-	 do (setf ,r (or ,r (ecase (ars-rule-match-mode ,i)
-			      (:default t)
-			      (:comment nil)
-			      (:ln (if ,n (string/= ,s ,ln) (string= ,s ,ln)))
-			      (:rc (if ,n (not (search ,rc ,s)) (search ,rc ,s))))))
-	 finally (return ,r)))))
+     `(if (eql ,ars-rules t) t
+	  (loop
+	     with ,r = nil
+	     for ,i across ,ars-rules
+	     for ,s = (ars-rule-match-string ,i)
+	     for ,n = (ars-rule-invert-match ,i)
+	     do (when (ecase (ars-rule-match-mode ,i)
+			(:ln (if ,n (string/= ,s ,ln) (string= ,s ,ln)))
+			(:rc (if ,n (not (search ,rc ,s)) (search ,rc ,s))))
+		  (setf ,r t))
+	     until ,r
+	     finally (return ,r))))))
 
 (defmacro match-route (routelist ln rc)
   (alexandria:with-gensyms (i r)
@@ -220,26 +217,21 @@
 	finally (return ,path))))
 
 (defmacro parse-ars-rules (rulesht)
-  (alexandria:with-gensyms (ht rules i ent neg def ln rc c ftype match)
-    `(loop
-	with ,rules = (aux:adj-vector-of 'ars-rule)
-	and ,ht = (or ,rulesht (make-hash-table))
-	for ,i = 1 then (1+ ,i)
-	for ,ent = (gethash ,i ,ht)
-	while ,ent
-	for ,neg = (gethash "n" ,ent nil)
-	and ,def = (gethash "default" ,ent nil)
-	and ,ln = (gethash "ln" ,ent nil)
-	and ,rc = (gethash "rc" ,ent nil)
-	and ,c = (gethash "c" ,ent nil)
-	for ,ftype = (cond (,def :default) (,ln :ln) (,rc :rc) (,c :comment) (t nil))
-	and ,match = (if ,def "" (or ,ln ,rc ,c))
-	when ,ftype
-	do (vector-push-extend (make-ars-rule :match-mode ,ftype
-					      :match-string ,match
-					      :invert-match ,neg)
-			       ,rules)
-	finally (return ,rules))))
+  (alexandria:with-gensyms (ht rules ent neg ln rc ftype match)
+    `(let ((,rules (aux:adj-vector-of 'ars-rule)) (,ht ,rulesht))
+       (cond
+	 ((not (hash-table-p ,ht)) ,rules)
+	 ((gethash "default" ,ht) t)
+	 (t (progn
+	      (aux:with-integrally-indexed-entries (,ht nil ,ent 1)
+		(aux:with-entries-in-hash-table (,ent (,neg "n") (,ln "ln") (,rc "rc"))
+		  (alexandria:when-let ((,ftype (cond (,ln :ln) (,rc :rc) (t nil)))
+					(,match (or ,ln ,rc)))
+		    (vector-push-extend (make-ars-rule :match-mode ,ftype
+						       :match-string ,match
+						       :invert-match ,neg)
+					,rules))))
+	      ,rules))))))
 
 (defmacro parse-route (routeinfo)
   (alexandria:with-gensyms (rname rars rpath)
@@ -253,14 +245,11 @@
 		    :path ,rpath)))))
 
 (defmacro read-routes (routeht)
-  (alexandria:with-gensyms (routelist i ent)
-    `(loop
-	with ,routelist = (aux:adj-vector-of 'route)
-	for ,i = 1 then (1+ ,i)
-	for ,ent = (gethash ,i ,routeht nil)
-	while ,ent
-	do (vector-push-extend (parse-route ,ent) ,routelist)
-	finally (return ,routelist))))
+  (alexandria:with-gensyms (routelist ent)
+    `(let ((,routelist (aux:adj-vector-of 'route)))
+       (aux:with-integrally-indexed-entries (,routeht nil ,ent 1)
+	 (vector-push-extend (parse-route ,ent) ,routelist))
+       ,routelist)))
 
 (defmacro read-tcb-side (side)
   (alexandria:with-gensyms (ts spos sname routes)
@@ -276,7 +265,7 @@
 		      :routes ,routes)))))
 
 (defun import-data (fn)
-  (let ((ht (atsl:from-file fn :hash-table)))
+  (atsl:with-data-from-file (ht fn :hash-table)
     (let ((tcbs (aux:adj-vector-of 'tcb)))
       (loop
 	 for poss being each hash-key of (gethash "tcbs" ht)

serialize-lib.lisp

@@ -1,7 +1,7 @@
 (defpackage :advtrains-serialize-lib
   (:use :cl :parse-float)
   (:nicknames :atsl)
-  (:export :from-file :from-stream))
+  (:export :from-file :from-stream :with-data-from-file))
 (in-package :atsl)
 
 (defmacro unescape (seq)
@@ -88,3 +88,6 @@
     `(let ((,fn ,filename))
        (with-open-file (,stream ,fn)
 	 (from-stream ,stream ,restype)))))
+
+(defmacro with-data-from-file ((var &rest options) &body body)
+  `(let ((,var (from-file ,@options))) ,@body))