From: Dmitry Kalyanov Date: Sat, 17 Oct 2009 00:10:13 +0000 (+0400) Subject: Add integration to cl-cairo2 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ead1d57a689234a3604caddb0903e0bcf6e1fe52;p=cl-gtk2.git Add integration to cl-cairo2 --- diff --git a/cairo/cairo.demo.lisp b/cairo/cairo.demo.lisp new file mode 100644 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 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 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 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 " + :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