Fix hash table serialization; implement dumping basic TCB information

dataserver.lisp

@@ -13,16 +13,18 @@
 	 (serverport (parse-integer (cadr argv)))
 	 (server (make-instance 'easy-routes:routes-acceptor
 				:port serverport)))
-    (ywsw:safe-text-route
-     ("/dumpser/:p" :method :get) (&path (p 'string))
-     (format nil "~s"
-	     (atsl:from-file
-	      (uiop:subpathname worldpath (format nil "advtrains_~a" p))
-	      :alist)))
-    (hunchentoot:start server)
-    ;; loop until an error occurs
-    (handler-case (loop (sleep most-positive-fixnum))
-      (t (c) (format t "~&~a~%" c)))
-    (ignore-errors
-      (hunchentoot:stop server)
-      (uiop:quit))))
+    (macrolet ((savefilepath (n)
+		 `(uiop:subpathname worldpath (format nil "advtrains_~a" ,n))))
+      (ywsw:safe-text-route
+       ("/dumpser/:p" :method :get) (&path (p 'string))
+       (format nil "~s" (atsl:from-file (savefilepath p) :alist)))
+      (ywsw:safe-text-route
+       ("/pretty_dump/interlocking" :method :get) ()
+       (format nil "~s" (atil:import-data (savefilepath "interlocking.ls"))))
+      (hunchentoot:start server)
+      ;; loop until an error occurs
+      (handler-case (loop (sleep most-positive-fixnum))
+	(t (c) (format t "~&~a~%" c)))
+      (ignore-errors
+	(hunchentoot:stop server)
+	(uiop:quit)))))

helpers.lisp

@@ -0,0 +1,46 @@
+(defpackage :advtrains-helpers
+  (:use :cl :parse-float)
+  (: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))
+(in-package :aux)
+
+(defmacro adj-vector-of (element-type)
+  `(make-array 0
+	       :element-type ,element-type
+	       :adjustable t
+	       :fill-pointer t))
+
+(deftype lua-number () '(or float integer))
+
+(defmacro parse-lua-number (str)
+  (alexandria:with-gensyms (n)
+    `(let ((,n (parse-float ,str :type 'real)))
+       (if (typep ,n 'ratio) (coerce ,n 'float) ,n))))
+
+(defstruct v3d
+  (x 0 :type lua-number)
+  (y 0 :type lua-number)
+  (z 0 :type lua-number))
+
+(defmethod print-object ((obj v3d) stream)
+  (with-accessors ((x v3d-x) (y v3d-y) (z v3d-z)) obj
+    (print-unreadable-object (obj stream)
+      (format stream "~a,~a,~a" x y z))))
+
+(defmacro string-to-v3d (str)
+  (alexandria:with-gensyms (xs ys zs)
+    `(cl-ppcre:register-groups-bind
+      (,xs ,ys ,zs)
+      ("^\\((-?[0-9]+),(-?[0-9]+),(-?[0-9]+)\\)$" ,str)
+      (make-v3d :x (parse-integer ,xs)
+		:y (parse-integer ,ys)
+		:z (parse-integer ,zs)))))
+
+(defmacro hash-table-to-v3d (ht)
+  (alexandria:once-only
+   (ht)
+   `(make-v3d :x (gethash "x" ,ht)
+	      :y (gethash "y" ,ht)
+	      :z (gethash "z" ,ht))))

interlocking.lisp

@@ -0,0 +1,46 @@
+(defpackage :advtrains-interlocking
+  (:use :cl)
+  (:nicknames :atil)
+  (:export :import-data))
+(in-package :atil)
+
+(defstruct tcbdata
+  (ts nil :type (or string null))
+  (signal-pos nil :type (or aux:v3d null)))
+
+(defstruct tcb
+  (pos (error "no position specified") :type aux:v3d)
+  (side-a (error "TCB has no side A") :type tcbdata)
+  (side-b (error "TCB has no side B") :type tcbdata))
+
+(defmethod print-object ((obj tcb) stream)
+  (let ((*standard-output* stream))
+    (with-accessors ((pos tcb-pos) (a tcb-side-a) (b tcb-side-b)) obj
+      (print-unreadable-object (obj stream)
+	(format stream "TCB AT ~a " pos)
+	(pprint-newline :mandatory)
+	(pprint-indent :current 0)
+	(format stream "SIDE A ~a " a)
+	(pprint-newline :mandatory)
+	(format stream "SIDE B ~a" b)))))
+
+(defmacro read-tcb-side (side)
+  (alexandria:with-gensyms (ts)
+    (alexandria:once-only
+     (side)
+     `(let ((,ts (gethash "ts_id" ,side nil)))
+	(make-tcbdata :ts ,ts
+		      :signal-pos (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side))))))))
+
+(defun import-data (fn)
+  (let ((ht (atsl:from-file fn :hash-table)))
+    (let ((tcbs (aux:adj-vector-of 'tcb)))
+      (loop
+	 for poss being each hash-key of (gethash "tcbs" ht)
+	 using (hash-value tcb)
+	 for pos = (aux:string-to-v3d poss)
+	 and side-a = (read-tcb-side (gethash 1 tcb))
+	 and side-b = (read-tcb-side (gethash 2 tcb))
+	 for tcbobj = (make-tcb :pos pos :side-a side-a :side-b side-b)
+	 do (vector-push-extend tcbobj tcbs))
+      tcbs)))

serialize-lib.lisp

@@ -15,14 +15,13 @@
        (cl-ppcre:regex-replace-all "&[:nr&]" ,seq #',replacef :simple-calls t))))
 
 (defmacro string-to-value (seq table-allow)
-  (alexandria:with-gensyms (str datatype restdata n)
+  (alexandria:with-gensyms (str datatype restdata)
     `(let* ((,str ,seq)
 	    (,datatype (char ,str 0))
 	    (,restdata (subseq ,str 1)))
        (ecase ,datatype
 	 (#\T ,(if table-allow `'table `(error "table not allowed")))
-	 (#\N (let ((,n (parse-float ,restdata :type 'real)))
-		(if (typep ,n 'ratio) (coerce ,n 'float) ,n)))
+	 (#\N (aux:parse-lua-number ,restdata))
 	 (#\B (ecase (parse-integer ,restdata)
 		(0 t)
 		(1 nil)))
@@ -66,7 +65,7 @@
 
 (declaim (ftype (function (stream) hash-table) read-table-as-hash-table))
 (defun read-table-as-hash-table (stream)
-  (let ((ht (make-hash-table)))
+  (let ((ht (make-hash-table :test #'equal)))
     (iterate-table-entries
      (stream kv vv #'read-table-as-hash-table)
      (setf (gethash kv ht) vv))
@@ -87,7 +86,5 @@
 (defmacro from-file (filename restype)
   (let ((stream (gensym)) (fn (gensym)))
     `(let ((,fn ,filename))
-       (handler-case
-	   (with-open-file (,stream ,fn)
-	     (from-stream ,stream ,restype))
-	 (t () (error (make-condition 'file-error :pathname ,fn)))))))
+       (with-open-file (,stream ,fn)
+	 (from-stream ,stream ,restype)))))

server-wrapper.lisp

@@ -27,7 +27,10 @@
 (defmacro safe-route (&body body)
   (let ((c (gensym)))
     `(handler-case (progn ,@body)
-       (file-error () (setf (hunchentoot:return-code*) 404) nil)
+       (file-error (,c)
+	 (setf (hunchentoot:return-code*) 404)
+	 (hunchentoot:log-message* :error (format nil "~a" ,c))
+	 nil)
        (t (,c)
 	 (setf (hunchentoot:return-code*) 403)
 	 (hunchentoot:log-message* :error (format nil "~a" ,c))

ywatds.asd

@@ -5,10 +5,12 @@
     :author "Y.W."
     :license "GNU AGPL 3 or later"
     :depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float" "alexandria")
-    :components ((:file "serialize-lib")
+    :serial t
+    :components ((:file "helpers")
+		 (:file "serialize-lib")
+		 (:file "interlocking")
 		 (:file "server-wrapper")
-		 (:file "dataserver" :depends-on ("serialize-lib"
-						  "server-wrapper")))
+		 (:file "dataserver"))
     ;; https://lispcookbook.github.io/cl-cookbook/scripting.html
     :build-operation "program-op"
     :build-pathname "ywatds"