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)))