refactored for speed, did away with array searching approach

1 files changed, 125 insertions, 58 deletions

diff --git a/imbricate.ros b/imbricate.ros
index bb9d97e..7d4e2d9 100755
--- a/imbricate.ros
+++ b/imbricate.ros
@@ -16,6 +16,10 @@ exec ros -Q -- $0 "$@"
   `(let ((,var ,test))
      (when ,var ,@body)))
 
+(defmacro let-if ((var test) then else)
+  `(let ((,var ,test))
+     (if ,var ,then ,else)))
+
 (defun images-under-dir (dir &key (type "png"))
   (let ((images '()))
     (cl-fad:walk-directory
@@ -28,7 +32,6 @@ exec ros -Q -- $0 "$@"
 
 (defvar *bad-images* '())
 
-
 (defun safe-open-image (path)
   (handler-case (imago:read-image (format nil "~a" path))
     (error (c)
@@ -37,7 +40,8 @@ exec ros -Q -- $0 "$@"
 
 (defun image-stats (img)
     (list :width (imago:image-width img)
-          :height (imago:image-height img)))
+          :height (imago:image-height img)
+          :img img))
 
 (defun image-area (stat)
   (* (getf stat :width)
@@ -54,30 +58,31 @@ exec ros -Q -- $0 "$@"
       (setf h (max h (+ (getf img :height) (getf img :y)))))
     (list w h)))
 
-(defun fill-grid (grid x y w h)
-  "fills grid with T for rectangle x y w h"
-  (do-over-rect x y w h #'(lambda (xi yi) (setf (aref grid xi yi) t))))
-
 (defun rgb-imagep (img)
   (eq (find-class 'imago:rgb-image)
       (class-of img)))
 
+(defun to-rgb (img)
+  (if (not (rgb-imagep img))
+      (imago:convert-to-rgb img)
+      img))
+
 (defun pack-images (packlist)
   "Creates an image and copies the contents of the packlist to that image"
   (destructuring-bind (cw ch) (packlist-dimensions packlist)
     (let ((tilesheet (make-instance 'imago:rgb-image :width cw :height ch)))
       (dolist (spec packlist)
-        (let-when (img (safe-open-image (getf spec :path)))
-                  (let ((img (if (not (rgb-imagep img)) (imago:convert-to-rgb img) img)))
-                    (imago:copy tilesheet img
-                              :dest-x (getf spec :x)
-                              :dest-y (getf spec :y)))))
+        (let* ((img (to-rgb (getf spec :img))))
+          (imago:copy tilesheet img
+                      :dest-x (getf spec :x)
+                      :dest-y (getf spec :y))))
       tilesheet)))
 
 (defun packlist->tile-index (packlist)
   "renames the path1 in the packlist to a nicer name for referring toa tile location"
   (mapcar #'(lambda (pl)
               (let ((name (pathname-name (getf pl :path))))
+                (remf pl :img)
                 (setf (getf pl :name) name)
                 pl))
           packlist))
@@ -89,53 +94,115 @@ exec ros -Q -- $0 "$@"
     (print tile-index out)))
 
 
-(defun build-packlist (image-list)
-  (let* ((image-list (sort image-list #'> :key #'image-area))
-         (side-dim (ceiling (sqrt (minimum-required-area image-list))))
-         (pack-mask (make-array (list side-dim side-dim) :initial-element nil :adjustable t))
-         (pack-list '()))
-    (dolist (image image-list)
-      (let ((width (getf image :width))
-            (height (getf image :height)))
-        (destructuring-bind (x y) (find-place-for pack-mask width height)
-          (fill-grid pack-mask x y width height)
-          (push (nconc (list :x x :y y) image) pack-list))))
-    (reverse pack-list))) ;; biggest image first
-
-
-(defun do-over-rect (x y w h fn)
-  (loop for xi from x to (+ x w -1) do
-    (loop for yi from y to (+ y h -1) do
-      (funcall fn xi yi))))
-
-
-(defun filled-at (grid x y)
-  "returns two values. The the second is nil if x y is out of range"
-  (destructuring-bind (gw gh) (array-dimensions grid)
-    (if (and (< x gw) (< y gh))
-        (values (aref grid x y) t)
-        (values nil nil))))
-
-(defun unfilled-over-rect (grid x y w h)
-  (do-over-rect x y w h
-    #'(lambda (xi yi)
-        (multiple-value-bind (filled in-bounds) (filled-at grid xi yi)
-          (when (or filled (not in-bounds))
-            (return-from unfilled-over-rect nil)))))
-  t)
-
-(defun find-place-for (grid width height)
-  "returns (x y) where a (width X height) sized rectangle will fit into grid"
-  (labels ((search-loop ()
-             (destructuring-bind (gw gh) (array-dimensions grid)
-               (do-over-rect 0 0 gw gh
-                 #'(lambda (x y)
-                     (when (unfilled-over-rect grid x y width height)
-                       (return-from search-loop (list x y)))))
-               (progn
-                 (adjust-array grid (list (+ width gw) (+ height gh)) :initial-element nil)
-                 (search-loop)))))
-    (search-loop)))
+(defun rect (x y w h) (list x y w h))
+(defun rx (r) (first r))
+(defun ry (r) (second r))
+(defun rw (r) (third r))
+(defun rh (r) (fourth r))
+(defun tl (r) (list (rx r) (ry r)))
+(defun tr (r) (list (+ (rx r) (rw r)) (ry r)))
+(defun br (r) (list (+ (rx r) (rw r)) (+ (ry r) (rh r))))
+(defun bl (r) (list (rx r) (+ (ry r) (rh r))))
+(defun xy-bounds (r)
+  "returns (left right top bottom)"
+  (list (rx r) (+ (rx r) (rw r))
+        (ry r) (+ (ry r) (rh r))))
+
+
+(defun inside-rect (r x y)
+  (destructuring-bind (l r tp b) (xy-bounds r)
+    (and (<= l x) (< x r)
+         (<= tp y) (< y b))))
+
+
+(defun make-corner-keeper () (list 0 0 '() (make-hash-table :test 'equal)))
+(defun keeper-w (k) (first k))
+(defun keeper-h (k) (second k))
+(defun (setf keeper-w) (v k)
+  (setf (first k) v))
+(defun (setf keeper-h) (v k)
+  (setf (second k) v))
+
+(defun keeper-corners (k) (third k))
+(defun (setf keeper-corners) (val k)
+  (setf (third k) val))
+
+(defun visited-corners (k) (fourth k))
+
+(defun was-visited (k p)
+  (gethash p (visited-corners k)))
+
+(defun visit (k p)
+  (setf (gethash p (visited-corners k)) t))
+
+(defun remove-corner (k c)
+  (setf (keeper-corners k)
+        (remove c (keeper-corners k) :test #'equal)))
+
+(defun prune-corners-behind (k r)
+  (setf (keeper-corners k)
+        (remove-if
+         #'(lambda (xy)
+             (destructuring-bind (x y) xy
+               (or
+                (inside-rect r x y)
+                (inside-rect r (+ x (rw r) -1) (+ y (rh r) -1))
+                (inside-rect r (+ x (rw r) -1) y)
+                (inside-rect r x (+ y (rh r) -1)))))
+
+         (keeper-corners k))))
+
+(defun add-corner (k c)
+  (unless (was-visited k c)
+    (visit k c)
+    (push c (keeper-corners k))))
+
+(defun adjust-width (k)
+  (let ((mx 0)
+        (my 0))
+    (dolist (xy (keeper-corners k))
+      (setf mx (max mx (first xy)))
+      (setf my (max my (second xy))))
+    (setf (keeper-w k) mx)
+    (setf (keeper-h k) my)))
+
+(defun add-rect (k r)
+  (remove-corner k (tl r))
+  (prune-corners-behind k r)
+  (add-corner k (tr r))
+  (add-corner k (bl r))
+  (add-corner k (br r))
+  (adjust-width k))
+
+
+(defun bounds-preserving-corners (k w h)
+  (let ((kw (keeper-w k))
+        (kh (keeper-h k)))
+    (remove-if
+     #'(lambda (xy)
+         (destructuring-bind (x y) xy
+           (or (< kw (+ x w))
+               (< kh (+ y h)))))
+     (keeper-corners k))))
+
+(defun find-space-for (k w h)
+  (let-if (candidates (bounds-preserving-corners k w h))
+          (first candidates)
+          (if (< (keeper-w k) (keeper-h k))
+              (list (keeper-w k) 0)
+              (list 0 (keeper-h k)))))
+
+(defun build-packlist (tile-stats)
+  (let ((tile-stats (sort tile-stats #'> :key #'image-area))
+        (ck (make-corner-keeper))
+        (packlist '()))
+    (dolist (stats tile-stats)
+      (let ((tw (getf stats :width))
+            (th (getf stats :height)))
+        (destructuring-bind (x y) (find-space-for ck tw th)
+          (add-rect ck (rect x y tw th))
+          (push (nconc (list :x x :y y) stats) packlist))))
+    packlist))
 
 
 (defun main (&rest argv)