path: root/imbricate.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp(ql:quickload '(cl-fad opticl jonathan) :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 (opticl:read-png-file (format nil "~a" path))
    (error (c)
      (push path *bad-images*)
      nil)))

(defun image-stats (img)
    (list :|width| (array-dimension img 0)
          :|height| (array-dimension img 1)
          :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 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-array (list cw ch 4) :element-type '(unsigned-byte 8))))
      (dolist (spec packlist)
        (format t ".")
        (force-output)
        (let* ((img (getf spec :img)))
	  (handler-case 
	      (copy-into-img tilesheet img
			     (getf spec :|y|)
			     (getf spec :|x|))
	    (error (e) (push (list :bad-image-format
				   (array-dimensions img)
				   (getf spec :path))
			     *bad-images*)))))
      tilesheet)))

(defun img-width (img) (array-dimension img 0))
(defun img-height (img) (array-dimension img 1))

(defun copy-into-img (target source dest-x dest-y)
  (dotimes (x (img-width source))
    (dotimes (y (img-height source))
      (dotimes (v 4)
	(setf (aref target (+ x dest-x) (+ y dest-y) v)
	      (aref source x y v))))))



(defun packlist->tile-index (packlist)
  "renames the path in the packlist to a nicer name for referring toa tile location"
  (let ((strip-index (1+  (length (sb-posix:getcwd)))))
    (mapcar #'(lambda (pl)
		(remf pl :img)
		(let ((name (substitute #\. #\/ (subseq (namestring  (getf pl :path))
							strip-index))))
		  (setf name (subseq name 0 (search "." name :from-end t)))
		  (setf (getf pl :|name|) name))
		(remf pl :path)
		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 :if-exists :supersede)
    (print tile-index out)))

(defun write-json-index (tile-index file-path)
  (with-open-file (out file-path :direction :output :if-exists :supersede)
    (format out "~a"
	    (jonathan:to-json tile-index))))

(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 . options) 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)
        (opticl:write-png-file (format nil "~a.png" target) tilesheet)
	(if (member "-json" options :test #'equal)
	    (write-json-index tile-index (format nil "~a-index.json" 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: