path: root/imbricate.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp(ql:quickload '(imago cl-fad) :silent t)
  )

(defpackage :ros.script.imbricate.3764151058
  (:use :cl))
(in-package :ros.script.imbricate.3764151058)

(defmacro let-when ((var test) &rest body)
  `(let ((,var ,test))
     (when ,var ,@body)))

(defun images-under-dir (dir &key (type "png"))
  (format t "~%Reading images from disk")
  (let ((images '()))
    (cl-fad:walk-directory
     dir
     (lambda (path)
       (format t ".")
       (force-output)
       (let-when (img (and (string= type (pathname-type path))
                           (safe-open-image path)))
                 (push (nconc (list :path path) (image-stats img)) images))))
    images))

(defvar *bad-images* '())

(defun safe-open-image (path)
  (handler-case (imago:read-png (format nil "~a" path))
    (error (c)
      (push path *bad-images*)
      nil)))

(defun image-stats (img)
    (list :width (imago:image-width img)
          :height (imago:image-height img)
          :img img))

(defun image-area (stat)
  (* (getf stat :width)
     (getf stat :height)))

(defun minimum-required-area (image-list)
  (loop for stats in image-list
        summing (image-area stats)))

(defun packlist-dimensions (packlist)
  (let ((w 0) (h 0))
    (dolist (img packlist)
      (setf w (max w (+ (getf img :width) (getf img :x))))
      (setf h (max h (+ (getf img :height) (getf img :y)))))
    (list w h)))

(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"
  (format t "~%Constructing tilesheet")
  (destructuring-bind (cw ch) (packlist-dimensions packlist)
    (let ((tilesheet (make-instance 'imago:rgb-image :width cw :height ch)))
      (dolist (spec packlist)
        (format t ".")
        (force-output)
        (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))

(defun write-tile-index (tile-index file-path)
  "saves tile-index to file-path as a standard lisp object"
  (with-open-file (out file-path :direction :output)
    (print tile-index out)))

(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 xy)
  (destructuring-bind (l r tp b) (xy-bounds r)
    (destructuring-bind (x y) xy
      (and (< l x) (< x r)
           (< tp y) (< y b)))))

(defun intersect-p (r1 r2)
  (or
   (equalp r1 r2)
   (inside-rect r1 (tl r2))
   (inside-rect r1 (tr r2))
   (inside-rect r1 (br r2))
   (inside-rect r1 (bl r2))
   (inside-rect r2 (tl r1))
   (inside-rect r2 (tr r1))
   (inside-rect r2 (br r1))
   (inside-rect r2 (bl r1))
   ;; if no corner of one is inside the other, then
   ;; any edge of one intersects at least one edge of the other
   ;; so we check one arbitrarily
   (destructuring-bind (left1 right1 top1 bottom1) (xy-bounds r1)
     (destructuring-bind (left2 right2 top2 bottom2) (xy-bounds r2)
       (and (<= left1 left2)
            (< left2 right1)
            (<= top2 top1)
            (< top1 bottom2))))))

(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 keeper-rects (k) (fifth k))
(defun (setf keeper-rects) (val k)
  (setf (fifth k) val))

(defun remove-corner (k c)
  (setf (keeper-corners k)
        (remove c (keeper-corners k) :test #'equal)))

(defun add-corner (k c)
  (unless (was-visited k c)
    (visit k c)
    (push c (keeper-corners k))))

(defun add-rect (k r)
  (remove-corner k (tl r))
  (push r (keeper-rects k))
  (add-corner k (tr r))
  (add-corner k (bl r))
  (setf (keeper-w k) (max (first (br r))
                          (keeper-w k)))
  (setf (keeper-h k) (max (second (br r))
                          (keeper-h k))))

(defun intersects-any-tile-p (k r)
  (dolist (r2 (keeper-rects k))
    (when (intersect-p r r2)
      (return-from intersects-any-tile-p t))))

(defun valid-rect (k r)
  (and (inside-rect (rect 0 0 (keeper-w k) (keeper-h k)) (br r))
       (not (intersects-any-tile-p k r))))

(defun find-space-for (k w h)
  (dolist (xy (keeper-corners k))
    (when (valid-rect k (rect (first xy) (second xy) w h))
      (return-from find-space-for xy)))
  ;; if not already-returned, then do:
  (if (< (keeper-w k) (keeper-h k))
      (list (keeper-w k) 0)
      (list 0 (keeper-h k))))

(defun build-packlist (tile-stats)
  (format t "~%Creating Layout")
  (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)
          (format t ".")
          (force-output)
          (add-rect ck (rect x y tw th))
          (push (nconc (list :x x :y y) stats) packlist))))
    packlist))

(defun main (&rest argv)
  (declare (ignorable argv))
  (destructuring-bind (path target) argv
      (let* ((tile-stats (images-under-dir path))
             (packlist (build-packlist tile-stats))
             (tilesheet (pack-images packlist))
             (tile-index (packlist->tile-index packlist)))
        (format t "~%Writing to disk...")
        (force-output)
        (imago:write-png tilesheet (format nil "~a.png" target))
        (write-tile-index tile-index (format nil "~a-index.lisp" target))
        (write-tile-index *bad-images* (format nil "~a.bad.txt" target))))
  (format t "~%ALL DONE~%"))
;;; vim: set ft=lisp lisp: