From 43db41841cf17a8b80a596fe1d1e46472da0933c Mon Sep 17 00:00:00 2001 From: John Connors Date: Sat, 29 Mar 2008 13:00:01 +0000 Subject: [PATCH 1/1] Initial commit --- color-map.lisp | 82 +++++++ package.lisp | 10 + rectangles.lisp | 165 ++++++++++++++ yotta-zoomer.asd | 19 ++ yotta-zoomer.lisp | 639 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 915 insertions(+) create mode 100755 color-map.lisp create mode 100755 package.lisp create mode 100755 rectangles.lisp create mode 100644 yotta-zoomer.asd create mode 100755 yotta-zoomer.lisp diff --git a/color-map.lisp b/color-map.lisp new file mode 100755 index 0000000..7a12be5 --- /dev/null +++ b/color-map.lisp @@ -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 index 0000000..2981f41 --- /dev/null +++ b/package.lisp @@ -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 index 0000000..24e5466 --- /dev/null +++ b/rectangles.lisp @@ -0,0 +1,165 @@ +;;;; rectangles.lisp + +(asdf:oos 'asdf:load-op 'cl-gd) + +(defpackage #:rectangles + (:use #:cl)) + +(in-package #:rectangles) + + +;; an abstract named rectangle thing +(defclass rectangle () + ((x :accessor x-of :iniform 0 :initarg :x) + (y :accessor y-of :initform 0 :initarg :y) + (w :accessor width-of :initform 1 :initarg :width) + (h :accessor height-of :initform 1 :initarg :height) + (name :accessof name-of :initform "Unknown")) + +;; split one rectangle into two. Returns two rectangles, +;; the first of which is the given fraction of the original, +;; the second the remaining area of the original +(defmethod split ((self rectangle) fraction &key direction) + (ccase direction + (:horizontal + (let* + ((h-top (* (height-of rectangle) fraction)) + (h-bot (- (height-of rectangle) h-top)) + (split-y (+ h-top (y-of rectangle)))) + (values + (make-instance 'rectangle + :x (x-of rectangle) + :y (y-of rectangle) + :width (width-of rectangle) + :height h-top) + (make-instance 'rectangle + :x (x-of rectangle) + :y split-y + :width (width-of rectangle) + :height h-bot)))) + (:vertical + (let* + ((w-top (* (width-of rectangle) fraction)) + (w-bot (- (width-of rectangle) w-top)) + (split-x (+ w-top (x-of rectangle)))) + (values + (make-instance 'rectangle + :x (x-of rectangle) + :y (y-of rectangle) + :width w-top + :height (height-of rectangle)) + (make-instance 'rectangle + :x split-x + :y (y-of rectangle) + :width w-bot + :height (height-of rectangle))))))) + +;; Represents a chart of rectangles +(defclass chart () + ((rectangles :initform nil) + (free-rectangle :initform (make-instance 'rectangle) :accessor free-rectangle-of))) + + +;; create a chart of rectangles from a property list of data +;; ( ( "Name" . value ) ...) + +(defmethod make-instance ((self chart) &key data) + (labels + ((sum-data (data) + "Return the sum od the data" + (reduce #'(lambda (t x) (+ t (cdr x))) data)) + (normalise-data (sum data) + "Normalise the data." + (loop + for element in data + collect (cons (car element) (/ (cdr element) sum)))) + (normalise (data) + "Normalise the data." + (normalise-data (sum-data data) data)) + (split-for-datum (datum &key direction) + (multiple-value-bind + (taken free) + (split (free-rectangle-of self) (cdr datum) :direction direction) + (progn + (setf (free-rectangle-of self) free) + (setf (name-of taken) (car data)) + (push (rectangles-of self) taken)))) + (consume-data (data) + (when data + ((split-for-datum (car data) :horizontal) + (consume-data (normalise (rest data)))))) + (consume-data data)))) + + + + + +(asdf:oos 'asdf:load-op 'cl-gd) + +(in-package 'cl-gd) + + +(defun discretize (data range) + (labels + ((sum-data (data) + (reduce #'+ data)))) + (let + ((result (make-array (array-total-size data)))) + (map-into result #'(lambda (x) (round (* (/ x (sum-data data))))) range))) + + +(defun region-sample (sample-count region sample-size sample-resolution sample-fn sample-score-fn) + (labels + ((randomly-place main-region &key within) + (make-instance 'rectangle + :x (+ (x-of region) (random (- (width-of region) (width-of within)))) + :y (+ (y-of region) (random (- (height-of region) (height-of within)))) + :width (width-of within) + :height (height-of within)) + (create-sample (region sample-resolution) + (let + ((result (make-array (* sample-resolution sample-resolution) + :fill-pointer 0 + :adjustable t))) + (loop + for x = (x-of region) then (+ x (/ (width-of region) sample-resolution)) + do + (loop + for y = (y-of region) then (+ y (/ (height-of region) sample-resolution)) + (vector-push (funcall sample-fn x y)))) + result)) + (let* + ((sample-region-rectangle + (make-instance 'rectangle + :width (* (width-of region) sample-size) + :height (* (width-of region) sample-size))) + (samples + (loop + for sample-index from 0 below sample-count + collect + (progn + (create-sample + (randomly-place sample-region-rectangle :within region) + sample-resolution)))) + (sample-scores + (sort + (loop + for sample in samples + for sample-index = 0 then (1+ sample-index) + collect + (cons + (funcall sample-score-fun sample) + sample-index)) + #'< :key #'car))) + (loop + for score in sample-scores + (collect + (cons (car score) (nth (car score) samples)))))))) + + + + + + + + diff --git a/yotta-zoomer.asd b/yotta-zoomer.asd new file mode 100644 index 0000000..f613e45 --- /dev/null +++ b/yotta-zoomer.asd @@ -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 index 0000000..2d8f10a --- /dev/null +++ b/yotta-zoomer.lisp @@ -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)))) + + + + + + -- 2.11.4.GIT