Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv13587/cells-gtk

Modified Files: buttons.lisp cairo-drawing-area.lisp cells-gtk.asd drawing-area.lisp gl-drawing-area.lisp gtk-app.lisp packages.lisp widgets.lisp Log Message: Added OpenGL drawing area

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/14 16:43:41 1.2 @@ -81,7 +81,7 @@

(def-widget radio-button (check-button) () () () - :new-tail (c? (and (upper self box) + :new-tail (c_1 (and (upper self box) (not (eql (first (kids (fm-parent self))) self)) '-from-widget)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/14 16:43:41 1.2 @@ -216,19 +216,6 @@ (deb "done."))

-;;;; ----------------------------------------------------------- -;;;; redraw method (called to trigger a refresh) -;;;; ----------------------------------------------------------- - -;;; a handler if redraw called on nil -(defmethod redraw (self)) - -(defmethod redraw ((self cairo-drawing-area)) - "Queues a redraw with GTK. This is called whenever a primitve is modified" - (trc nil "queue redraw" self) - (gtk-ffi:gtk-widget-queue-draw (widget-id self))) - - (defobserver prims ((self cairo-drawing-area)) (redraw self))

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/14 16:43:42 1.2 @@ -17,7 +17,7 @@ (pushnew :cells-gtk-cairo *features*)

;;; drawing-area widget using OpenGL (requires libgtkglext1) -;(pushnew :cells-gtk-opengl *features*) +(pushnew :cells-gtk-opengl *features*)

(asdf:defsystem :cells-gtk :name "cells-gtk" @@ -27,7 +27,10 @@ :gtk-ffi :ph-maths #+cells-gtk-cairo :cl-cairo2 - #+cells-gtk-threads :bordeaux-threads) + #+cells-gtk-threads :bordeaux-threads + #+cells-gtk-opengl :cl-opengl + #+cells-gtk-opengl :cl-glu + #+cells-gtk-opengl :cl-glut) :serial t :components ((:file "packages") --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/14 16:43:42 1.2 @@ -123,10 +123,26 @@ (declare (ignore rest)) (let ((widget (id self))) (trc "registering handlers for" widget) - (gtk-widget-add-events widget 772) ; 512 + 256 + 4 button_press, release, motion - (gtk-signal-connect-swap widget "button-press-event" (cffi:get-callback 'drawing-button-handler) :data widget) - (gtk-signal-connect-swap widget "button-release-event" (cffi:get-callback 'drawing-button-handler) :data widget) - (gtk-signal-connect-swap widget "motion-notify-event" (cffi:get-callback 'drawing-pointer-motion-handler) :data widget) - (gtk-signal-connect-swap widget "expose-event" (cffi:get-callback 'drawing-expose-handler) :data widget))) + (gtk-widget-add-events widget 772) ; 512 + 256 + 4 button_press, release, motion + (gtk-signal-connect-swap widget "button-press-event" (cffi:get-callback 'drawing-button-handler) :data widget) + (gtk-signal-connect-swap widget "button-release-event" (cffi:get-callback 'drawing-button-handler) :data widget) + (gtk-signal-connect-swap widget "motion-notify-event" (cffi:get-callback 'drawing-pointer-motion-handler) :data widget) + (gtk-signal-connect-swap widget "expose-event" (cffi:get-callback 'drawing-expose-handler) :data widget))) + + +;;; +;;; redraw method (called to trigger a refresh) +;;; + +;;; a handler if redraw called on nil +(export! redraw) + +(defmethod redraw (self)) + +(defmethod redraw ((self drawing-area)) + "Queues a redraw with GTK." + (trc nil "queue redraw" self) + (gtk-widget-queue-draw (id self))) +

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/14 16:43:42 1.2 @@ -2,9 +2,112 @@

(in-package :cgtk)

+(defvar *gl-config* nil) + ;;; ;;; gl drawing area ;;;

+;;; +;;; OpenGL interaction +;;; + +(defun get-gl-config () + (let ((cfg (gdk-gl-config-new-by-mode '(:gdk-gl-mode-rgba :gdk-gl-mode-depth :gdk-gl-mode-double)))) + (if (cffi-sys:null-pointer-p cfg) + (let ((cfg (gdk-gl-config-new-by-mode '(:gdk-gl-mode-rgba :gdk-gl-mode-depth :gdk-gl-mode-double)))) + (warn "No double buffered visual found. Trying single-buffered.") + (if (cffi-sys:null-pointer-p cfg) + (error "No OpenGL capable visual found.") + cfg)) + cfg))) + +(defun gl-init () + (gtk-gl-init +c-null+ +c-null+) + (setf *gl-config* (get-gl-config))) + + +(defmacro with-gl-context ((widget &key (swap-buffers-p t)) &rest body) + (with-gensyms (drawable context swap-p w wid) + `(let ((,swap-p ,swap-buffers-p) + (,w ,widget)) + (let ((,wid (id ,w))) + (let ((,context (gtk-widget-get-gl-context ,wid)) + (,drawable (gtk-widget-get-gl-window ,wid))) + (if (gdk-gl-drawable-gl-begin ,drawable ,context) + (progn + ,@body + (when ,swap-p + (when (gdk-gl-drawable-is-double-buffered ,drawable) + (trc "swapping buffers") + (gdk-gl-drawable-swap-buffers ,drawable))) + (gdk-gl-drawable-gl-end ,drawable)) + (trc "gl-begin failed" ,w ,drawable ,context))))))) + +;;; +;;; Event handling +;;; + +(defun %gl-draw (self) + (bwhen (draw-fn (draw self)) + (with-gl-context (self) + (funcall draw-fn self)))) + +(cffi:defcallback realize-handler :void ((widget :pointer) (data :pointer)) + (declare (ignore data)) + (let ((self (gtk-object-find widget))) + (trc "gl realize" self widget (id self)) + (bwhen (init-fn (init self)) + (with-gl-context (self) + (funcall init-fn self))) + (trc "done gl realize" self))) + + +(defun %resize (self) + (let ((width (allocated-width self)) + (height (allocated-height self))) + (when (and (plusp width) (plusp height)) + (trc "%resize to" width height) + (with-gl-context (self) + (gl:viewport 0 0 width height) + (bwhen (resize-fn (resize self)) + (funcall resize-fn self)))))) + +;;; +;;; Widget +;;; + (defmodel gl-drawing-area (drawing-area) - ()) \ No newline at end of file + ((draw :accessor draw :initarg :draw :cell nil :initform nil) + (init :accessor init :initarg :init :cell nil :initform nil) + (resize :accessor resize :initarg :resize :cell nil :initform nil)) + (:default-initargs + :on-draw #'%gl-draw)) + +(defmethod initialize-instance :after ((self gl-drawing-area) &rest initargs) + (declare (ignore initargs)) + (trc "registering handlers for" self) + (gtk-signal-connect-swap (id self) "realize" (cffi:get-callback 'realize-handler) :data (id self)) + (trc "set gl capability" self) + (gtk-widget-set-gl-capability (id self) *gl-config* +c-null+ t :gdk-gl-rgba-type)) + +(defobserver allocated-width ((self gl-drawing-area)) + (%resize self)) + +(defobserver allocated-height ((self gl-drawing-area)) + (%resize self)) + + +;;; +;;; supporting macros +;;; + +(export! with-matrix-mode) + +(defmacro with-matrix-mode ((mode) &body body) + `(progn + (gl:matrix-mode ,mode) + (gl:load-identity) + ,@body + (gl:matrix-mode :modelview) + (gl:load-identity))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 11:34:24 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/14 16:43:42 1.3 @@ -127,28 +127,6 @@ (with-trc (gtk-quit-remove (slot-value self 'cb-quit-id))))

;;; -;;; callback table -;;; - -(defvar *gtk-global-callbacks* nil) - -(defun gtk-reset () - (cells-reset) - (gtk-objects-init) - (setf *gtk-global-callbacks* - (make-array 128 :adjustable t :fill-pointer 0))) - -(defun gtk-global-callback-register (callback) - (vector-push-extend callback *gtk-global-callbacks* 16)) - -(defun gtk-global-callback-funcall (n) - (trc nil "gtk-global-callback-funcall >" n - *gtk-global-callbacks* - (when n (aref *gtk-global-callbacks* n))) - (funcall (aref *gtk-global-callbacks* n))) - - -;;; ;;; Helper functions convering the life cycle of an application ;;;

@@ -184,6 +162,7 @@ (gdk-threads-init) (assert (gtk-init-check +c-null+ +c-null+)) (gtk-init +c-null+ +c-null+) + #+cells-gtk-opengl (gl-init) (gtk-reset) #-libcellsgtk (setf threading-initialized t)))))

@@ -349,6 +328,5 @@ ('no (error "Cannot mix start-win and start-app in one lisp session. Use start-app or restart lisp")) (t (setf *using-thread* 'yes))) (start-gtk-main) - (apply #'show-win app-class initargs) - 0)) + (apply #'show-win app-class initargs)))

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/14 16:43:42 1.2 @@ -44,11 +44,15 @@ #:cells-tree-node #:cells-tree-store #:cells-gtk-init + #:title #:icon #:tooltips #:tooltips-enable #:tooltips-delay + #:allocated-width + #:allocated-height + #:start-app #:start-win #:stop-gtk-main @@ -142,4 +146,9 @@ #:on-dragged ; (on-dragged [widget] [button] [primitive] [start-pos] [end-pos]) #:hover ; the primitive the mouse is currently over #:dragging ; the primitive currently being dragged + + #:gl-drawing-area + #:with-gl-context + #:init + #:draw )) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/14 16:43:44 1.2 @@ -24,9 +24,9 @@ (def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil) (new-function-name :accessor new-function-name :initarg :new-function-name :initform (c_1 (intern (format nil "GTK-~a-NEW~a" - (def-gtk-class-name self) - (or (new-tail self) "")) - :gtk-ffi))) + (def-gtk-class-name self) + (or (new-tail self) "")) + :gtk-ffi))) (new-args :accessor new-args :initarg :new-args :initform nil) (new-tail :accessor new-tail :initarg :new-tail :initform nil) (id :initarg :id :accessor id @@ -36,6 +36,7 @@ (let ((id (apply (symbol-function (new-function-name self)) (new-args self)))) (gtk-object-store id self) + (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id) id))))

(callbacks :cell nil :accessor callbacks @@ -47,14 +48,19 @@

;; --------- provide id-to-clos lookup ------

-(defvar *gtk-objects* nil) +;;; +;;; gtk object registry +;;;

+(defvar *gtk-objects* nil) (defvar *widgets* nil)

(defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100) *widgets* (make-hash-table :test #'equal)))

+;;; id lookup + (defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) @@ -88,10 +94,11 @@ (gtk-report-error gtk-object-id-error "gtk.object.find ID not found ~a" hash-id)) clos-widget)))

+;;; name lookup + (defun find-widget (name &optional default) (gethash name *widgets* default))

- (defmacro with-widget ((widget name &optional alternative) &body body) `(bif (,widget (find-widget ,name)) (progn ,@body) @@ -104,12 +111,13 @@ (progn ,@body) ,alternative))))

-(defun widget-value (name default &key (accessor 'value)) +(defun widget-value (name &optional default (accessor 'value)) (with-widget-value (val name :accessor accessor :alternative default) val))

- - +;;; +;;; callbacks +;;;

;; ----- fake callbackable closures ------------

@@ -121,8 +129,6 @@ (defun callback-recover (self callback-key) (cdr (assoc callback-key (callbacks self))))

-; ------------------------------------------ - ;;; ;;; callback table ;;; @@ -145,7 +151,6 @@ (funcall (aref *gtk-global-callbacks* n)))

- (defmethod configure ((self gtk-object) gtk-function value) (apply gtk-function (id self) @@ -321,15 +326,36 @@ (x-pad :accessor x-pad :initarg :x-pad :initform (c? (padding? self))) (y-pad :accessor y-pad :initarg :y-pad :initform (c? (padding? self))) (width :accessor width :initarg :width :initform nil) - (height :accessor height :initarg :height :initform nil)) + (height :accessor height :initarg :height :initform nil) + (allocated-width :accessor allocated-width :initform (c-in 0)) + (allocated-height :accessor allocated-height :initform (c-in 0)) + ) () (focus show hide delete-event destroy-event) ;; this is called unless the user overwrites this routine :on-delete-event (c-in #'(lambda (self widget event data) (declare (ignore widget event data)) + (trc "on-delete") (gtk-object-forget (id self) self) 0)))

+#+libcellsgtk +(cffi:defcallback reshape-widget-handler :int ((widget :pointer) (event :pointer) (data :pointer)) + (declare (ignore data event)) + (bwhen (self (gtk-object-find widget)) + (let ((new-width (gtk-adds-widget-width widget)) + (new-height (gtk-adds-widget-height widget))) + (trc "reshape widget to new size" self widget new-width new-height) + (with-integrity (:change :adjust-widget-size) + (setf (allocated-width self) new-width + (allocated-height self) new-height)))) + 0) + +(defmethod initialize-instance :after ((self widget) &rest initargs) + (declare (ignore initargs)) + #+libcellsgtk- + ) + (defmethod focus ((self widget)) (gtk-widget-grab-focus (id self)))