minor optimizations; rename certain functions for profiling
parent
854580be14
commit
0bdfb513b2
|
@ -24,8 +24,8 @@
|
||||||
`(uiop:subpathname *world-path* (concatenate 'string "advtrains_" ,name)))
|
`(uiop:subpathname *world-path* (concatenate 'string "advtrains_" ,name)))
|
||||||
|
|
||||||
(defun load-data ()
|
(defun load-data ()
|
||||||
(let* ((ildb (atil:import-data (savefilepath "interlocking.ls"))))
|
(let* ((ildb (atil:load-ildb (savefilepath "interlocking.ls"))))
|
||||||
(multiple-value-bind (tdb tdbtemp) (tracks:import-data (savefilepath "ndb4.ls"))
|
(multiple-value-bind (tdb tdbtemp) (tracks:load-trackdb (savefilepath "ndb4.ls"))
|
||||||
(if *debugp* (setf *trackdb-temp* tdbtemp))
|
(if *debugp* (setf *trackdb-temp* tdbtemp))
|
||||||
(psetf *ildb* ildb *trackdb* tdb)))
|
(psetf *ildb* ildb *trackdb* tdb)))
|
||||||
(when *gcp*
|
(when *gcp*
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
(defpackage :advtrains-interlocking
|
(defpackage :advtrains-interlocking
|
||||||
(:use :cl)
|
(:use :cl)
|
||||||
(:nicknames :atil)
|
(:nicknames :atil)
|
||||||
(:export :import-data
|
(:export :load-ildb
|
||||||
:ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
|
:ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
|
||||||
:tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
|
:tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
|
||||||
:path-entry :path-entry-p :path-entry-next :path-entry-locks
|
:path-entry :path-entry-p :path-entry-next :path-entry-locks
|
||||||
|
@ -245,8 +245,8 @@
|
||||||
:signal-name ,sname
|
:signal-name ,sname
|
||||||
:routes ,routes)))))
|
:routes ,routes)))))
|
||||||
|
|
||||||
(defun import-data (fn)
|
(defun load-ildb (fn)
|
||||||
(atsl:with-data-from-file (ht fn :hash-table)
|
(atsl:with-data-from-file (ht fn :hash-table :only "tcbs")
|
||||||
(let ((tcbs (make-hash-table :test #'equalp)))
|
(let ((tcbs (make-hash-table :test #'equalp)))
|
||||||
(loop
|
(loop
|
||||||
for poss being each hash-key of (gethash "tcbs" ht)
|
for poss being each hash-key of (gethash "tcbs" ht)
|
||||||
|
|
|
@ -30,48 +30,57 @@
|
||||||
(defmacro adjust-line (line)
|
(defmacro adjust-line (line)
|
||||||
`(string-right-trim '(#\Return) ,line))
|
`(string-right-trim '(#\Return) ,line))
|
||||||
|
|
||||||
(defmacro read-table-entry (line stream gett-f)
|
(defmacro read-table-entry (line stream gett-f &key only)
|
||||||
(alexandria:with-gensyms (key value kv vt)
|
(alexandria:with-gensyms (key value kv vt)
|
||||||
`(cl-ppcre:register-groups-bind
|
`(cl-ppcre:register-groups-bind
|
||||||
(,key ,value)
|
(,key ,value)
|
||||||
("^(.*[^&]):(.+)$" ,line)
|
("^(.*[^&]):(.+)$" ,line)
|
||||||
(let ((,kv (string-to-value ,key nil))
|
(let ((,kv (string-to-value ,key nil))
|
||||||
(,vt (string-to-value ,value t)))
|
(,vt (string-to-value ,value t)))
|
||||||
(values ,kv (if (equal ,vt 'table)
|
(if (and ,only (not (equal ,only ,kv)))
|
||||||
(funcall ,gett-f ,stream)
|
(values nil nil (if (equal ,vt 'table) (skip-table ,stream)))
|
||||||
,vt))))))
|
(values t ,kv (if (equal ,vt 'table) (funcall ,gett-f ,stream) ,vt)))))))
|
||||||
|
|
||||||
(defmacro iterate-table-entries ((stream key val gett-f) &body body)
|
(defmacro iterate-table-entries ((stream key val gett-f &key only) &body body)
|
||||||
(alexandria:with-gensyms (line)
|
(alexandria:with-gensyms (line use-entry-p)
|
||||||
(alexandria:once-only
|
(alexandria:once-only
|
||||||
(stream)
|
(stream)
|
||||||
`(do ((,line (adjust-line (read-line ,stream nil))
|
`(do ((,line (adjust-line (read-line ,stream nil))
|
||||||
(adjust-line (read-line ,stream nil))))
|
(adjust-line (read-line ,stream nil))))
|
||||||
((or (null ,line) (equal ,line "E")))
|
((or (null ,line) (string= ,line "E")))
|
||||||
(multiple-value-bind (,key ,val)
|
(multiple-value-bind (,use-entry-p ,key ,val)
|
||||||
(read-table-entry ,line ,stream ,gett-f)
|
(read-table-entry ,line ,stream ,gett-f :only ,only)
|
||||||
,@body)))))
|
(when ,use-entry-p ,@body))))))
|
||||||
|
|
||||||
(declaim (ftype (function (stream) list) read-table-as-alist))
|
(declaim (ftype (function (stream) null) skip-table))
|
||||||
(defun read-table-as-alist (stream)
|
(defun skip-table (stream)
|
||||||
|
;; note that this function partly duplicates parts of other functions/macros
|
||||||
|
(do ((line (adjust-line (read-line stream nil)) (adjust-line (read-line stream nil))))
|
||||||
|
((or (null line) (string= line "E")) nil)
|
||||||
|
(cl-ppcre:register-groups-bind
|
||||||
|
(v) ("^.*[^&]:(.).+$" line)
|
||||||
|
(if (string= v "T") (skip-table stream)))))
|
||||||
|
|
||||||
|
(declaim (ftype (function (stream &key (:only t)) list) read-table-as-alist))
|
||||||
|
(defun read-table-as-alist (stream &key only)
|
||||||
(let ((ht ()))
|
(let ((ht ()))
|
||||||
(iterate-table-entries
|
(iterate-table-entries
|
||||||
(stream kv vv #'read-table-as-alist)
|
(stream kv vv #'read-table-as-alist :only only)
|
||||||
(let ((c (assoc kv ht :test #'equal)))
|
(let ((c (assoc kv ht :test #'equal)))
|
||||||
(if c
|
(if c
|
||||||
(setf (cdr c) vv)
|
(setf (cdr c) vv)
|
||||||
(push (cons kv vv) ht))))
|
(push (cons kv vv) ht))))
|
||||||
ht))
|
ht))
|
||||||
|
|
||||||
(declaim (ftype (function (stream) hash-table) read-table-as-hash-table))
|
(declaim (ftype (function (stream &key (:only t)) hash-table) read-table-as-hash-table))
|
||||||
(defun read-table-as-hash-table (stream)
|
(defun read-table-as-hash-table (stream &key only)
|
||||||
(let ((ht (make-hash-table :test #'equal)))
|
(let ((ht (make-hash-table :test #'equal)))
|
||||||
(iterate-table-entries
|
(iterate-table-entries
|
||||||
(stream kv vv #'read-table-as-hash-table)
|
(stream kv vv #'read-table-as-hash-table :only only)
|
||||||
(setf (gethash kv ht) vv))
|
(setf (gethash kv ht) vv))
|
||||||
ht))
|
ht))
|
||||||
|
|
||||||
(defmacro from-stream (stream restype)
|
(defmacro from-stream (stream restype &rest options)
|
||||||
(alexandria:with-gensyms (header sver)
|
(alexandria:with-gensyms (header sver)
|
||||||
(alexandria:once-only
|
(alexandria:once-only
|
||||||
(stream)
|
(stream)
|
||||||
|
@ -81,13 +90,13 @@
|
||||||
(,(ecase restype
|
(,(ecase restype
|
||||||
(:alist 'read-table-as-alist)
|
(:alist 'read-table-as-alist)
|
||||||
(:hash-table 'read-table-as-hash-table))
|
(:hash-table 'read-table-as-hash-table))
|
||||||
,stream)))))
|
,stream ,@options)))))
|
||||||
|
|
||||||
(defmacro from-file (filename restype)
|
(defmacro from-file (filename restype &rest options)
|
||||||
(let ((stream (gensym)) (fn (gensym)))
|
(let ((stream (gensym)) (fn (gensym)))
|
||||||
`(let ((,fn ,filename))
|
`(let ((,fn ,filename))
|
||||||
(with-open-file (,stream ,fn)
|
(with-open-file (,stream ,fn)
|
||||||
(from-stream ,stream ,restype)))))
|
(from-stream ,stream ,restype ,@options)))))
|
||||||
|
|
||||||
(defmacro with-data-from-file ((var &rest options) &body body)
|
(defmacro with-data-from-file ((var &rest options) &body body)
|
||||||
`(let ((,var (from-file ,@options))) ,@body))
|
`(let ((,var (from-file ,@options))) ,@body))
|
||||||
|
|
|
@ -39,35 +39,32 @@
|
||||||
collect (cons ,c ,d))))))
|
collect (cons ,c ,d))))))
|
||||||
|
|
||||||
(defun optimize-track-database (tdb)
|
(defun optimize-track-database (tdb)
|
||||||
(loop for pos in (loop for i being the hash-keys of tdb collect i)
|
(declare (optimize (debug 3)))
|
||||||
|
(labels ((ndirs (c) (loop for i across c when i count i))
|
||||||
|
(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))))
|
||||||
|
(merge-2way (c u)
|
||||||
|
(when (eql (ndirs c) 2)
|
||||||
|
(let ((collapsed (loop for i across c when i collect i)))
|
||||||
|
(connect-dirs (caar collapsed) (caadr collapsed)
|
||||||
|
(+ (cadar collapsed) (cadadr collapsed))))
|
||||||
|
(loop for i from 0 to 15 do (setf (aref u i) t))))
|
||||||
|
(removable-p (u)
|
||||||
|
(loop for i across (the (vector t 16) u) always i)))
|
||||||
|
(loop for pos of-type aux:v3d in (loop for i being the hash-keys of tdb collect i)
|
||||||
for track = (gethash pos tdb)
|
for track = (gethash pos tdb)
|
||||||
when (and track (not (track-special track))) do
|
when (and track (not (track-special track))) do
|
||||||
(let ((connections (track-connects track))
|
(let ((connections (track-connects track))
|
||||||
(unused (make-array 16 :initial-element nil)))
|
(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
|
(loop for dir from 0 to 15 for i across connections
|
||||||
when (null i) do (setf (aref unused dir) t))
|
when (null i) do (setf (aref unused dir) t))
|
||||||
(merge-2way connections)
|
(merge-2way connections unused)
|
||||||
(when (removable-p)
|
(when (removable-p unused)
|
||||||
(remhash pos tdb))))))
|
(remhash pos tdb))))))
|
||||||
|
|
||||||
;;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html
|
;;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html
|
||||||
|
@ -100,7 +97,7 @@
|
||||||
(adjust-conns-list-with-param2 clist param2 t))))
|
(adjust-conns-list-with-param2 clist param2 t))))
|
||||||
tmpdb))))
|
tmpdb))))
|
||||||
|
|
||||||
(defun import-data (fn)
|
(defun load-trackdb (fn)
|
||||||
(let ((tdb (make-track-database))
|
(let ((tdb (make-track-database))
|
||||||
(tmpdb (read-tracks-from-nodedb fn)))
|
(tmpdb (read-tracks-from-nodedb fn)))
|
||||||
(loop for pos being the hash-keys of tmpdb using (hash-value clist)
|
(loop for pos being the hash-keys of tmpdb using (hash-value clist)
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
(defpackage :tracks
|
(defpackage :tracks
|
||||||
(:use :cl)
|
(:use :cl)
|
||||||
(:export :init-tracks :import-data
|
(:export :init-tracks :load-trackdb
|
||||||
:dump-track-definitions :gvdump
|
:dump-track-definitions :gvdump
|
||||||
:trackside
|
:trackside
|
||||||
:dijkstra))
|
:dijkstra))
|
||||||
|
|
|
@ -27,4 +27,4 @@
|
||||||
|
|
||||||
#+sb-core-compression
|
#+sb-core-compression
|
||||||
(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
|
(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
|
||||||
(uiop:dump-image (asdf:output-file o c) :executable t :compression t))
|
(uiop:dump-image (asdf:output-file o c) :executable t :compression 9))
|
||||||
|
|
Loading…
Reference in New Issue