removed roswell script

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: