Adds CANVAS - see sketch-examples:stars

examples/package.lisp

@@ -3,7 +3,8 @@
 (defpackage #:sketch-examples
   (:use #:cl #:sketch)
   (:export :brownian
-	   :hello-world
-	   :life
-	   :sinewave))
-
+           :hello-world
+           :life
+           :sinewave
+           :stars
+           ))

examples/stars.lisp

@@ -0,0 +1,47 @@
+;;;; stars.lisp
+
+(in-package #:sketch-examples)
+
+;;;  ____ _____  _    ____  ____
+;;; / ___|_   _|/ \  |  _ \/ ___|
+;;; \___ \ | | / _ \ | |_) \___ \
+;;;  ___) || |/ ___ \|  _ < ___) |
+;;; |____/ |_/_/   \_\_| \_\____/
+
+(defsketch stars
+    ((stars (loop :for i :below 10 :collect (make-stars)))
+     (positions (loop :for i :from 18 :downto 0 :by 2 :collect i)))
+  (background +black+)
+  (dotimes (i (length stars))
+    (incf (elt positions i) 0.03)
+    (let ((zoom (get-zoom (elt positions i))))
+      (with-current-matrix
+        (with-pen (make-pen :fill (canvas-image (elt stars i)))
+          (translate 200 200)
+          (scale zoom)
+          (rect -50 -50 100 100)))))
+  (with-font (make-font :color +white+ :size 48
+                        :align :center)
+    (text "s k e t c h" 200 160))
+  (when (>= (get-zoom (car positions)) 20)
+    (setf (car positions) 0)
+    (setf positions (rotate-list positions))
+    (setf stars (rotate-list stars))))
+
+(defun make-stars ()
+  (let ((canvas (make-canvas 100 100)))
+    (dotimes (i 20)
+      (let ((x (random 100))
+            (y (random 100)))
+        (unless (and (< 40 x 60)
+                     (< 40 y 60)))
+        (canvas-paint canvas (gray-255 (+ 200 (random 55))) x y)))
+    (canvas-lock canvas)
+    canvas))
+
+(defun rotate-list (list)
+  (let ((el (pop list)))
+    (reverse (cons el (reverse list)))))
+
+(defun get-zoom (position)
+  (exp (/ position 6)))

sketch-examples.asd

@@ -13,4 +13,5 @@
                (:file "life")
                (:file "brownian")
                (:file "hello-world")
+               (:file "stars")
                ))

sketch.asd

@@ -34,4 +34,5 @@
                (:file "transforms")
                (:file "sketch")
                (:file "figures")
-               (:file "controllers")))
+               (:file "controllers")
+               (:file "canvas")))

src/canvas.lisp

@@ -0,0 +1,55 @@
+;;;; canvas.lisp
+
+(in-package #:sketch)
+
+;;;   ____    _    _   ___     ___    ____
+;;;  / ___|  / \  | \ | \ \   / / \  / ___|
+;;; | |     / _ \ |  \| |\ \ / / _ \ \___ \
+;;; | |___ / ___ \| |\  | \ V / ___ \ ___) |
+;;;  \____/_/   \_|_| \_|  \_/_/   \_|____/
+
+
+(defclass canvas ()
+  ((width :initarg :width :reader canvas-width)
+   (height :initarg :height :reader canvas-height)
+   (%image :initform nil :accessor %canvas-image)
+   (%vector :initform nil :accessor %canvas-vector)
+   (%locked :initform nil :accessor %canvas-locked)))
+
+(defun make-canvas (width height)
+  (let ((canvas (make-instance 'canvas :width width :height height)))
+    (canvas-reset canvas)
+    canvas))
+
+(defmethod %canvas-vector-pointer ((canvas canvas))
+  (static-vectors:static-vector-pointer (%canvas-vector canvas)))
+
+(defmethod canvas-reset ((canvas canvas))
+  (setf (%canvas-vector canvas)
+        (static-vectors:make-static-vector (* (canvas-width canvas) (canvas-height canvas) 4) :initial-element 0)))
+
+(defmethod canvas-paint ((canvas canvas) (color color) x y)
+  (let ((ptr (%canvas-vector-pointer canvas))
+        (pos (+ (* x 4) (* y 4 (canvas-width canvas))))
+        (vec (color-bgra-255 color)))
+    (dotimes (i 4)
+      (setf (cffi:mem-aref ptr :uint8 (+ pos i)) (elt vec i)))))
+
+(defmethod canvas-image ((canvas canvas))
+  (if (%canvas-locked canvas)
+      (%canvas-image canvas)
+      (make-image-from-surface
+       (sdl2:create-rgb-surface-with-format-from
+        (%canvas-vector-pointer canvas)
+        (canvas-width canvas)
+        (canvas-height canvas)
+        32
+        (* 4 (canvas-width canvas))
+        :format sdl2:+pixelformat-argb8888+))))
+
+(defmethod canvas-lock ((canvas canvas))
+  (setf (%canvas-image canvas) (canvas-image canvas)
+        (%canvas-locked canvas) t))
+
+(defmethod canvas-unlock ((canvas canvas))
+  (setf (%canvas-locked canvas) nil))

src/color.lisp

@@ -118,16 +118,31 @@
         (color-green color)
         (color-blue color)))
 
+(defun color-bgr (color)
+  (list (color-blue color)
+        (color-green color)
+        (color-red color)))
+
 (defun color-rgba (color)
   (list (color-red color)
         (color-green color)
         (color-blue color)
         (color-alpha color)))
 
+(defun color-bgra (color)
+  (list (color-blue color)
+        (color-green color)
+        (color-red color)
+        (color-alpha color)))
+
 (defun color-rgba-255 (color)
   (mapcar (lambda (x) (coerce (truncate (* 255 x)) 'unsigned-byte))
           (color-rgba color)))
 
+(defun color-bgra-255 (color)
+  (mapcar (lambda (x) (coerce (truncate (* 255 x)) 'unsigned-byte))
+          (color-bgra color)))
+
 (defun color-hsba (color)
   (list (color-hue color)
         (color-saturation color)

src/package.lisp

@@ -150,4 +150,12 @@
            :set-font
            :text
            :text-line-image
+
+           ;; Canvas
+           :make-canvas
+           :canvas-reset
+           :canvas-paint
+           :canvas-image
+           :canvas-lock
+           :canvas-unlock
            ))