diff options
| -rw-r--r-- | imbricate.asd | 10 | ||||
| -rw-r--r-- | imbricate.lisp | 196 |
2 files changed, 206 insertions, 0 deletions
diff --git a/imbricate.asd b/imbricate.asd new file mode 100644 index 0000000..acdd2ec --- /dev/null +++ b/imbricate.asd @@ -0,0 +1,10 @@ +;;;; imbricate.asd + +(asdf:defsystem #:imbricate + :description "Describe imbricate here" + :author "Your Name <your.name@example.com>" + :license "Specify license here" + :version "0.0.1" + :serial t + :depends-on (#:jonathan #:opticl #:uiop #:defclass-std #:lambda-tools) + :components ((:file "imbricate"))) diff --git a/imbricate.lisp b/imbricate.lisp new file mode 100644 index 0000000..5eeae6d --- /dev/null +++ b/imbricate.lisp @@ -0,0 +1,196 @@ +;;;; imbricate.lisp + +(defpackage #:imbricate + (:use #:cl) + (:import-from #:opticl + #:convert-image-to-rgba + #:read-png-file + #:with-image-bounds) + (:import-from #:alexandria #:when-let #:if-let) + (:import-from #:defclass-std #:defclass/std)) + +(in-package #:imbricate) + +(defclass rect () + ((x :accessor rect-x + :initarg :x + :initform 0 + :type fixnum) + (y :accessor rect-y + :initarg :y + :initform 0 + :type fixnum) + (width :accessor rect-width + :initarg :width + :initform 0 + :type fixnum) + (height :accessor rect-height + :initarg :height + :initform 0 + :type fixnum))) + + +(defun rect-area (r) + (* (rect-width r) (rect-height r))) + +(defun contains-point-p (r px py) + (with-slots (x y width height) r + (and (<= x px (1- (+ x width))) + (<= y py (1- (+ y height)))))) + + +(defun top-left (rect) + (with-slots (x y) rect + (cons x y))) + +(defun top-right (rect) + (with-slots (x y width) rect + (cons (1- (+ x width)) + y))) + +(defun bottom-left (rect) + (with-slots (x y width height) rect + (cons (1- (+ x width)) + (1- (+ y height))))) + +(defun bottom-right (rect) + (with-slots (x y height) rect + (cons x + (1- (+ y height))))) + +(defun translate-pt (pt dx dy) + (cons (+ dx (car pt)) + (+ dy (cdr pt)))) + +(defun left-most (rect) (rect-x rect)) +(defun right-most (rect) (1- (+ (rect-x rect) (rect-width rect)))) +(defun bottom-most (rect) (1- (+ (rect-y rect) (rect-height rect)))) +(defun top-most (rect ) (rect-y rect)) + +(defun corners (rect) + (list (top-left rect) + (top-right rect) + (bottom-right rect) + (bottom-left rect))) + +(defun intersects-p (r1 r2) + (loop :for (x . y) :in (corners r2) + :when (contains-point-p r1 x y) + :do (return-from intersects-p t))) + +(defclass tile (rect) + ((path :accessor tile-path + :initarg :path + :initform (error "must supply path")) + (data :accessor tile-data + :initarg :data + :initform (error "Must supply data")))) + +(defmethod print-object ((ob tile) stream) + (with-slots (x y width height path) ob + (format stream "#<tile: ~a~% dimensions: ~ax~a~% at: ~a,~a>" + path width height x y))) + +(defclass sheet-plan (rect) + ((candidates :accessor candidates + :initform nil) + (positioned :accessor positioned + :initform nil))) + + +(defun validly-positioned-p (plan tile) + (and (contains-point-p plan (right-most tile) (bottom-most tile)) + (not (some (lambda (other) (intersects-p tile other)) (positioned plan))))) + +(defun position-tile (plan tile) + "finds a place for the tile in the tilesheet under construction and +places the tile into the 'positioned' list of the corner plan +instance. " + (loop :for (x . y) :in (candidates plan) + :do (setf (rect-x tile) x + (rect-y tile) y) + :until (validly-positioned-p plan tile)) + ;; if no position was found, set a position based + ;; on the current size of the tilesheet + (unless (validly-positioned-p plan tile) + (with-slots (width height) plan + (if (< width height) + (setf (rect-x tile) width + (rect-y tile) 0) + (setf (rect-x tile) 0 + (rect-y tile) height)))) + + ;; update width and height of the sheet + (setf (rect-width plan) (max (rect-width plan) + (1+ (right-most tile))) + (rect-height plan) (max (rect-height plan) + (1+ (bottom-most tile)))) + + ;; update the corner plan + (push tile (positioned plan)) + (setf (candidates plan) + (delete (top-left tile) + (candidates plan) + :test #'equal)) + (pushnew (translate-pt (top-right tile) 1 0) (candidates plan) + :test #'equal) + (pushnew (translate-pt (bottom-left tile) 0 1) (candidates plan) + :test #'equal)) + + + +(defun position-tiles (tiles) + (let ((plan (make-instance 'sheet-plan)) + (tiles (sort tiles #'> :key #'rect-area))) + (dolist (tile tiles plan) + (position-tile plan tile)))) + + + +(defun render-sheet (plan) + (let ((sheet (opticl:make-8-bit-rgba-image (rect-width plan) (rect-height plan)))) + (dolist (tile (positioned plan)) + (with-slots (x y width height data) tile + (dotimes (px width) + (dotimes (py height) + (setf (opticl:pixel sheet (+ x px) (+ y py) ) + (opticl:pixel data px py )))))) + sheet)) + + + +(defun load-tile (path) + (let ((data + (convert-image-to-rgba + (read-png-file path)))) + + (with-image-bounds (w h) data + (make-instance 'tile + :path path + :data data + :width w + :height h)))) + +(defun png-file-p (path) + (declare (type pathname path)) + (string-equal "png" (pathname-type path))) + +(defvar *bad-images* nil) + +(defun images-under-dir (dir) + (let ((images '()) + (*bad-images* nil)) + (uiop:collect-sub*directories + dir + (constantly t) + (constantly t) + (lambda (subdir) + (dolist (file (uiop:directory-files subdir)) + (when (png-file-p file) + (handler-case + (push (load-tile file) images) + (error (e) + (declare (ignore e)) + (push file *bad-images*))))))) + images)) + |