165 lines
7.2 KiB
Common Lisp
165 lines
7.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 boolean))
|
|
|
|
(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 mark-interlocking-tracks (tdb ildb)
|
|
;; TODO: actually check whether the TCBs are useful
|
|
(loop for pos being the hash-keys of (atil:ildb-tcbs ildb) do
|
|
(alexandria:when-let ((track (gethash pos tdb)))
|
|
(setf (track-special track) t))))
|
|
|
|
(defun optimize-track-database (tdb)
|
|
(labels ((connect-dirs (from to dist)
|
|
(with-track-at-ts (tdb from nil dir track)
|
|
(let ((c (aref (track-connects track) dir)))
|
|
(psetf (car c) to (cadr c) dist)))
|
|
(with-track-at-ts (tdb to nil dir track)
|
|
(let ((c (aref (track-connects track) dir)))
|
|
(psetf (car c) from (cadr c) dist))))
|
|
(check-2way-merge (connections this-dir)
|
|
(let* ((this (aref connections this-dir)) (that-dir (caddr this)))
|
|
(when (and that-dir (not (cdddr this)))
|
|
(let* ((that (aref connections that-dir))
|
|
(that-cons (cddr that)))
|
|
(and (eql (car that-cons) this-dir) (not (cdr that-cons)) that-dir)))))
|
|
(merge-2way (connections)
|
|
(loop for dir from 0 to 15 for cons across connections
|
|
for other = (check-2way-merge connections dir) when other do
|
|
(let ((other-cons (aref connections other)))
|
|
(connect-dirs (car cons) (car other-cons)
|
|
(+ (cadr cons) (cadr other-cons)))
|
|
(psetf (aref connections dir) nil (aref connections other) nil))))
|
|
(merge-simple-eol (pos connections)
|
|
(loop for dir from 0 to 15 for cons across connections
|
|
when (and cons (not (car cons))) do
|
|
(psetf (car cons) (make-trackside :pos pos :side dir)
|
|
(cadr cons) (* 2 (cadr cons)))))
|
|
(removable-p (connections) (every #'null connections)))
|
|
(loop for pos of-type aux:v3d being the hash-keys of tdb using (hash-value track)
|
|
when (and track (not (track-special track))) do
|
|
(let ((connections (track-connects track)))
|
|
(merge-2way connections)
|
|
(when (removable-p connections)
|
|
(remhash pos tdb))))
|
|
(loop for pos of-type aux:v3d being the hash-keys of tdb using (hash-value track)
|
|
when track do (merge-simple-eol pos (track-connects track)))))
|
|
|
|
;;; 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)
|
|
;; The 1000000 is chosen from a large dataset with ~800k tracks. The idea is to avoid
|
|
;; excessive rehashing for large databases.
|
|
(let ((tmpdb (make-hash-table :test #'equalp :size 1000000))
|
|
(nodes (make-hash-table :test #'eql :size (hash-table-count *track->conns*))))
|
|
(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 load-trackdb (fn ildb)
|
|
(let* ((tmpdb (read-tracks-from-nodedb fn))
|
|
(tdb (make-hash-table :test #'equalp :size (hash-table-count tmpdb))))
|
|
(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))))
|
|
(mark-interlocking-tracks tdb ildb)
|
|
(optimize-track-database tdb)
|
|
tdb))
|
|
|
|
(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)))
|