Version bump to 0.1
[cl-gtk2.git] / cairo / cairo.demo.lisp
1 (defpackage #:cl-gtk2-cairo-demo
2   (:shadowing-import-from #:cl-cairo2 #:scale)
3   (:use :cl #:gtk #:cl-cairo2 #:cl-gtk2-cairo #:iter)
4   (:export #:demo))
5
6 (in-package #:cl-gtk2-cairo-demo)
7
8 (eval-when (:compile-toplevel :load-toplevel :execute)
9   (defclass cairo-w (drawing-area)
10     ((draw-fn :initform 'draw-clock-face :accessor cairo-w-draw-fn))
11     (:metaclass gobject:gobject-class)))
12
13 (defmethod initialize-instance :after ((w cairo-w) &rest initargs)
14   (declare (ignore initargs))
15   (gobject:connect-signal w "configure-event" (lambda (widget event)
16                                                 (declare (ignore event))
17                                                 (widget-queue-draw widget)))
18   (gobject:connect-signal w "expose-event" (lambda (widget event)
19                                              (declare (ignore event))
20                                              (cc-expose widget))))
21
22 (defmethod (setf cairo-w-draw-fn) :after (new-value (w cairo-w))
23   (declare (ignore new-value))
24   (widget-queue-draw w))
25
26 (defun cc-expose (widget)
27   (multiple-value-bind (w h) (gdk:drawable-get-size (widget-window widget))
28     (with-gdk-context (ctx (widget-window widget))
29       (with-context (ctx)
30         (funcall (cairo-w-draw-fn widget) w h)
31         nil))))
32
33 (defstruct cairo-fn name fn)
34
35 (defun starts-with (str prefix)
36   (string= str prefix :end1 (min (length str) (length prefix))))
37
38 (defun get-draw-fns ()
39   (iter (for symbol in-package '#:cl-gtk2-cairo-demo)
40         (when (and (fboundp symbol)
41                    (starts-with (symbol-name symbol) "DRAW-"))
42           (for doc = (or (documentation (fdefinition symbol) t) (let ((*print-case* :downcase)) (format nil "~A" symbol))))
43           (collect (make-cairo-fn :name doc :fn symbol)))))
44
45 (defun demo ()
46   (within-main-loop
47     (let ((cb-list (make-instance 'array-list-store)))
48       (store-add-column cb-list gobject:+g-type-string+ #'cairo-fn-name)
49       (iter (for fn in (get-draw-fns))
50             (store-add-item cb-list fn))
51       (let-ui (gtk-window
52                :var w
53                :default-width 300
54                :default-height 400
55                :type :toplevel
56                :title "Cairo drawing"
57                (v-box
58                 (combo-box :var combo :model cb-list) :expand nil
59                 (cairo-w :var cw)))
60         (let ((renderer (make-instance 'cell-renderer-text :text "A text")))
61           (cell-layout-pack-start combo renderer)
62           (cell-layout-add-attribute combo renderer "text" 0))
63         (gobject:connect-signal combo "changed"
64                                 (lambda (widget)
65                                   (declare (ignore widget))
66                                   (let ((iter (combo-box-active-iter combo)))
67                                     (when iter
68                                       (setf (cairo-w-draw-fn cw)
69                                             (cairo-fn-fn (tree-model-item cb-list iter)))))))
70         (setf (combo-box-active-iter combo) (tree-model-iter-first cb-list))
71         (widget-show w)))))
72
73 (defun draw-clock-face (w h)
74   "Draw a clock face"
75   (set-line-width 1)
76   (translate (/ w 2) (/ h 2))
77   (setf w (- w 2) h (- h 2))
78   (scale (* 0.99 (/ (min w h) 2)) (* 0.99 (/ (min w h) 2)))
79   (set-line-width 0.01)
80
81   ;; Circle
82   (arc 0 0 1 0 (* 2 pi))
83   (set-source-rgb 1 1 1)
84   (fill-preserve)
85   (set-source-rgb 0 0 0)
86   (stroke)
87         
88   ;; Ticks
89   (iter (for i from 0 below 12)
90         (for angle = (/ (* i pi) 6))
91         (for cos = (cos angle))
92         (for sin = (sin angle))
93         (save)
94         (if (zerop (mod i 3))
95             (progn (set-line-width 0.02)
96                    (move-to (* 0.8 cos) (* 0.8 sin)))
97             (move-to (* 0.9 cos) (* 0.9 sin)))
98         (line-to cos sin)
99         (set-source-rgb 0 0 0)
100         (stroke)
101         (restore)))
102
103 (defun draw-line (w h)
104   "Draw simple diagonal line"
105   (set-line-width 1)
106   (move-to 0 0)
107   (line-to w h)
108   (set-source-rgb 1 1 1)
109   (stroke))
110
111 (defun draw-ex-1 (w h)
112   "White diagonal line on a blue background"
113   (set-source-rgb 0.2 0.2 1)
114   (rectangle 0 0 w h)
115   (fill-path)
116   
117   (move-to w 0)
118   (line-to 0 h)
119   (set-source-rgb 1 1 1)
120   (set-line-width 5)
121   (stroke))
122
123 (defun draw-text (w h)
124   "Very simple text example"
125   (declare (ignore w h))
126   (move-to 0 100)
127   (set-font-size 50)
128   (show-text "foo. Привет мир!"))
129
130 (defparameter *lis-a* 9)
131 (defparameter *lis-b* 8)
132 (defparameter *lis-delta* (/ pi 2))
133 (defparameter *lis-density* 2000)
134 (defparameter *lis-margin* 10)
135
136 (defun draw-lissajou (w h)
137   "Draw Lissajous curve"
138   (rectangle 0 0 w h)
139   (set-source-rgb 0.9 0.9 1)
140   (fill-path)
141   
142   (labels ((stretch (s x)
143              (+ (* (1+ x)
144                    (- (/ s 2)
145                       *lis-margin*))
146                 *lis-margin*)))
147     (move-to (stretch w (sin *lis-delta*)) (stretch h 0))
148     (dotimes (i *lis-density*)
149       (let* ((v (/ (* i pi 2) *lis-density*))
150              (x (sin (+ (* *lis-a* v) *lis-delta*)))
151              (y (sin (* *lis-b* v))))
152         (line-to (stretch w x) (stretch h y)))))
153   (close-path)
154   (set-line-width 0.5)
155   (set-source-rgb 0 0 1)
156   (stroke))
157
158 (defun heart (alpha)
159   "Draw a heart with fixed size and the given transparency alpha.
160   Heart is upside down."
161   (let ((radius (sqrt 0.5)))
162     (move-to 0 -2)
163     (line-to 1 -1)
164     (arc 0.5 -0.5 radius (deg-to-rad -45) (deg-to-rad 135))
165     (arc -0.5 -0.5 radius (deg-to-rad 45) (deg-to-rad 215))
166     (close-path)
167     (set-source-rgba 1 0 0 alpha)
168     (fill-path)))
169
170 (defvar *heart-max-angle* 40d0)
171
172 (defun draw-heart (w h)
173   "Draw a lot of hearts"
174   (rectangle 0 0 w h)
175   (set-source-rgb 1 1 1)
176   (fill-path)
177
178   (dotimes (i 200)
179     (let ((scaling (+ 5d0 (random 40d0))))
180       (reset-trans-matrix)              ; reset matrix
181       (translate (random w) (random h)) ; move the origin
182       (scale scaling scaling)           ; scale
183       (rotate (deg-to-rad (- (random (* 2 *heart-max-angle*))
184                              *heart-max-angle* 180))) ; rotate
185       (heart (+ 0.1 (random 0.7))))))
186
187 (defun draw-gradient (w h)
188   "Draw a gradient"
189   (with-linear-pattern rainbow (0 0 w h)
190       `((0 (0.7 0 0.7 0))               ;rgb(a) color as list
191         (1/6 ,cl-colors:+blue+)         ;color as cl-color
192         (2/6 ,cl-colors:+green+)
193         (3/6 ,cl-colors:+yellow+)
194         (4/6 ,cl-colors:+orange+)
195         (5/6 ,cl-colors:+red+)
196         (1 ,cl-colors:+violetred+))
197     (rectangle 0 0 w h)
198     (set-source rainbow)
199     (fill-path)))