yw05
/
ywatds
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

minor optimizations; rename certain functions for profiling

master
y5nw 2021-08-24 15:08:04 +02:00
parent 854580be14
commit 0bdfb513b2
6 changed files with 61 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
dataserver.lisp
View File

@ -24,8 +24,8 @@
`(uiop:subpathname *world-path* (concatenate 'string "advtrains_" ,name)))
(defun load-data ()
(let* ((ildb (atil:import-data (savefilepath "interlocking.ls"))))
(multiple-value-bind (tdb tdbtemp) (tracks:import-data (savefilepath "ndb4.ls"))
(let* ((ildb (atil:load-ildb (savefilepath "interlocking.ls"))))
(multiple-value-bind (tdb tdbtemp) (tracks:load-trackdb (savefilepath "ndb4.ls"))
(if *debugp* (setf *trackdb-temp* tdbtemp))
(psetf *ildb* ildb *trackdb* tdb)))
(when *gcp*

6
interlocking.lisp
View File

@ -1,7 +1,7 @@
(defpackage :advtrains-interlocking
(:use :cl)
(:nicknames :atil)
(:export :import-data
(:export :load-ildb
:ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
:tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
:path-entry :path-entry-p :path-entry-next :path-entry-locks
@ -245,8 +245,8 @@
:signal-name ,sname
:routes ,routes)))))
(defun import-data (fn)
(atsl:with-data-from-file (ht fn :hash-table)
(defun load-ildb (fn)
(atsl:with-data-from-file (ht fn :hash-table :only "tcbs")
(let ((tcbs (make-hash-table :test #'equalp)))
(loop
for poss being each hash-key of (gethash "tcbs" ht)

49
serialize-lib.lisp
View File

@ -30,48 +30,57 @@
(defmacro adjust-line (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)
`(cl-ppcre:register-groups-bind
(,key ,value)
("^(.*[^&]):(.+)$" ,line)
(let ((,kv (string-to-value ,key nil))
(,vt (string-to-value ,value t)))
(values ,kv (if (equal ,vt 'table)
(funcall ,gett-f ,stream)
,vt))))))
(if (and ,only (not (equal ,only ,kv)))
(values nil nil (if (equal ,vt 'table) (skip-table ,stream)))
(values t ,kv (if (equal ,vt 'table) (funcall ,gett-f ,stream) ,vt)))))))
(defmacro iterate-table-entries ((stream key val gett-f) &body body)
(alexandria:with-gensyms (line)
(defmacro iterate-table-entries ((stream key val gett-f &key only) &body body)
(alexandria:with-gensyms (line use-entry-p)
(alexandria:once-only
(stream)
`(do ((,line (adjust-line (read-line ,stream nil))
(adjust-line (read-line ,stream nil))))
((or (null ,line) (equal ,line "E")))
(multiple-value-bind (,key ,val)
(read-table-entry ,line ,stream ,gett-f)
,@body)))))
((or (null ,line) (string= ,line "E")))
(multiple-value-bind (,use-entry-p ,key ,val)
(read-table-entry ,line ,stream ,gett-f :only ,only)
(when ,use-entry-p ,@body))))))
(declaim (ftype (function (stream) list) read-table-as-alist))
(defun read-table-as-alist (stream)
(declaim (ftype (function (stream) null) skip-table))
(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 ()))
(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)))
(if c
(setf (cdr c) vv)
(push (cons kv vv) ht))))
ht))
(declaim (ftype (function (stream) hash-table) read-table-as-hash-table))
(defun read-table-as-hash-table (stream)
(declaim (ftype (function (stream &key (:only t)) hash-table) read-table-as-hash-table))
(defun read-table-as-hash-table (stream &key only)
(let ((ht (make-hash-table :test #'equal)))
(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))
ht))
(defmacro from-stream (stream restype)
(defmacro from-stream (stream restype &rest options)
(alexandria:with-gensyms (header sver)
(alexandria:once-only
(stream)
@ -81,13 +90,13 @@
(,(ecase restype
(:alist 'read-table-as-alist)
(: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 ((,fn ,filename))
(with-open-file (,stream ,fn)
(from-stream ,stream ,restype)))))
(from-stream ,stream ,restype ,@options)))))
(defmacro with-data-from-file ((var &rest options) &body body)
`(let ((,var (from-file ,@options))) ,@body))

53
tracks/database.lisp
View File

@ -39,35 +39,32 @@
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)))
(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)
when (and track (not (track-special track))) do
(let ((connections (track-connects track))
(unused (make-array 16 :initial-element nil)))
(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)
(merge-2way connections unused)
(when (removable-p unused)
(remhash pos tdb))))))
;;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html
@ -100,7 +97,7 @@
(adjust-conns-list-with-param2 clist param2 t))))
tmpdb))))
(defun import-data (fn)
(defun load-trackdb (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)

2
tracks/package.lisp
View File

@ -1,6 +1,6 @@
(defpackage :tracks
(:use :cl)
(:export :init-tracks :import-data
(:export :init-tracks :load-trackdb
:dump-track-definitions :gvdump
:trackside
:dijkstra))

2
ywatds.asd
View File

@ -27,4 +27,4 @@
#+sb-core-compression
(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))