From c41f1be44ab76da6cc3a66b90c9a6edc604d125d Mon Sep 17 00:00:00 2001 From: y5nw Date: Fri, 20 Aug 2021 15:56:30 +0200 Subject: [PATCH] Further code cleanup --- dataserver.lisp | 3 +- helpers.lisp | 33 ++++++++----- interlocking.lisp | 119 +++++++++++++++++++--------------------------- 3 files changed, 73 insertions(+), 82 deletions(-) diff --git a/dataserver.lisp b/dataserver.lisp index a8facec..ce3ae2f 100644 --- a/dataserver.lisp +++ b/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)) diff --git a/helpers.lisp b/helpers.lisp index e894459..ced7ded 100644 --- a/helpers.lisp +++ b/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) - (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)))))) + (when ,ht + (do* ((,i ,start (1+ ,i)) (,k ,i ,i) (,v (gethash ,i ,ht) (gethash ,i ,ht))) + ((not ,v)) + ,@body))))) + +(defmacro collect-integrally-indexed-entries ((result-type &body options) &body body) + (alexandria:with-gensyms (l) + `(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)))) diff --git a/interlocking.lisp b/interlocking.lisp index f7d6512..e9d9789 100644 --- a/interlocking.lisp +++ b/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))) - (match-string "" :type string) - (invert-match nil :type boolean)) + (type (error "no ARS mode speified") :type (or (eql :ln) (eql :rc))) + (match "" :type string) + (invertp nil :type boolean)) (defmethod print-object ((obj ars-rule) *standard-output*) - (with-accessors ((mode ars-rule-match-mode) - (match ars-rule-match-string) - (neg ars-rule-invert-match)) + (with-accessors ((mode ars-rule-type) + (match ars-rule-match) + (neg ars-rule-invertp)) obj (print-unreadable-object (obj *standard-output*) - (ecase mode - (:ln (format t "~:[~;NOT ~] LINE ~s" neg match)) - (:rc (format t "~:[~;NOT ~] RC ~s" neg match)))))) + (format t "~:[~;NOT ~]~a ~s" neg (ecase mode (:ln "LINE") (:rc "RC")) match)))) (defmethod json:encode-json ((obj ars-rule) &optional json:*json-output*) - (with-accessors ((mode ars-rule-match-mode) - (match ars-rule-match-string) - (neg ars-rule-invert-match)) + (with-accessors ((mode ars-rule-type) + (match ars-rule-match) + (neg ars-rule-invertp)) obj - (json:encode-json (ecase mode - (:ln (list (cons "mode" "ln") - (cons "ln" match) - (cons "n" neg))) - (:rc (list (cons "mode" "rc") - (cons "rc" match) - (cons "n" neg))))))) + (json:encode-json (list (cons "mode" (ecase mode (:ln "ln") (:rc "rc"))) + (cons "match" 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) - (format s "SIDE ~a OF ~a" tside p))))) + (print-unreadable-object (obj s) + (format s "SIDE ~a OF ~a" side 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" tside)))))) + (json:encode-json (list (cons "p" p) (cons "s" side))))) (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 ,n = (ars-rule-invert-match ,i) - do (when (ecase (ars-rule-match-mode ,i) + for ,s = (ars-rule-match ,i) + for ,n = (ars-rule-invertp ,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) - `(loop - with ,ht = (or ,pathht (make-hash-table)) - and ,path = (aux:adj-vector-of 'path-entry) - for ,i = 1 then (1+ ,i) - for ,ent = (gethash ,i ,ht) - while ,ent - for ,next = (gethash "next" ,ent) - 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)))) + (alexandria:with-gensyms (ent next p s locks) + `(aux:collect-integrally-indexed-non-nil + ((vector path-entry) ,pathht nil ,ent 1) + (aux:with-entries-in-hash-table (,ent (,next "next") (,locks "locks")) + (aux:with-entries-in-hash-table (,next (,p "p") (,s "s")) + (make-path-entry :next (make-tcbside :pos (aux:hash-table-to-v3d ,p) + :side (1- ,s)) + :locks (parse-route-locks ,locks))))))) (defmacro parse-ars-rules (rulesht) - (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)))))) + (alexandria:with-gensyms (ent neg ln rc ftype match) + (alexandria:once-only + (rulesht) + `(cond + ((not (hash-table-p ,rulesht)) (aux:adj-vector-of 'ars-rule)) + ((gethash "default" ,rulesht) t) + (t (aux:collect-integrally-indexed-non-nil + ((vector ars-rule) ,rulesht nil ,ent 1) + (aux:with-entries-in-hash-table (,ent (,ln "ln") (,rc "rc") (,neg "n")) + (alexandria:when-let ((,ftype (cond (,ln :ln) (,rc :rc) (t nil))) + (,match (or ,ln ,rc))) + (make-ars-rule :type ,ftype :match ,match :invertp ,neg))))))))) (defmacro parse-route (routeinfo) - (alexandria:with-gensyms (rname rars rpath) + (alexandria:with-gensyms (name ars) (alexandria:once-only (routeinfo) - `(let ((,rname (gethash "name" ,routeinfo)) - (,rars (parse-ars-rules (gethash "ars" ,routeinfo))) - (,rpath (parse-path ,routeinfo))) - (make-route :name ,rname - :ars-rules ,rars - :path ,rpath))))) + `(aux:with-entries-in-hash-table (,routeinfo (,name "name") (,ars "ars")) + (make-route :name ,name + :ars-rules (parse-ars-rules ,ars) + :path (parse-path ,routeinfo)))))) (defmacro read-routes (routeht) - (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))) + (alexandria:with-gensyms (ent) + `(aux:collect-integrally-indexed-entries + ((vector route) ,routeht nil ,ent 1) + (parse-route ,ent)))) (defmacro read-tcb-side (side) (alexandria:with-gensyms (ts spos sname routes)