summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorColin Okay <cbeok@protonmail.com>2020-09-07 16:39:49 -0500
committerColin Okay <cbeok@protonmail.com>2020-09-07 16:39:49 -0500
commitf09c489f299fefce62d6b46703744a4336b484b2 (patch)
tree04194a58a2830a0d51b0457141ad502ecfa494a8
parente49c96b0c3ad920864b4c2e1ec025affb4c7c25f (diff)
removed roswell script
-rwxr-xr-ximbricate.ros250
1 files changed, 0 insertions, 250 deletions
diff --git a/imbricate.ros b/imbricate.ros
deleted file mode 100755
index 694d2dd..0000000
--- a/imbricate.ros
+++ /dev/null
@@ -1,250 +0,0 @@
-#!/bin/sh
-#|-*- mode:lisp -*-|#
-#|
-exec ros -Q -- $0 "$@"
-|#
-(progn ;;init forms
- (ros:ensure-asdf)
- #+quicklisp(ql:quickload '(cl-fad opticl jonathan uiop) :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 (length (princ-to-string (uiop: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: