gtk-glext/gtkglext-drawing-area.lisp

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