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