From a54bc690580818c0332193d1f8e7c966713b7a2c Mon Sep 17 00:00:00 2001
From: y5nw <y5nw@localhost>
Date: Wed, 25 Aug 2021 15:25:35 +0200
Subject: [PATCH] Optimize crossings

---
 tracks/database.lisp | 34 ++++++++++++++++++----------------
 1 file changed, 18 insertions(+), 16 deletions(-)

diff --git a/tracks/database.lisp b/tracks/database.lisp
index ffb4ada..7dd0240 100644
--- a/tracks/database.lisp
+++ b/tracks/database.lisp
@@ -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