3 (register-object-type-implementation "GtkGLDrawingArea" gl-drawing-area "GtkDrawingArea" nil nil)
5 (defclass gl-drawing-area (drawing-area)
6 ((on-expose :initarg :on-expose :initform nil :accessor gl-drawing-area-on-expose)
7 (on-init :initarg :on-init :initform nil :accessor gl-drawing-area-on-init)
8 (on-resize :initarg :on-resize :initform nil :accessor gl-drawing-area-on-resize)
9 (realized-p :initform nil :accessor gl-drawing-area-realized-p))
10 (:metaclass gobject-class)
11 (:g-type-name . "GtkGLDrawingArea"))
13 (defun resize (widget width height)
14 (with-gl-context (widget)
15 (if (gl-drawing-area-on-resize widget)
16 (funcall (gl-drawing-area-on-resize widget) widget width height)
18 (gl:viewport 0 0 width height)
20 ;; set projection to account for aspect
21 (gl:matrix-mode :projection)
23 (glu:perspective 90 (/ width height) 0.5 20) ; 90 degrees field of view y, clip 0.5-20 z
25 ;; set modelview to identity
26 (gl:matrix-mode :modelview)
27 (gl:load-identity)))))
29 (defun gl-drawing-area-configure (widget event)
30 (declare (ignore event))
31 (multiple-value-bind (width height)
32 (gdk:drawable-get-size (widget-window widget))
33 #+nil(format t "configure ~Dx~D~%" width height)
34 (when (gl-drawing-area-realized-p widget)
35 (resize widget width height))))
37 (defun gl-drawing-area-realize (widget)
38 #+nil(format t "realize~%")
39 (bwhen (init-fn (gl-drawing-area-on-init widget))
40 (with-gl-context (widget)
41 (funcall init-fn widget)))
42 (setf (gl-drawing-area-realized-p widget) t)
43 (multiple-value-bind (width height)
44 (gdk:drawable-get-size (widget-window widget))
45 (resize widget width height))
48 (defun gl-drawing-area-unrealize (widget)
49 (setf (gl-drawing-area-realized-p widget) nil)
52 (defun gl-drawing-area-exposed (widget event)
53 (bwhen (draw-fn (gl-drawing-area-on-expose widget))
54 (with-gl-context (widget)
55 (funcall draw-fn widget event)))
58 (defun gl-drawing-area-parent-set (widget event)
59 (declare (ignore event))
60 (unless (gtk-widget-set-gl-capability widget
65 (warn "set gl capability for ~A (with ~A) failed~%" widget *gl-config*)))
67 (defmethod initialize-instance :after ((widget gl-drawing-area) &key &allow-other-keys)
68 (connect-signal widget "realize" #'gl-drawing-area-realize)
69 (connect-signal widget "unrealize" #'gl-drawing-area-unrealize)
70 (connect-signal widget "expose-event" #'gl-drawing-area-exposed)
71 (connect-signal widget "configure-event" #'gl-drawing-area-configure)
72 (connect-signal widget "parent-set" #'gl-drawing-area-parent-set))