gtk-glext/gtkglext-drawing-area.lisp

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