Add integration to cl-cairo2

diff --git a/cairo/cairo.demo.lisp b/cairo/cairo.demo.lisp
new file mode 100644 (file)
index 0000000..6aabad8
--- /dev/null
+++ b/cairo/cairo.demo.lisp
@@ -0,0 +1,199 @@
+(defpackage #:cl-gtk2-cairo-demo
+  (:shadowing-import-from #:cl-cairo2 #:scale)
+  (:use :cl #:gtk #:cl-cairo2 #:cl-gtk2-cairo #:iter)
+  (:export #:demo))
+
+(in-package #:cl-gtk2-cairo-demo)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass cairo-w (drawing-area)
+    ((draw-fn :initform 'draw-clock-face :accessor cairo-w-draw-fn))
+    (:metaclass gobject:gobject-class)))
+
+(defmethod initialize-instance :after ((w cairo-w) &rest initargs)
+  (declare (ignore initargs))
+  (gobject:connect-signal w "configure-event" (lambda (widget event)
+                                                (declare (ignore event))
+                                                (widget-queue-draw widget)))
+  (gobject:connect-signal w "expose-event" (lambda (widget event)
+                                             (declare (ignore event))
+                                             (cc-expose widget))))
+
+(defmethod (setf cairo-w-draw-fn) :after (new-value (w cairo-w))
+  (declare (ignore new-value))
+  (widget-queue-draw w))
+
+(defun cc-expose (widget)
+  (multiple-value-bind (w h) (gdk:drawable-get-size (widget-window widget))
+    (with-gdk-context (ctx (widget-window widget))
+      (with-context (ctx)
+        (funcall (cairo-w-draw-fn widget) w h)
+        nil))))
+
+(defstruct cairo-fn name fn)
+
+(defun starts-with (str prefix)
+  (string= str prefix :end1 (min (length str) (length prefix))))
+
+(defun get-draw-fns ()
+  (iter (for symbol in-package '#:cl-gtk2-cairo-demo)
+        (when (and (fboundp symbol)
+                   (starts-with (symbol-name symbol) "DRAW-"))
+          (for doc = (or (documentation (fdefinition symbol) t) (let ((*print-case* :downcase)) (format nil "~A" symbol))))
+          (collect (make-cairo-fn :name doc :fn symbol)))))
+
+(defun demo ()
+  (within-main-loop
+    (let ((cb-list (make-instance 'array-list-store)))
+      (store-add-column cb-list gobject:+g-type-string+ #'cairo-fn-name)
+      (iter (for fn in (get-draw-fns))
+            (store-add-item cb-list fn))
+      (let-ui (gtk-window
+               :var w
+               :default-width 300
+               :default-height 400
+               :type :toplevel
+               :title "Cairo drawing"
+               (v-box
+                (combo-box :var combo :model cb-list) :expand nil
+                (cairo-w :var cw)))
+        (let ((renderer (make-instance 'cell-renderer-text :text "A text")))
+          (cell-layout-pack-start combo renderer)
+          (cell-layout-add-attribute combo renderer "text" 0))
+        (gobject:connect-signal combo "changed"
+                                (lambda (widget)
+                                  (declare (ignore widget))
+                                  (let ((iter (combo-box-active-iter combo)))
+                                    (when iter
+                                      (setf (cairo-w-draw-fn cw)
+                                            (cairo-fn-fn (tree-model-item cb-list iter)))))))
+        (setf (combo-box-active-iter combo) (tree-model-iter-first cb-list))
+        (widget-show w)))))
+
+(defun draw-clock-face (w h)
+  "Draw a clock face"
+  (set-line-width 1)
+  (translate (/ w 2) (/ h 2))
+  (setf w (- w 2) h (- h 2))
+  (scale (* 0.99 (/ (min w h) 2)) (* 0.99 (/ (min w h) 2)))
+  (set-line-width 0.01)
+
+  ;; Circle
+  (arc 0 0 1 0 (* 2 pi))
+  (set-source-rgb 1 1 1)
+  (fill-preserve)
+  (set-source-rgb 0 0 0)
+  (stroke)
+        
+  ;; Ticks
+  (iter (for i from 0 below 12)
+        (for angle = (/ (* i pi) 6))
+        (for cos = (cos angle))
+        (for sin = (sin angle))
+        (save)
+        (if (zerop (mod i 3))
+            (progn (set-line-width 0.02)
+                   (move-to (* 0.8 cos) (* 0.8 sin)))
+            (move-to (* 0.9 cos) (* 0.9 sin)))
+        (line-to cos sin)
+        (set-source-rgb 0 0 0)
+        (stroke)
+        (restore)))
+
+(defun draw-line (w h)
+  "Draw simple diagonal line"
+  (set-line-width 1)
+  (move-to 0 0)
+  (line-to w h)
+  (set-source-rgb 1 1 1)
+  (stroke))
+
+(defun draw-ex-1 (w h)
+  "White diagonal line on a blue background"
+  (set-source-rgb 0.2 0.2 1)
+  (rectangle 0 0 w h)
+  (fill-path)
+  
+  (move-to w 0)
+  (line-to 0 h)
+  (set-source-rgb 1 1 1)
+  (set-line-width 5)
+  (stroke))
+
+(defun draw-text (w h)
+  "Very simple text example"
+  (declare (ignore w h))
+  (move-to 0 100)
+  (set-font-size 50)
+  (show-text "foo. Привет мир!"))
+
+(defparameter *lis-a* 9)
+(defparameter *lis-b* 8)
+(defparameter *lis-delta* (/ pi 2))
+(defparameter *lis-density* 2000)
+(defparameter *lis-margin* 10)
+
+(defun draw-lissajou (w h)
+  "Draw Lissajous curve"
+  (rectangle 0 0 w h)
+  (set-source-rgb 0.9 0.9 1)
+  (fill-path)
+  
+  (labels ((stretch (s x)
+             (+ (* (1+ x)
+                   (- (/ s 2)
+                      *lis-margin*))
+                *lis-margin*)))
+    (move-to (stretch w (sin *lis-delta*)) (stretch h 0))
+    (dotimes (i *lis-density*)
+      (let* ((v (/ (* i pi 2) *lis-density*))
+             (x (sin (+ (* *lis-a* v) *lis-delta*)))
+             (y (sin (* *lis-b* v))))
+        (line-to (stretch w x) (stretch h y)))))
+  (close-path)
+  (set-line-width 0.5)
+  (set-source-rgb 0 0 1)
+  (stroke))
+
+(defun heart (alpha)
+  "Draw a heart with fixed size and the given transparency alpha.
+  Heart is upside down."
+  (let ((radius (sqrt 0.5)))
+    (move-to 0 -2)
+    (line-to 1 -1)
+    (arc 0.5 -0.5 radius (deg-to-rad -45) (deg-to-rad 135))
+    (arc -0.5 -0.5 radius (deg-to-rad 45) (deg-to-rad 215))
+    (close-path)
+    (set-source-rgba 1 0 0 alpha)
+    (fill-path)))
+
+(defvar *heart-max-angle* 40d0)
+
+(defun draw-heart (w h)
+  "Draw a lot of hearts"
+  (rectangle 0 0 w h)
+  (set-source-rgb 1 1 1)
+  (fill-path)
+
+  (dotimes (i 200)
+    (let ((scaling (+ 5d0 (random 40d0))))
+      (reset-trans-matrix)              ; reset matrix
+      (translate (random w) (random h)) ; move the origin
+      (scale scaling scaling)           ; scale
+      (rotate (deg-to-rad (- (random (* 2 *heart-max-angle*))
+                             *heart-max-angle* 180))) ; rotate
+      (heart (+ 0.1 (random 0.7))))))
+
+(defun draw-gradient (w h)
+  "Draw a gradient"
+  (with-linear-pattern rainbow (0 0 w h)
+      `((0 (0.7 0 0.7 0))               ;rgb(a) color as list
+        (1/6 ,cl-colors:+blue+)         ;color as cl-color
+        (2/6 ,cl-colors:+green+)
+        (3/6 ,cl-colors:+yellow+)
+        (4/6 ,cl-colors:+orange+)
+        (5/6 ,cl-colors:+red+)
+        (1 ,cl-colors:+violetred+))
+    (rectangle 0 0 w h)
+    (set-source rainbow)
+    (fill-path)))

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
new file mode 100644 (file)
index 0000000..7830d18
--- /dev/null
+++ b/cairo/cairo.lisp
@@ -0,0 +1,30 @@
+(in-package #:cl-gtk2-cairo)
+
+(defcfun gdk-cairo-create :pointer (drawable (g-object drawable)))
+
+(defclass gdk-context (cl-cairo2:context)
+  ())
+                          
+(defun create-gdk-context (gdk-drawable)
+  "creates an context to draw on a GTK widget, more precisely on the
+associated gdk-window.  This should only be called from within the
+expose event.  In cells-gtk, use (gtk-adds-widget-window gtk-pointer)
+to obtain the gdk-window. 'gtk-pointer' is the pointer parameter
+passed to the expose event handler."
+  (make-instance 'gdk-context
+                 :pointer (gdk-cairo-create gdk-drawable)))
+
+(defmethod cl-cairo2:destroy ((self gdk-context))
+  (cl-cairo2::cairo_destroy (slot-value self 'cl-cairo2:pointer)))
+
+(defmacro with-gdk-context ((context gdk-drawable) &body body)
+  "Executes body while context is bound to a valid cairo context for
+gdk-window.  This should only be called from within an expose event
+handler.  In cells-gtk, use (gtk-adds-widget-window gtk-pointer) to
+obtain the gdk-window. 'gtk-pointer' is the pointer parameter passed
+to the expose event handler."
+  (cl-utilities:with-gensyms (context-pointer)
+    `(let ((,context (create-gdk-context ,gdk-drawable)))
+       (cl-cairo2::with-context-pointer (,context ,context-pointer)
+         ,@body)
+       (cl-cairo2:destroy ,context))))

diff --git a/cairo/cairo.package.lisp b/cairo/cairo.package.lisp
new file mode 100644 (file)
index 0000000..eb08246
--- /dev/null
+++ b/cairo/cairo.package.lisp
@@ -0,0 +1,5 @@
+(defpackage #:cl-gtk2-cairo
+  (:use #:cl #:gdk #:cffi #:gobject)
+  (:export #:gdk-context
+           #:create-gdk-context
+           #:with-gdk-context))

diff --git a/cairo/cl-gtk2-cairo.asd b/cairo/cl-gtk2-cairo.asd
new file mode 100644 (file)
index 0000000..cfddeb9
--- /dev/null
+++ b/cairo/cl-gtk2-cairo.asd
@@ -0,0 +1,9 @@
+(defsystem :cl-gtk2-cairo
+  :name :cl-gtk2-cairo
+  :author "Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>"
+  :license "LLGPL"
+  :serial t
+  :components ((:file "cairo.package")
+               (:file "cairo")
+               (:file "cairo.demo"))
+  :depends-on (:cl-gtk2-glib :cffi :cl-gtk2-gdk :cl-gtk2-gtk :iterate :cl-cairo2))
\ No newline at end of file