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)))

(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
     dir
     (lambda (path)
       (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-image (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"
  (destructuring-bind (cw ch) (packlist-dimensions packlist)
    (let ((tilesheet (make-instance 'imago:rgb-image :width cw :height ch)))
      (dolist (spec packlist)
        (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 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)
  (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)))
        (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: