Merge pull request #35 from compmstr/image-uv-coords

Added support for drawing partial images

sketch.asd

@@ -25,10 +25,10 @@
                (:file "channels")
                (:file "shaders")
                (:file "pen")
-               (:file "image")
                (:file "font")
                (:file "geometry")
                (:file "drawing")
+               (:file "image")
                (:file "shapes")
                (:file "transforms")
                (:file "sketch")

src/drawing.lisp

@@ -24,6 +24,12 @@
 (defparameter *draw-mode* :gpu)
 (defparameter *draw-sequence* nil)
 
+(defparameter *uv-rect* nil)
+
+(defmacro with-uv-rect (rect &body body)
+  `(let ((*uv-rect* ,rect))
+     ,@body))
+
 (defun start-draw ()
   (%gl:bind-buffer :array-buffer 1)
   (%gl:buffer-data :array-buffer *buffer-size* (cffi:null-pointer) :stream-draw)
@@ -38,29 +44,34 @@
   (typecase res
     (color (values (or (color-vector-255 res) (env-white-color-vector *env*))
                    (env-white-pixel-texture *env*)))
+    (cropped-image (values (env-white-color-vector *env*)
+                           (or (image-texture res) (env-white-pixel-texture *env*))
+                           (cropped-image-uv-rect res)))
     (image (values (env-white-color-vector *env*)
                    (or (image-texture res) (env-white-pixel-texture *env*))))))
 
 (defun draw-shape (primitive fill-vertices stroke-vertices)
   (when (and fill-vertices (pen-fill (env-pen *env*)))
-    (multiple-value-bind (shader-color shader-texture)
+    (multiple-value-bind (shader-color shader-texture uv-rect)
         (shader-color-texture-values (pen-fill (env-pen *env*)))
-      (push-vertices fill-vertices
-                     shader-color
-                     shader-texture
-                     primitive
-                     *draw-mode*)))
-  (when (and stroke-vertices (pen-stroke (env-pen *env*)))
-    (multiple-value-bind (shader-color shader-texture)
-        (shader-color-texture-values (pen-stroke (env-pen *env*)))
-      (let* ((weight (or (pen-weight (env-pen *env*)) 1))
-             (mixed (mix-lists stroke-vertices
-                               (grow-polygon stroke-vertices weight))))
-        (push-vertices (append mixed (list (first mixed) (second mixed)))
+      (with-uv-rect uv-rect
+        (push-vertices fill-vertices
                        shader-color
                        shader-texture
-                       :triangle-strip
-                       *draw-mode*)))))
+                       primitive
+                       *draw-mode*))))
+  (when (and stroke-vertices (pen-stroke (env-pen *env*)))
+    (multiple-value-bind (shader-color shader-texture uv-rect)
+        (shader-color-texture-values (pen-stroke (env-pen *env*)))
+      (with-uv-rect uv-rect
+        (let* ((weight (or (pen-weight (env-pen *env*)) 1))
+               (mixed (mix-lists stroke-vertices
+                                 (grow-polygon stroke-vertices weight))))
+          (push-vertices (append mixed (list (first mixed) (second mixed)))
+                         shader-color
+                         shader-texture
+                         :triangle-strip
+                         *draw-mode*))))))
 
 (defmethod push-vertices (vertices color texture primitive (draw-mode (eql :gpu)))
   (kit.gl.shader:uniform-matrix (env-programs *env*) :model-m 4
@@ -88,11 +99,19 @@
                 :pointer buffer-pointer
                 :length (length vertices)) *draw-sequence*)))
 
+(defun fit-uv-to-rect (uv)
+  (if *uv-rect* 
+      (destructuring-bind (u-in v-in) uv
+        (destructuring-bind (u1 v1 u-range v-range) *uv-rect*
+            (list (+ u1 (* u-range u-in))
+                  (+ v1 (* v-range v-in)))))
+      uv))
+
 (defun fill-buffer (buffer-pointer vertices color)
   (loop
      for idx from 0 by *vertex-attributes*
      for (x y) in vertices
-     for (tx ty) in (normalize-to-bounding-box vertices)
+     for (tx ty) in (mapcar #'fit-uv-to-rect (normalize-to-bounding-box vertices))
      do (setf (cffi:mem-aref buffer-pointer :float idx) (coerce-float x)
               (cffi:mem-aref buffer-pointer :float (+ idx 1)) (coerce-float y)
               (cffi:mem-aref buffer-pointer :float (+ idx 2)) (coerce-float tx)

src/image.lisp

@@ -12,7 +12,13 @@
   (with-pen (make-pen :fill image-resource
                       :stroke (pen-stroke (env-pen *env*))
                       :weight (pen-weight (env-pen *env*)))
-    (rect x
-          y
-          (or (abs-or-rel width (image-width image-resource)))
-          (or (abs-or-rel height (image-height image-resource))))))
+       (rect x
+             y
+             (or (abs-or-rel width (image-width image-resource)))
+             (or (abs-or-rel height (image-height image-resource))))))
+
+(defmethod crop ((image-resource image) x y w h)
+  "Generate a cropped image resource from IMAGE-RESOURCE, limiting how much of the image is drawn
+   to the rect of X,Y,W,H, which are all in pixel values."
+  (cropped-image-from-image image-resource x y w h))
+

src/package.lisp

@@ -140,6 +140,8 @@
            ;; Resources
            :load-resource
            :image
+           :crop
+           :with-uv-rect
 
            ;; Font
            :make-font

src/resources.lisp

@@ -17,6 +17,26 @@
    (width :accessor image-width :initarg :width)
    (height :accessor image-height :initarg :height)))
 
+(defclass cropped-image (image)
+  ((uv-rect :accessor cropped-image-uv-rect :initarg :uv-rect)))
+
+(defun pixel-uv-rect (img x y w h)
+  "Generate uv coordinates (0.0 to 1.0) for portion of IMG within
+   the rect specified by X Y W H
+   Image flipping can be done by using negative width and height values"
+  (with-slots (width height) img
+    (list (coerce-float (/ x width))
+          (coerce-float (/ y height))
+          (coerce-float (/ w width))
+          (coerce-float (/ h height)))))
+
+(defun cropped-image-from-image (image x y w h)
+  (make-instance 'cropped-image
+                 :texture (image-texture image)
+                 :width w
+                 :height h
+                 :uv-rect (pixel-uv-rect image x y w h)))
+
 (defclass typeface (resource)
   ((filename :accessor typeface-filename :initarg :filename)
    (pointer :accessor typeface-pointer :initarg :pointer)))