repos
/
kde.examples
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial import
Annotate for file src/mandelbrot/render.lisp
2009-04-02 tobias
1
;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
22:16:06 '
2
;;; Copyright (C) 2009 Nokia Corporation and/or its subsidiary(-ies).
'
3
;;;
'
4
;;; This library is free software; you can redistribute it and/or
'
5
;;; modify it under the terms of the GNU Lesser General Public
'
6
;;; License as published by the Free Software Foundation; either
'
7
;;; version 2.1 of the License, or (at your option) any later version.
'
8
;;;
'
9
;;; This library is distributed in the hope that it will be useful,
'
10
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
'
11
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
'
12
;;; Lesser General Public License for more details.
'
13
;;;
'
14
;;; You should have received a copy of the GNU Lesser General Public
'
15
;;; License along with this library; if not, write to the Free Software
'
16
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
'
17
;;;
'
18
'
19
(in-package :kde.examples)
'
20
'
21
(declaim (optimize (debug 3)))
'
22
'
23
(defun make-image (width height)
'
24
(make-instance 'qt:image :args (list width height
'
25
qt:image.+format-rgb32+)))
'
26
'
27
(declaim (inline z_0))
'
28
(defun z_0 ()
'
29
#C(0d0 0d0))
'
30
'
31
(declaim (inline z_n+1))
'
32
(defun z_n+1 (z_n c)
'
33
(+ (expt z_n 2) c))
'
34
'
35
(declaim (inline make-complex))
'
36
(defun make-complex (realpart imagpart)
'
37
(+ (float realpart 0d0) (* imagpart #C(0d0 1d0))))
'
38
'
39
'
40
(defun diverge-p (c iterations)
'
41
(declare (type (complex double-float) c)
'
42
(type fixnum iterations)
'
43
(optimize (speed 3) (debug 3) (safety 3)))
'
44
(let ((z (z_0)))
'
45
(declare (type (complex double-float) z))
'
46
(dotimes (n iterations nil)
'
47
(setf z (z_n+1 z c))
'
48
(when (> (+ (expt (realpart z) 2) (expt (imagpart z) 2)) 4)
'
49
(return n)))))
'
50
'
51
'
52
(declaim (inline div-to-color))
'
53
(defun div-to-color (n iterations)
'
54
(declare (type fixnum n iterations))
'
55
(let ((grey (- #xFF (min #xFF n))))
'
56
(+ #xFF000000
'
57
(* #x010000 grey)
'
58
(* #x000100 grey)
'
59
(* #x000001 grey))))
'
60
'
61
(defclass render-control ()
'
62
((done-signal :initform (qt:make-signal (find-class 'qt:image)
'
63
(find-class 'double-float))
'
64
:reader done-signal
'
65
:documentation "Signals that an image is ready.")
'
66
(mutex :initform (sb-thread:make-mutex)
'
67
:accessor mutex)
'
68
(stop-p :initform nil)))
'
69
'
70
(defun stop-p (render-control)
'
71
(sb-thread:with-mutex ((mutex render-control))
'
72
(slot-value render-control 'stop-p)))
'
73
'
74
(defmacro if-stop-p (render-control then else)
'
75
`(sb-thread:with-mutex ((mutex ,render-control))
'
76
(if (slot-value ,render-control 'stop-p)
'
77
,then
'
78
,else)))
'
79
'
80
(defun (setf stop-p) (new-value control)
'
81
(sb-thread:with-mutex ((mutex control))
'
82
(setf (slot-value control 'stop-p)
'
83
new-value)))
'
84
'
85
;;;a : x width
'
86
;;;b : y height
'
87
(defun render (center scale width height control)
'
88
(declare (fixnum width height)
'
89
(type (complex double-float) center)
'
90
(double-float scale)
'
91
(optimize (speed 3)))
'
92
(let ((image (make-image width height))
'
93
(top-left (- (/ (complex width height) 2))))
'
94
(dotimes (pass 1)
'
95
(let ((iterations 200)) ;(+ (expt 2 (+ (* 2 pass) 6)) 32)))
'
96
(dotimes (y height)
'
97
(when (stop-p control)
'
98
(return))
'
99
(let ((scanline (cxx:scan-line image y)))
'
100
(dotimes (x width)
'
101
(let ((diverge (diverge-p (+ (* scale (+ top-left (make-complex x y))) center) iterations)))
'
102
(if diverge
'
103
(setf (cffi:mem-ref scanline :unsigned-int)
'
104
(div-to-color diverge iterations))
'
105
(setf (cffi:mem-ref scanline :unsigned-int)
'
106
#.(qt:q-rgb 0 0 0))))
'
107
(cffi:incf-pointer scanline
'
108
(cffi:foreign-type-size :unsigned-int))))))
'
109
(if-stop-p control
'
110
(return)
'
111
(funcall (done-signal control) image scale)))))
'
112
'
113
(defun make-render-function (center scale width height done-signal)
'
114
#'(lambda () (render center scale width height done-signal)))