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

Optimize crossings

master
y5nw 2021-08-25 15:25:35 +02:00
parent 960bcf7137
commit a54bc69058
1 changed files with 18 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
tracks/database.lisp
View File

@ -42,31 +42,33 @@
(setf (track-special track) t))))
(defun optimize-track-database (tdb)
(labels ((ndirs (c) (loop for i across c when i count i))
(connect-dirs (from to dist)
(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))))
(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)))
(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))))
(removable-p (connections) (every #'null connections)))
(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 unused)
(when (removable-p unused)
(let ((connections (track-connects track)))
(merge-2way connections)
(when (removable-p connections)
(remhash pos tdb))))))
;;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html