Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 125 lines (98 sloc) 3.403 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
 

(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+)
  (glut:init)
  (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)

;; set projection to account for aspect
(gl:matrix-mode :projection)
(gl:load-identity)
(glu:perspective 90 (/ width height) 0.5 20) ; 90 degrees field of view y, clip 0.5-20 z
   
;; set modelview to identity
(gl:matrix-mode :modelview)
(gl:load-identity)

(bwhen (resize-fn (resize self))
(funcall resize-fn self))))))

;;;
;;; Widget
;;;

(defmodel gl-drawing-area (drawing-area)
  ((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)))
Something went wrong with that request. Please try again.