155 lines
6.2 KiB
Common Lisp
155 lines
6.2 KiB
Common Lisp
(in-package :tracks)
|
|
|
|
(defmacro make-empty-connects () `(make-array 16 :element-type 'list :initial-element nil))
|
|
|
|
;; The each list in the connects array is:
|
|
;; nil - the direction does not exist in the conns table of the track, or
|
|
;; a list with the CAR representing the position of the connecting track
|
|
;; CADR representing the distance to the connecting track (or 0)
|
|
;; CDDR representing the list of directions the train can move in
|
|
(defstruct track
|
|
(connects (make-empty-connects) :type (vector list 16))
|
|
(special nil :type list))
|
|
|
|
(defmacro make-track-database ()
|
|
`(make-hash-table :test #'equalp))
|
|
|
|
(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)))))))
|
|
|
|
(defmacro direct-next (trackdb trackside &optional no-eol-p)
|
|
(alexandria:with-gensyms (dir track i c d connects)
|
|
(alexandria:once-only
|
|
(trackdb trackside no-eol-p)
|
|
`(with-track-at-ts (,trackdb ,trackside nil ,dir ,track)
|
|
(loop with ,connects = (track-connects ,track)
|
|
for ,i in (cddr (aref ,connects ,dir))
|
|
for ,c = (car (aref ,connects ,i))
|
|
and ,d = (cadr (aref ,connects ,i))
|
|
when (or (not ,no-eol-p) ,c)
|
|
collect (cons ,c ,d))))))
|
|
|
|
(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))))))
|
|
|
|
;;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html
|
|
;;; note that this implementation only reads nodes that are known to be tracks
|
|
(defun read-tracks-from-nodedb (fn)
|
|
(let ((tmpdb (make-hash-table :test #'equalp))
|
|
(nodes (make-hash-table :test #'eql)))
|
|
(with-open-file (stream fn :element-type '(unsigned-byte 8))
|
|
(labels ((read-u8 () (read-byte stream nil nil))
|
|
(read-u16 () (let ((msb (read-u8)) (lsb (read-u8)))
|
|
(if (and msb lsb) (+ (* 256 msb) lsb))))
|
|
(read-int () (let ((i (read-u16))) (if i (- i 32768))))
|
|
(read-ln ()
|
|
(with-output-to-string (s)
|
|
(loop for c = (read-u8) while c for char = (code-char c)
|
|
until (char= char #\Newline) do (write-char char s))))
|
|
(read-node-entry ()
|
|
(let ((x (read-int)) (y (read-int)) (z (read-int)) (v (read-int)))
|
|
(if (and x y z v) (cons (aux:make-v3d :x x :y y :z z) v))))
|
|
(id->clist (ent)
|
|
(if ent (gethash (ash (cdr ent) -2) nodes))))
|
|
(assert (= (read-u8) 1))
|
|
(loop repeat (read-int)
|
|
for id = (read-int) for name = (read-ln) for clist = (gethash name *track->conns*)
|
|
when clist do (setf (gethash id nodes) clist))
|
|
(loop for ent = (read-node-entry) for clist = (id->clist ent) while ent
|
|
when clist
|
|
do (let ((param2 (ldb (byte 2 0) (cdr ent))))
|
|
(setf (gethash (car ent) tmpdb)
|
|
(adjust-conns-list-with-param2 clist param2 t))))
|
|
tmpdb))))
|
|
|
|
(defun import-data (fn)
|
|
(let ((tdb (make-track-database))
|
|
(tmpdb (read-tracks-from-nodedb fn)))
|
|
(loop for pos being the hash-keys of tmpdb using (hash-value clist)
|
|
for dirs = (conns-list-dirs clist)
|
|
for connects = (make-empty-connects) do
|
|
(labels
|
|
((dir-pos-connection (from-c to-pos)
|
|
(let ((td (conns-list-dirs (gethash to-pos tmpdb)))
|
|
(to-c (mod (+ 8 from-c) 16)))
|
|
(if (member to-c td :test #'equal :key #'dir-c)
|
|
(make-trackside :pos to-pos :side to-c)))))
|
|
;; collect a list of directions a train can move in after reaching the track
|
|
(loop for i in clist do
|
|
(let ((from (dir-c (conns-from i)))
|
|
(to (dir-c (conns-to i))))
|
|
(push from (aref connects to))
|
|
(push to (aref connects from))))
|
|
;; collect coordinates (or nil) of connecting tracks
|
|
(loop for i in dirs for c = (dir-c i)
|
|
for adj = (if (zerop (dir-r i))
|
|
(let* ((dp (apply-dir-to-v3d pos i))
|
|
(sp (aux:make-v3d :x (aux:v3d-x dp)
|
|
:y (1- (aux:v3d-y dp))
|
|
:z (aux:v3d-z dp))))
|
|
(or (dir-pos-connection c dp)
|
|
(dir-pos-connection c sp)))
|
|
(let ((p (apply-dir-to-v3d pos i)))
|
|
(dir-pos-connection c p)))
|
|
for dist = (if adj (aux:v3d-dist pos (trackside-pos adj))
|
|
(/ (dir-length i) 2))
|
|
do
|
|
(push dist (aref connects (dir-c i)))
|
|
(push adj (aref connects (dir-c i))))
|
|
(setf (get-track tdb pos) (make-track :connects connects))))
|
|
(optimize-track-database tdb)
|
|
(values tdb tmpdb)))
|
|
|
|
(defun gvdump (tdb)
|
|
(with-output-to-string (stream)
|
|
(princ "digraph{" stream)
|
|
(write-char #\Newline stream)
|
|
(loop for pos being the hash-keys of tdb using (hash-value track)
|
|
for connections = (track-connects track) do
|
|
(loop for i from 0 to 15 for connects = (aref connections i)
|
|
for trackside = (make-trackside :pos pos :side i) do
|
|
(labels ((draw-connection (from to dist)
|
|
(format stream "\"~a\"->\"~a\"[label=\"~a\"];~%" from to dist)))
|
|
(loop for j in (cddr connects)
|
|
for target = (aref connections j)
|
|
do (draw-connection trackside (car target) (cadr target))))))
|
|
(write-char #\} stream)))
|