Initial commitmaster
authorJohn Connors <johnc@yagc.ndo.co.uk>
Sat, 29 Mar 2008 13:00:01 +0000 (29 13:00 +0000)
committerJohn Connors <johnc@yagc.ndo.co.uk>
Sat, 29 Mar 2008 13:00:01 +0000 (29 13:00 +0000)
color-map.lisp [new file with mode: 0755]
package.lisp [new file with mode: 0755]
rectangles.lisp [new file with mode: 0755]
yotta-zoomer.asd [new file with mode: 0644]
yotta-zoomer.lisp [new file with mode: 0755]

diff --git a/color-map.lisp b/color-map.lisp
new file mode 100755 (executable)
index 0000000..7a12be5
--- /dev/null
@@ -0,0 +1,82 @@
+
+(defun get-red (color-list)
+  (cadr (assoc :red color-list)))
+
+(defun get-green (color-list)
+  (cadr (assoc :green color-list)))
+
+(defun get-blue (color-list)
+  (cadr (assoc :blue color-list)))
+
+(defun get-point (color-list)
+  (cadr (assoc :point color-list)))
+
+(defun calc-normal-alpha (start end alpha)
+  (* (- alpha start) (/ 1.0 (- end start))))
+  
+(defun add-point-to-color-list (color-list point &key red green blue)
+  (list
+   `((:red . ,red)
+    (:green . ,green)
+    (:blue . ,blue)
+    (:point . ,point))
+    color-list))
+
+(defun add-points-to-color-list (color-list points)
+  (append 
+    (loop 
+      for point in points
+      collect
+         (destructuring-bind
+               (p &key red green blue)
+             point 
+        `((:red ,red)
+          (:green ,green)
+          (:blue ,blue)
+          (:point ,p))))
+   color-list))
+
+(defparameter *color-list* 
+  (add-points-to-color-list
+   nil
+  '((0.0 :red 255 :green 255 :blue 255)
+     (0.1 :red 64 :green 0 :blue 64)
+     (0.5 :red 0 :green 64 :blue 64)
+     (1.0 :red 64 :green 63 :blue 0))))
+
+(defun sort-color-list (color-list)
+       (sort color-list
+             #'(lambda (x y)
+                 (< (cadr (assoc :point x))
+                    (cadr (assoc :point y))))))
+
+(defun make-color-list-interpolator (color-list)
+  (let 
+      ((sorted-color-list (sort-color-list color-list)))
+    (lambda (alpha)
+      (destructuring-bind
+            (start end)
+          (loop
+             for next-color in sorted-color-list
+             and color = nil then next-color
+             when (<= alpha (cadr (assoc :point next-color)))
+             return
+               (list color next-color))
+        (list
+         (cons
+          :red 
+          ((cadr (assoc :red start))
+           + (*
+              (- (cadr (assoc :red end))
+                 (cadr (assoc :red end))
+))
+  
+  (format t "~A ~A~%~A~%" color next-color
+                   (>= alpha (cadr (assoc :point next-color))))))))
+
+
+         return (cons color next-color)))))
+                 
+;; to do -- 
+;; sort-color-list
+;; make-color-list-interpolator
\ No newline at end of file
diff --git a/package.lisp b/package.lisp
new file mode 100755 (executable)
index 0000000..2981f41
--- /dev/null
@@ -0,0 +1,10 @@
+;;;; package.lisp
+
+(in-package #:yotta-zoomer-system)
+
+(defpackage #:yotta-zoomer
+  (:use :cl :iterate))
+
+(in-package #:yotta-zoomer)
+
+
diff --git a/rectangles.lisp b/rectangles.lisp
new file mode 100755 (executable)
index 0000000..24e5466
--- /dev/null
@@ -0,0 +1,165 @@
+;;;; rectangles.lisp\r
+\r
+(asdf:oos 'asdf:load-op 'cl-gd)\r
+\r
+(defpackage #:rectangles\r
+  (:use #:cl))\r
+\r
+(in-package #:rectangles)\r
+\r
+\r
+;; an abstract named rectangle thing\r
+(defclass rectangle ()\r
+  ((x :accessor x-of :iniform 0 :initarg :x)\r
+   (y :accessor y-of :initform 0 :initarg :y)\r
+   (w :accessor width-of :initform 1 :initarg :width)\r
+   (h :accessor height-of :initform 1 :initarg :height)\r
+   (name :accessof name-of :initform "Unknown"))\r
+\r
+;; split one rectangle into two. Returns two rectangles,\r
+;; the first of which is the given fraction of the original,\r
+;; the second the remaining area of the original\r
+(defmethod split ((self rectangle) fraction &key direction)\r
+  (ccase direction\r
+                (:horizontal \r
+                 (let*\r
+                         ((h-top (* (height-of rectangle) fraction))\r
+                          (h-bot (- (height-of rectangle) h-top))\r
+                          (split-y (+ h-top (y-of rectangle))))\r
+                       (values\r
+                        (make-instance 'rectangle\r
+                                                       :x (x-of rectangle)\r
+                                                       :y (y-of rectangle)\r
+                                                       :width (width-of rectangle)\r
+                                                       :height h-top)\r
+                        (make-instance 'rectangle\r
+                                                       :x (x-of rectangle)\r
+                                                       :y split-y\r
+                                                       :width (width-of rectangle)\r
+                                                       :height h-bot))))\r
+                (:vertical \r
+                 (let*\r
+                         ((w-top (* (width-of rectangle) fraction))\r
+                          (w-bot (- (width-of rectangle) w-top))\r
+                          (split-x (+ w-top (x-of rectangle))))\r
+                       (values\r
+                        (make-instance 'rectangle\r
+                                                       :x (x-of rectangle)\r
+                                                       :y (y-of rectangle)\r
+                                                       :width w-top\r
+                                                       :height (height-of rectangle))\r
+                        (make-instance 'rectangle\r
+                                                       :x split-x\r
+                                                       :y (y-of rectangle)\r
+                                                       :width w-bot\r
+                                                       :height (height-of rectangle)))))))\r
+\r
+;; Represents a chart of rectangles\r
+(defclass chart ()\r
+  ((rectangles :initform nil)\r
+   (free-rectangle :initform (make-instance 'rectangle) :accessor free-rectangle-of)))\r
+  \r
+\r
+;; create a chart of rectangles from a property list of data\r
+;; ( ( "Name" . value ) ...)\r
+\r
+(defmethod make-instance ((self chart) &key data)\r
+  (labels\r
+         ((sum-data (data)\r
+                                "Return the sum od the data"\r
+                                (reduce #'(lambda (t x) (+  t (cdr x))) data))\r
+          (normalise-data (sum data)\r
+                                          "Normalise the data."\r
+                                          (loop\r
+                                               for element in data\r
+                                               collect (cons (car element) (/ (cdr element) sum))))\r
+          (normalise (data)\r
+                                 "Normalise the data."\r
+                                 (normalise-data (sum-data data) data))\r
+          (split-for-datum (datum &key direction)\r
+                                               (multiple-value-bind\r
+                                                       (taken free)\r
+                                                       (split (free-rectangle-of self) (cdr datum) :direction direction)\r
+                                                 (progn\r
+                                                       (setf (free-rectangle-of self) free)\r
+                                                       (setf (name-of taken) (car data))\r
+                                                       (push (rectangles-of self) taken))))\r
+          (consume-data (data)\r
+                                        (when data\r
+                                          ((split-for-datum (car data) :horizontal)\r
+                                               (consume-data (normalise (rest data))))))\r
+          (consume-data data))))\r
+          \r
+\r
+               \r
+                \r
+          \r
+(asdf:oos 'asdf:load-op 'cl-gd)\r
+\r
+(in-package 'cl-gd)\r
+\r
+\r
+(defun discretize (data range)\r
+  (labels\r
+         ((sum-data (data)\r
+                                (reduce #'+ data))))\r
+  (let \r
+         ((result (make-array (array-total-size data))))       \r
+       (map-into result #'(lambda (x) (round (* (/ x (sum-data data))))) range)))\r
+       \r
+\r
+(defun region-sample (sample-count region sample-size sample-resolution sample-fn sample-score-fn)\r
+  (labels\r
+         ((randomly-place main-region &key within)\r
+          (make-instance 'rectangle\r
+                                         :x (+ (x-of region) (random (- (width-of region) (width-of within))))\r
+                                         :y (+ (y-of region) (random (- (height-of region) (height-of within))))\r
+                                         :width (width-of within)\r
+                                         :height (height-of within))\r
+          (create-sample (region sample-resolution)\r
+                                         (let \r
+                                                 ((result (make-array (* sample-resolution sample-resolution)\r
+                                                                                          :fill-pointer 0\r
+                                                                                          :adjustable t)))\r
+                                               (loop\r
+                                                for x = (x-of region) then (+ x (/ (width-of region) sample-resolution))\r
+                                                do\r
+                                                (loop\r
+                                                 for y = (y-of region) then (+ y (/ (height-of region) sample-resolution))\r
+                                                 (vector-push (funcall sample-fn x y))))\r
+                                               result))\r
+          (let*\r
+                  ((sample-region-rectangle \r
+                        (make-instance 'rectangle \r
+                                                       :width (* (width-of region) sample-size)\r
+                                                       :height (* (width-of region) sample-size)))\r
+                       (samples\r
+                        (loop\r
+                         for sample-index from 0 below sample-count\r
+                                                        collect\r
+                                                        (progn\r
+                                                          (create-sample\r
+                                                               (randomly-place sample-region-rectangle :within region)\r
+                                                               sample-resolution))))\r
+                       (sample-scores\r
+                        (sort\r
+                         (loop\r
+                          for sample in samples\r
+                          for sample-index = 0 then (1+ sample-index)\r
+                          collect\r
+                          (cons \r
+                               (funcall sample-score-fun sample)\r
+                               sample-index))\r
+                         #'< :key #'car)))\r
+                (loop\r
+                 for score in sample-scores\r
+                 (collect\r
+                  (cons (car score) (nth (car score) samples))))))))\r
+          \r
+                \r
+\r
+               \r
+\r
+\r
+\r
+\r
diff --git a/yotta-zoomer.asd b/yotta-zoomer.asd
new file mode 100644 (file)
index 0000000..f613e45
--- /dev/null
@@ -0,0 +1,19 @@
+;;;; cl-fractal-zoom.asd
+
+(defpackage #:yotta-zoomer-system
+  (:use #:asdf #:cl))
+
+(in-package #:yotta-zoomer-system)
+
+(asdf:defsystem #:yotta-zoomer
+  :depends-on (:cl-glfw 
+               :cl-glfw-glu 
+               :cl-glfw-opengl 
+               :cl-glfw-opengl-version_1_1 
+               :cl-glfw-opengl-version_1_2 
+               :cowl-glfw 
+               :iterate )
+  :serial t
+  :components 
+  ((:file "package")
+   (:file "yotta-zoomer")))
diff --git a/yotta-zoomer.lisp b/yotta-zoomer.lisp
new file mode 100755 (executable)
index 0000000..2d8f10a
--- /dev/null
@@ -0,0 +1,639 @@
+
+(in-package :yotta-zoomer)
+
+(declaim (optimize (speed 0) (safety 3) (debug 3) (compilation-speed 0)))
+
+(defmacro with-gensyms ((&rest names) &body body)
+  `(let ,(loop for n in names collect `(,n (gensym)))
+     ,@body))
+
+(defmacro once-only ((&rest names) &body body)
+  (let ((gensyms (loop for n in names collect (gensym))))
+    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
+       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
+          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
+             ,@body)))))
+
+(defmacro with-opengl (&body forms)
+  (with-gensyms (error-sym)
+    `(progn ,@forms 
+            (let ((,error-sym  (gl:get-error)))
+              (unless ,error-sym 
+                (error "OpenGL Error ~A~%" 
+                       (case ,error-sym
+                         (gl:+INVALID-ENUM+ "Invalid Enum")
+                         (gl:+INVALID-VALUE+ "Invalid value")
+                         (gl:+INVALID-OPERATION+ "Invalid Operation")
+                         (gl:+OUT-OF-MEMORY+ "Out of memory")
+                         (gl:+STACK-OVERFLOW+ "Stack overflow")
+                         (gl:+STACK-UNDERFLOW+ "Stack underflow"))))))))
+
+(defconstant +squared-limit+ 4.0)
+(defparameter *max-iterations* 16)
+
+(defclass rgba-image  ()
+  ((name :accessor name-of)
+   (width :accessor width-of :initform 0)
+   (height :accessor height-of :initform 0)
+   (format :reader format-of :initform gl:+rgba+)
+   (bpp :reader bpp-of :initform 4)
+   (data :accessor data-of)
+   (size :accessor size-of))
+  (:documentation "Data  for an opengl RGBA texture"))
+
+(defmethod make-image ((self rgba-image) &key width height)
+  "Create a sized rgba texture"
+  (setf (width-of self) width)
+  (setf (height-of self) height)
+  (setf (slot-value self 'name) (cffi:foreign-alloc :uint32))
+  (with-opengl 
+    (gl:gen-textures 1 (name-of self))
+    (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
+    (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-wrap-s+ gl:+repeat+) 
+    (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-wrap-t+ gl:+repeat+) 
+    (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-mag-filter+ gl:+linear+)
+    (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-min-filter+ gl:+linear+) 
+    (gl:pixel-store-i gl:+unpack-alignment+ 1)
+    (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+decal+))
+  (setf (slot-value self 'data)
+        (cffi:foreign-alloc :uint32
+                            :count (* (width-of self) (height-of self))
+                            :initial-element 0)))
+
+(defmethod update-image ((self rgba-image))
+  "Upload an RGBA texture"
+  (with-opengl
+    (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
+    (gl:tex-image-2d gl:+texture-2d+ 0 gl:+rgba+ 
+                     (width-of self) (height-of self) 
+                     0 gl:+rgba+ gl:+unsigned-byte+ (data-of self))))
+
+
+(defgeneric render (self &key target))
+
+(defmethod render ((self rgba-image) &key target)
+  "Render an RGBA texture"
+  (declare (ignore target))
+  (with-opengl
+    (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
+    (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+decal+)
+    (gl:with-begin gl:+quads+
+      (gl:tex-coord-2i 0 0)
+      (gl:vertex-2f -0.5 -0.5) ;; top lhs
+      (gl:tex-coord-2i 1 0)
+      (gl:vertex-2f  0.5 -0.5) ;; top rhs
+      (gl:tex-coord-2i 1 1)
+      (gl:vertex-2f  0.5  0.5) ;; bot rhs
+      (gl:tex-coord-2i 0 1)
+      (gl:vertex-2f -0.5  0.5)))) ;; bot lhs
+
+(defmethod destroy-image ((self rgba-image))
+  "Release the memory used by an RGBA texture"
+  (setf (width-of self) 0)
+  (setf (height-of self) 0)
+  (with-opengl
+    (gl:delete-textures 1 (name-of self))
+    (cffi:foreign-free (name-of self))
+    (cffi:foreign-free (data-of self))))
+
+
+
+(defmethod image-size ((image rgba-image))
+  "Overall RGBA texture size in bytes"
+  (* (width-of image) (height-of image)))
+
+(defmethod pixel ((image rgba-image) i)
+  "Access a pixel in an RGBA texture"
+  (cffi:mem-aref (data-of image) :uint32 i))
+
+(defmethod (setf pixel) (pixel (image rgba-image) i)
+  "Set a pixel in an RGBA texture"
+  (setf (cffi:mem-aref (data-of image) :uint32 i) pixel))
+
+(defmethod indexxy ((image rgba-image) index)
+  "Map an i index to an x,y index of a RGBA texure"
+  (values (mod index (width-of image))
+          (rem index (width-of image))))
+
+(defmethod xyindex ((image rgba-image) x y)
+  "Map an x,y index to an i index of a RGBA texure"
+  (+ x (* (width-of image) y)))
+
+(defun map-color-to-pixel (r g b)
+  "Convert rgb values to a pixel uint32"
+  (declare ((unsigned-byte 8) r g b))
+  (logior
+   (ash r 24)
+   (ash g 16)
+   (ash b 8)
+   #X0))
+
+
+;; FIRST THINGS FIRST -- make a slow zoom into 0,0 work
+;; make a colormap work
+;; then take samples :-)
+
+(declaim (ftype
+          (function (fixnum fixnum)
+                    (simple-array (unsigned-byte 8) *)) make-iteration-map))
+
+(defclass iteration-map  ()
+  ((width :reader width-of :initarg :width)
+   (height :reader height-of :initarg :height)
+   (map :reader map-of))
+  (:documentation "A map of the results of iterating a function over a fixed range of values"))
+
+(defmethod initialize-instance :after ((self iteration-map) &rest args)
+  (declare (ignore args))
+  (setf (slot-value self 'map) (make-array (* (width-of self) (height-of self)) :element-type '(unsigned-byte 8))))
+
+(defmethod result ((image iteration-map) i)
+  (aref (map-of image)  i))
+
+(defmethod (setf result) (value (image iteration-map) i)
+  (setf (aref (map-of image) i) value))
+
+(defmethod indexxy ((image iteration-map) index)
+  (values (mod index (width-of image))
+          (rem index (width-of image))))
+
+(defmethod xyindex ((image iteration-map) x y)
+  (+ x (* (width-of image) y)))
+
+
+(defun make-iteration-mapper (iteration-map
+                              iterated-function
+                              escape-function)
+  "Create an function to creat an iteration map of function on the given surface,
+in a region interpoalated between two region extents,"
+  #'(lambda (region-fn alpha max-evaluations)
+      (declare (type single-float alpha) (type fixnum max-evaluations))
+      (labels
+          ((evaluate-point (c)
+             "Evaluate the iteration function for a given point"
+             (declare (type (complex single-float) c))
+             (let ((z #C(0.0 0.0)))
+               (loop for eval-count of-type fixnum from 0 below max-evaluations
+                  until (funcall escape-function z)
+                  do  (setf z (funcall iterated-function z c))
+                  finally (return eval-count)))))
+        ;; work out the region we sample
+        (multiple-value-bind
+              (top-left bottom-right)
+            (funcall region-fn alpha)
+          (let*
+              ((difference (- bottom-right top-left))
+               (real-step (complex (/ (realpart difference)
+                                      (width-of iteration-map))
+                                   (- (imagpart difference))))
+               (imag-step (complex 0.0
+                                   (/ (imagpart difference)
+                                      (height-of iteration-map))))
+               (c top-left))
+            ;; iterate over the region
+            (dotimes (x (width-of iteration-map))
+              (dotimes (y (height-of iteration-map))
+                (setf (result iteration-map (xyindex iteration-map x y)) (evaluate-point c))
+                (incf c imag-step))
+              (incf c real-step))))
+        (values))))
+
+;; to do -- zoom in on a defined region via lerping to a target
+;; to do -- construct iteration map line by line
+
+
+(defun make-limit-interpolator (&key start-top-left start-bottom-right
+                                fin-top-left fin-bottom-right)
+  "Construct a function to lerp between two sets of limits"
+  (format t "Creating interpolator for ~A ~A ~A ~A~%"
+          start-top-left start-bottom-right fin-top-left fin-bottom-right)
+  #'(lambda (alpha)
+      (declare (type single-float alpha))
+      (values
+       ;; max
+       (+ start-top-left
+          (* (- fin-top-left start-top-left) alpha))
+       ;; to do -- min
+       (+ start-bottom-right
+          (* (- fin-bottom-right start-bottom-right) alpha)))))
+
+(defun print-iteration-map (iteration-map width height)
+  (dotimes (y width)
+    (dotimes (x height)
+      (if (>= (result iteration-map (xyindex iteration-map x y)) *max-iterations*)
+          (format t "~C" #\*)
+        (format t "~C" #\Space)))
+    (format t "~%")))
+
+;;; TO DO -- update this and test sampling
+;; ;; quicky test
+;; (defun iteration-mapper-test (i-m width height max-iter)
+;;   (let*
+;;       ((interpolator (make-limit-interpolator
+;;                       :start-top-left #C(-2.0 -2.0)
+;;                       :start-bottom-right  #C(2.0 2.0)
+;;                       :fin-top-left #C(-1.0 -1.0)
+;;                       :fin-bottom-right #C(1.0 1.0)))
+;;        (i-mapper (make-iteration-mapper i-m #'mandelbrot width height max-iter
+;;                                         interpolator)))
+
+;;     (funcall  i-mapper 0.0)
+;;     (print-iteration-map i-m 64 64 max-iter)
+;;     (funcall i-mapper 1.0)
+;;     (print-iteration-map i-m 64 64 max-iter)))
+
+;; color maps
+
+(defun get-red (color-list)
+  (cadr (assoc :red color-list)))
+
+(defun get-green (color-list)
+  (cadr (assoc :green color-list)))
+
+(defun get-blue (color-list)
+  (cadr (assoc :blue color-list)))
+
+(defun get-point (color-list)
+  (cadr (assoc :point color-list)))
+
+(defun calc-normal-alpha (start end alpha)
+  (* (- alpha start) (/ 1.0 (- end start))))
+
+(defun lerp (v0 v1 alpha)
+  (round  (+ v0
+             (* (- v1 v0) alpha))))
+
+(defun add-point-to-color-list (color-list point &key red green blue)
+  (list
+   `((:red . ,red)
+     (:green . ,green)
+     (:blue . ,blue)
+     (:point . ,point))
+   color-list))
+
+(defun add-points-to-color-list (color-list points)
+  (append
+   (loop
+    for point in points
+    collect
+    (destructuring-bind
+        (p &key red green blue)
+        point
+      `((:red ,red)
+        (:green ,green)
+        (:blue ,blue)
+        (:point ,p))))
+   color-list))
+
+
+(defun sort-color-list (color-list)
+  (sort color-list
+        #'(lambda (x y)
+            (< (cadr (assoc :point x))
+               (cadr (assoc :point y))))))
+
+(defun make-color-list-interpolator (color-list)
+  (let
+      ((sorted-color-list (sort-color-list color-list)))
+    (lambda (alpha)
+      (destructuring-bind
+          (start end)
+          (loop
+           for next-color in sorted-color-list
+           and color = nil then next-color
+           when (<= alpha (cadr (assoc :point next-color)))
+           return
+           (list color next-color))
+        (let
+            ((normal-alpha
+              (calc-normal-alpha
+               (get-point start)
+               (get-point end)
+               alpha)))
+          (values
+           (lerp (get-red start) (get-red end) normal-alpha)
+           (lerp (get-green start) (get-green end) normal-alpha)
+           (lerp (get-blue start) (get-blue end) normal-alpha)))))))
+
+
+
+(defun render-fractal-map  (iteration-map image color-interpolator)
+  (let
+      ((width (width-of image))
+       (height (height-of image))
+       (iter-limit (coerce *max-iterations* 'single-float)))
+    (loop for x from 0 below width do
+         (loop for y from 0 below height do
+              (multiple-value-bind
+                    (red green blue)
+                  (funcall color-interpolator
+                           (/ (result iteration-map (xyindex iteration-map x y)) iter-limit))
+                (setf (pixel image (xyindex image x y))
+                      (map-color-to-pixel
+                       red green blue))))))
+  (update-image image)
+  (render image))
+
+;; to do -- check real == x & imag == y
+(defun calc-iteration-map-limits (width height
+                                  sample-x sample-y
+                                  sample-width sample-height
+                                  top-left bottom-right)
+  "Given an iteration map with the given width and height, and a sample
+at the given position and size, work out the real and imaginary
+dimensions of the sample and return a suitable interpolation fn"
+  (let*
+      ((real-width
+        (realpart (- bottom-right top-left)))
+       (imag-width
+        (imagpart (- bottom-right top-left)))
+       (real-scale (/ real-width width))
+       (imag-scale (/ imag-width height)))
+
+    (make-limit-interpolator
+     :start-top-left top-left
+     :start-bottom-right bottom-right
+     :fin-top-left
+     (complex (* sample-x real-scale)
+              (* sample-y imag-scale))
+     :fin-bottom-right
+     (complex
+      (+
+       (* sample-x real-scale)
+       (* sample-width real-scale))
+      (+
+       (* sample-y imag-scale)
+       (* sample-height imag-scale))))))
+
+(defclass sample (iteration-map)
+  ((x :accessor x-of :initarg :sample-x)
+   (y :accessor y-of :initarg :sample-y)
+   (colour-count :accessor colours-in :initform 0)))
+
+;; to do -- wouldn't it be better to pass in a function to this
+;; to operate on the sample and return a result, rather than
+;; building a huje list of samples?
+(defun take-map-sample (iteration-map x y
+                                      sample-width sample-height)
+  "Return an sampled area in the iteration map"
+  (let
+      ((sample (make-instance 'sample
+                              :sample-x x
+                              :sample-y y
+                              :width sample-width
+                              :height sample-height)))
+    (dotimes (dx sample-width)
+      (dotimes (dy sample-height)
+        (setf (pixel sample (xyindex sample  dx dy))
+              (pixel iteration-map (xyindex iteration-map  (+ x dx) (+ y dy))))))
+    sample))
+
+
+(defun sample-map (iteration-map width height sample-width sample-height sample-count)
+  "Return a list of random samples of areas of a given size in the
+iteration map"
+  (iterate
+   (for sample-index from 0 below sample-count)
+   (for sample-x =  (random (- width sample-width)))
+   (for sample-y = (random (- height sample-height)))
+   (collect
+    (take-map-sample iteration-map
+                     sample-x sample-y sample-width sample-height))))
+
+(defun sample-frequency (sample)
+  "Return the number of distinct colours in the sample"
+  (dotimes (color-index 255)
+    (when (find color-index (map-of sample))
+      (incf (colours-in sample)))))
+
+
+(defun mandelbrot (z c)
+  "Evaluate an iteration of the mandelbrot set function."
+  (declare ((complex single-float) z c))
+  (the (complex single-float)
+    (+ (expt z 2) c)))
+
+
+(defun norm-squared-escape (z)
+  "Return the squared normal of the complex number"
+  (declare ((complex single-float) z))
+  (let ((real-part (realpart z))
+        (imag-part (imagpart z)))
+    (declare (single-float real-part imag-part))
+    (>= (the single-float
+          (+ (expt real-part 2)
+             (expt imag-part 2)))
+        +squared-limit+)))
+
+(defvar *esc-pressed* nil)
+
+(cffi:defcallback key-callback :void ((key :int) (action :int))
+                  (when (eql action glfw:+press+)
+                    (cond
+                     ((eql key glfw:+key-esc+)  (setf *esc-pressed* t)
+                      ))))
+
+(cffi:defcallback window-size-callback :void ((width :int) (height :int))
+                  (gl:viewport 0 0 width height))
+
+
+
+
+
+;;  (sdl::update-surface :surface video-surface)
+;;  (sdl::update-display video-surface)
+;;              (when (= sample-index samples-between-extents)
+;;                (let*
+;;                    ((sample-width (round (/ width 128)))
+;;                     (sample-height (round (/ height 128)))
+;;                     (sample-area (* sample-width sample-height)))
+;;                  (format t "Resampling using 42 samples of ~D x ~D pixels~%" sample-width sample-height)
+;;                ;; time to resample
+;;                  (let*
+;;                      ((samples
+;;                        (sort
+;;                         (sample-map iteration-map width height
+;;                                    sample-width sample-height
+;;                                    42)
+;;                         #'(lambda (sample0 sample1)
+;;                             (> (sample-frequency sample1)
+;;                                (sample-frequency sample0)))))
+;;                       (selected-sample
+;;                        (car samples)))
+;;                    (format t "Picking sample with frequency ~D~%"
+;;                            (sample-frequency (car samples)))
+;;                       (let*
+;;                           ((sample-x (cadr (assoc :sample-x selected-sample)))
+;;                            (sample-y (cadr (assoc :sample-y selected-sample))))
+;;                         (multiple-value-bind
+;;                               (start-top-left start-bottom-right)
+;;                             (funcall interpolator-fn 1.0)
+;;                           (setf interpolator-fn
+;;                                 (calc-iteration-map-limits
+;;                                  width height
+;;                                  sample-x sample-y
+;;                                  sample-width sample-height
+;;                                  start-top-left start-bottom-right))
+;;                           (setf sample-index 0)))))))
+
+
+(defparameter *texture-names* nil)
+
+(defun init-gl ()
+  ;;  Disable stuff that's likely to slow down glRenderPixels.
+  ;;  (Omit as much of this as possible, when you know in advance
+  ;;   that the OpenGL state will already be set correctly.)
+  (gl:enable gl:+texture-2d+)
+  (gl:matrix-mode gl:+projection+)
+  (gl:load-identity)
+  (gl:matrix-mode gl:+modelview+)
+  (gl:load-identity))
+
+
+(defun end-gl ()
+  ())
+
+(defparameter *frame-count* 0)
+(defparameter *height* 480)
+(defparameter *width* 640)
+(defparameter *max-iterations* 16)
+
+
+(defparameter *max-frames* 128)
+
+(defun pixel-toast ()
+  (glfw:with-init-window 
+      ("Mandelbrot" *width* *height*) 
+    (glfw::enable glfw:+key-repeat+)
+    (glfw:set-window-size-callback (cffi:callback window-size-callback))
+    (init-gl)
+    (glfw:set-key-callback (cffi:callback key-callback))
+    (glfw:swap-interval 1)
+    (let* 
+        ((frame 0)
+         (image (make-instance 'rgba-image))
+         (iteration-map (make-instance 'iteration-map :width *width* :height *height*))
+         (color-list
+          (add-points-to-color-list
+           nil
+           '((0.0 :red 255 :green 255 :blue 255)
+             (0.1 :red 64 :green 0 :blue 64)
+             (0.5 :red 0 :green 64 :blue 64)
+             (1.0 :red 64 :green 63 :blue 0))))
+         (color-interpolator
+          (make-color-list-interpolator color-list))
+         (region-fn
+          (make-limit-interpolator :start-top-left #C(-2.0 -2.0)
+                                   :start-bottom-right #C(2.0 2.0)
+                                   :fin-top-left #C(-1.0 -1.0)
+                                   :fin-bottom-right #C(1.0 1.0)))
+         (fractal-mapper (make-iteration-mapper
+                          iteration-map
+                          #'mandelbrot
+                          #'norm-squared-escape)))
+      (setf cowl:*root-widget* (cowl::make-label "Yotta zoomer" :x 128 :y  128))
+      (make-image image :width *width* :height *height*)
+      (iterate
+        (while (and  (not *esc-pressed*) 
+                     (eql (glfw:get-window-param glfw:+opened+) gl:+true+)
+                     (< frame *max-frames*)))
+        (gl:clear gl:+color-buffer-bit+)
+        (setf (pixel image (xyindex image (random *width*) (random *height*))) (map-color-to-pixel 255 0 0))
+        (funcall fractal-mapper region-fn (coerce (/ frame *max-frames*) 'single-float) *max-iterations*)
+        (render-fractal-map iteration-map image color-interpolator)
+        (update-image image)
+        (render image)
+        (incf frame)
+         (cowl:layout-root)
+         (cowl:draw-root)        
+        (glfw:swap-buffers)
+        (cl:sleep 0.1)
+        (format *debug-io* "Frame ~A ~%" frame))
+      (destroy-image image)
+      (end-gl)
+      (if (eql (glfw:get-window-param glfw:+opened+) gl:+true+)
+               (glfw:close-window))
+      (glfw:terminate))))
+
+
+;; (defparameter *image* nil)
+;; (glfw:with-init-window ("A Simple Example" 640 480)  
+;;   (gl:with-setup-projection
+;;     (glu:perspective 45 4/3 0.1 50)
+;;     (setf *image* (make-instance 'rgba-image))
+;;     (make-image *image* :width 320 :height 200))
+;;   (iterate
+;;     (while (= cl-glfw:+true+ (cl-glfw:get-window-param cl-glfw:+opened+)))
+;;     (gl:clear gl:+color-buffer-bit+)
+;;     (gl:load-identity)
+;;     (gl:translate-f 0 0 -5)
+;;     (gl:rotate-f (* 10 (glfw:get-time)) 1 1 0)
+;;     (gl:rotate-f (* 90 (glfw:get-time)) 0 0 1)
+;;     (render *image*)
+;;     (gl:with-begin gl:+triangles+
+;;       (gl:color-3f 1 0 0) (gl:vertex-3f  1  0 0)
+;;       (gl:color-3f 0 1 0) (gl:vertex-3f -1  1 0)
+;;       (gl:color-3f 0 0 1) (gl:vertex-3f -1 -1 0))
+;;     (cl-glfw:swap-buffers)))
+
+;; (defun pixel-toast (width height frames-between-samples)
+;;   (glfw:with-open-window
+;;    ("Mandelbrot" width height)
+;;    (glfw::enable glfw:+key-repeat+)
+;;    (glfw:swap-interval 0)
+;;    (glfw:set-window-size-callback (cffi:callback window-size-callback))
+;;    (glfw:set-key-callback (cffi:callback key-callback))
+;;    (init-gl)
+;;    (let*
+;;        ((frame        0)
+;;         
+;;         )
+;;         
+        
+
+;; ;; to do -- maybe pass in interpolator to iteration-mapper
+;; ;; to do -- maybe have a n pass iteration map - do the escapes for 1 limit, then 2 limit
+;; (dglDrefun fractal-toast (width height samples-between-extents fn-iterations)
+;;   (let*
+;;       ((sample-index 0)
+;;        (iteration-map (make-iteration-map
+;;                        ;; to do
+;;                        width height))
+;;        (color-list
+;;         (add-points-to-color-list
+;;          nil
+;;          '((0.0 :red 255 :green 255 :blue 255)
+;;            (0.1 :red 64 :green 0 :blue 64)
+;;            (0.5 :red 0 :green 64 :blue 64)
+;;            (1.0 :red 64 :green 63 :blue 0))))
+;;        (color-interpolator
+;;         (make-color-list-interpolator color-list))
+;;        (interpolator-fn
+;;         (make-limit-interpolator :start-top-left #C(-2.0 -2.0)
+;;                                  :start-bottom-right #C(2.0 2.0)
+;;                                  :fin-top-left #C(-1.0 -1.0)
+;;                                  :fin-bottom-right #C(1.0 1.0)))
+;;        (iteration-mapper
+;;         (make-iteration-mapper
+;;          iteration-map
+;;          #'mandelbrot
+;;          #'norm-squared-escape
+;;          width height
+;;          fn-iterations
+;;          interpolator-fn)))
+;;     (declare (fixnum width height sample-index))
+;;  (glfw:do-window ("Mandelbrot")
+;;    ((glfw::enable glfw:+key-repeat+)
+;;     (glfw:swap-interval 0)
+;;     (glfw:set-window-size-callback (cffi:callback window-size-callback))
+;;     (glfw:set-key-callback (cffi:callback key-callback))
+;;     (init-gl))
+;;    (render iteration-mapper (/ sample-index samples-between-extents))
+;;    (incf sample-index)
+;;    (glfw::swap-buffers))))
+
+
+
+
+
+