src/mandelbrot/render.lisp
Fri Apr 3 00:16:06 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-kde.examples/src/mandelbrot/render.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/mandelbrot/render.lisp 2014-10-30 07:20:22.000000000 +0100
@@ -0,0 +1,114 @@
+;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;; Copyright (C) 2009 Nokia Corporation and/or its subsidiary(-ies).
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;
+
+(in-package :kde.examples)
+
+(declaim (optimize (debug 3)))
+
+(defun make-image (width height)
+ (make-instance 'qt:image :args (list width height
+ qt:image.+format-rgb32+)))
+
+(declaim (inline z_0))
+(defun z_0 ()
+ #C(0d0 0d0))
+
+(declaim (inline z_n+1))
+(defun z_n+1 (z_n c)
+ (+ (expt z_n 2) c))
+
+(declaim (inline make-complex))
+(defun make-complex (realpart imagpart)
+ (+ (float realpart 0d0) (* imagpart #C(0d0 1d0))))
+
+
+(defun diverge-p (c iterations)
+ (declare (type (complex double-float) c)
+ (type fixnum iterations)
+ (optimize (speed 3) (debug 3) (safety 3)))
+ (let ((z (z_0)))
+ (declare (type (complex double-float) z))
+ (dotimes (n iterations nil)
+ (setf z (z_n+1 z c))
+ (when (> (+ (expt (realpart z) 2) (expt (imagpart z) 2)) 4)
+ (return n)))))
+
+
+(declaim (inline div-to-color))
+(defun div-to-color (n iterations)
+ (declare (type fixnum n iterations))
+ (let ((grey (- #xFF (min #xFF n))))
+ (+ #xFF000000
+ (* #x010000 grey)
+ (* #x000100 grey)
+ (* #x000001 grey))))
+
+(defclass render-control ()
+ ((done-signal :initform (qt:make-signal (find-class 'qt:image)
+ (find-class 'double-float))
+ :reader done-signal
+ :documentation "Signals that an image is ready.")
+ (mutex :initform (sb-thread:make-mutex)
+ :accessor mutex)
+ (stop-p :initform nil)))
+
+(defun stop-p (render-control)
+ (sb-thread:with-mutex ((mutex render-control))
+ (slot-value render-control 'stop-p)))
+
+(defmacro if-stop-p (render-control then else)
+ `(sb-thread:with-mutex ((mutex ,render-control))
+ (if (slot-value ,render-control 'stop-p)
+ ,then
+ ,else)))
+
+(defun (setf stop-p) (new-value control)
+ (sb-thread:with-mutex ((mutex control))
+ (setf (slot-value control 'stop-p)
+ new-value)))
+
+;;;a : x width
+;;;b : y height
+(defun render (center scale width height control)
+ (declare (fixnum width height)
+ (type (complex double-float) center)
+ (double-float scale)
+ (optimize (speed 3)))
+ (let ((image (make-image width height))
+ (top-left (- (/ (complex width height) 2))))
+ (dotimes (pass 1)
+ (let ((iterations 200)) ;(+ (expt 2 (+ (* 2 pass) 6)) 32)))
+ (dotimes (y height)
+ (when (stop-p control)
+ (return))
+ (let ((scanline (cxx:scan-line image y)))
+ (dotimes (x width)
+ (let ((diverge (diverge-p (+ (* scale (+ top-left (make-complex x y))) center) iterations)))
+ (if diverge
+ (setf (cffi:mem-ref scanline :unsigned-int)
+ (div-to-color diverge iterations))
+ (setf (cffi:mem-ref scanline :unsigned-int)
+ #.(qt:q-rgb 0 0 0))))
+ (cffi:incf-pointer scanline
+ (cffi:foreign-type-size :unsigned-int))))))
+ (if-stop-p control
+ (return)
+ (funcall (done-signal control) image scale)))))
+
+(defun make-render-function (center scale width height done-signal)
+ #'(lambda () (render center scale width height done-signal)))