darcs - kde.examples

3 ;;;

4 ;;; This program is free software: you can redistribute it and/or modify

5 ;;; it under the terms of the GNU General Public License as published by

6 ;;; the Free Software Foundation, either version 3 of the License, or

7 ;;; (at your option) any later version.

8 ;;;

9 ;;; This program 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

12 ;;; GNU General Public License for more details.

13 ;;;

14 ;;; You should have received a copy of the GNU General Public License

15 ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.

17 (in-package :cl-smoke.kde.examples)

19 (defun make-image (width height)

20 (make-instance 'qt:image :args (list width height

21 qt:image.+format-rgb32+)))

23 (declaim (inline z_0))

24 (defun z_0 ()

25 #C(0d0 0d0))

27 (declaim (inline z_n+1))

28 (defun z_n+1 (z_n c)

29 (+ (expt z_n 2) c))

31 (declaim (inline make-complex))

32 (defun make-complex (realpart imagpart)

33 (+ (float realpart 0d0) (* imagpart #C(0d0 1d0))))

36 (defun diverge-p (c iterations)

37 (declare (type (complex double-float) c)

38 (type fixnum iterations)

39 (optimize (speed 3) (debug 3) (safety 3)))

40 (let ((z (z_0)))

41 (declare (type (complex double-float) z))

42 (dotimes (n iterations nil)

43 (setf z (z_n+1 z c))

44 (when (> (+ (expt (realpart z) 2) (expt (imagpart z) 2)) 4)

45 (return n)))))

48 (declaim (inline div-to-color))

49 (defun div-to-color (n iterations)

50 (declare (type fixnum n iterations))

51 (let ((grey (- #xFF (min #xFF n))))

52 (+ #xFF000000

53 (* #x010000 grey)

54 (* #x000100 grey)

55 (* #x000001 grey))))

57 (defclass render-control ()

58 ((done-signal :initform (qt:make-signal (find-class 'qt:image)

59 (find-class 'double-float))

60 :reader done-signal

61 :documentation "Signals that an image is ready.")

62 (mutex :initform (sb-thread:make-mutex)

63 :accessor mutex)

64 (stop-p :initform nil)))

66 (defun stop-p (render-control)

67 (sb-thread:with-mutex ((mutex render-control))

68 (slot-value render-control 'stop-p)))

70 (defmacro if-stop-p (render-control then else)

71 `(sb-thread:with-mutex ((mutex ,render-control))

72 (if (slot-value ,render-control 'stop-p)

73 ,then

74 ,else)))

76 (defun (setf stop-p) (new-value control)

77 (sb-thread:with-mutex ((mutex control))

78 (setf (slot-value control 'stop-p)

79 new-value)))

81 ;;;a : x width

82 ;;;b : y height

83 (defun render (center scale width height control)

84 (declare (fixnum width height)

85 (type (complex double-float) center)

86 (double-float scale)

87 (optimize (speed 3)))

88 (let ((image (make-image width height))

89 (top-left (- (/ (complex width height) 2))))

90 (dotimes (pass 1)

91 (let ((iterations 200)) ;(+ (expt 2 (+ (* 2 pass) 6)) 32)))

92 (dotimes (y height)

93 (when (stop-p control)

94 (return))

95 (let ((scanline (cxx:scan-line image y)))

96 (dotimes (x width)

97 (let ((diverge (diverge-p (+ (* scale (+ top-left (make-complex x y))) center) iterations)))

98 (if diverge

99 (setf (cffi:mem-ref scanline :unsigned-int)

100 (div-to-color diverge iterations))

101 (setf (cffi:mem-ref scanline :unsigned-int)

102 #.(qt:q-rgb 0 0 0))))

103 (cffi:incf-pointer scanline

104 (cffi:foreign-type-size :unsigned-int))))))

105 (if-stop-p control

106 (return)

107 (funcall (done-signal control) image scale)))))

108

109 (defun make-render-function (center scale width height done-signal)

110 #'(lambda () (render center scale width height done-signal)))