gtk-glext/demo.lisp

   1 (defpackage :gtk-glext-demo
   2   (:use :cl :gtk :gtkglext :gobject :glib :iter)
   3   (:export :run
   4            #:planet
   5            #:opengl-interactive))
   6
   7 (in-package :gtk-glext-demo)
   8
   9 (defvar *theta* 30)
  10
  11 (defun draw (widget event)
  12   (declare (ignore widget event))
  13   (gl:clear-color 0 0 0 0)
  14   (gl:cull-face :back)
  15   (gl:depth-func :less)
  16   (gl:disable :dither)
  17   (gl:shade-model :smooth)
  18   (gl:light-model :light-model-local-viewer 1)
  19   (gl:color-material :front :ambient-and-diffuse)
  20   (gl:enable :light0 :lighting :cull-face :depth-test)
  21   (gl:load-identity)
  22   (gl:translate 0 0 -5)
  23   (gl:rotate *theta* 1 1 0)
  24   (gl:light :light0 :position '(0 1 1 0))
  25   (gl:light :light0 :diffuse '(0.2 0.4 0.6 0))
  26   (gl:clear :color-buffer-bit :depth-buffer-bit)
  27   (gl:color 1 1 1)
  28   (gl:front-face :cw)
  29   (glut:solid-teapot 1.5)
  30   (gl:front-face :ccw)
  31   (gl:flush))
  32
  33 (defun run ()
  34   (with-main-loop
  35     (setf *theta* 30)
  36     (let ((window (make-instance 'gtk-window
  37                                  :type :toplevel
  38                                  :window-position :center
  39                                  :title "Hello world!"
  40                                  :default-width 320
  41                                  :default-height 240))
  42           (v-box (make-instance 'v-box))
  43           (label (make-instance 'label :label "Click me!"))
  44           (drawing (make-instance 'gl-drawing-area :on-expose #'draw)))
  45       (box-pack-start v-box drawing)
  46       (box-pack-start v-box label :expand nil)
  47       (container-add window v-box)
  48       (let ((source-id (gtk-main-add-timeout 100 (lambda ()
  49                                                   (setf *theta*
  50                                                         (mod (+ *theta* 0.5) 360))
  51                                                   (widget-queue-draw drawing)
  52                                                   (setf (label-label label)
  53                                                         (format nil "Theta = ~A" *theta*))
  54                                                   t))))
  55         (connect-signal window "delete-event" (lambda (w e)
  56                                                 (declare (ignore w e))
  57                                                 (g-source-remove source-id)
  58                                                 nil)))
  59       (widget-show window :all t))))
  60
  61 (defvar *d* 0)
  62 (defvar *y* 0)
  63
  64 (defun planet ()
  65   (with-main-loop
  66     (setf *d* 0 *y* 0)
  67     (let ((window (make-instance 'gtk-window
  68                                  :window-position :center
  69                                  :title "Planets"
  70                                  :default-width 500
  71                                  :default-height 500))
  72           (area (make-instance 'gl-drawing-area :on-expose #'planet-draw :on-resize #'planet-resize)))
  73       (container-add window area)
  74       (pushnew :key-press-mask (gdk:gdk-window-events (widget-window window)))
  75       (connect-signal window "key-press-event"
  76                       (lambda (w e)
  77                         (declare (ignore w))
  78                         (ignore-errors
  79                           (let ((c (aref (gdk:event-key-string e) 0)))
  80                             (case c
  81                               (#\d (incf *d* 10) (widget-queue-draw area))
  82                               (#\D (incf *d* -10) (widget-queue-draw area))
  83                               (#\y (incf *y* 5) (widget-queue-draw area))
  84                               (#\Y (incf *y* -5) (widget-queue-draw area)))))
  85                         nil))
  86       (let ((timer-id (gtk-main-add-timeout 10 (lambda ()
  87                                                   (incf *d* 1) (incf *y* 0.5)
  88                                                   (widget-queue-draw area)
  89                                                   t))))
  90         (connect-signal window "delete-event" (lambda (w e)
  91                                                 (declare (ignore w e))
  92                                                 (g-source-remove timer-id)
  93                                                 nil)))
  94       (widget-show window))))
  95
  96 (defun planet-draw (w e)
  97   (declare (ignore w e))
  98   (gl:clear-color 0 0 0 0)
  99   (gl:shade-model :flat)
 100   (gl:clear :color-buffer)
 101   (gl:color 1 1 1)
 102   (gl:with-pushed-matrix
 103     ;; draw sun
 104     (gl:translate 0 0 -2)
 105     (gl:rotate 30 1 1 0)
 106     (glut:wire-sphere 1 20 16)
 107     ;; draw smaller planet
 108     (gl:rotate *y* 0 1 0)
 109     (gl:translate 2 0 0)
 110     (gl:rotate *d* 0 1 0)
 111     (glut:wire-sphere 0.2 10 8))
 112   (gl:flush))
 113
 114 (defun planet-resize (w width height)
 115   (declare (ignore w))
 116   (gl:viewport 0 0 width height)
 117   (gl:matrix-mode :projection)
 118   (gl:load-identity)
 119   (glu:perspective 60 (/ width height) 1 20)
 120   (gl:matrix-mode :modelview)
 121   (gl:load-identity)
 122   (glu:look-at 0 0 5 0 0 0 0 1 0))
 123
 124 (defclass opengl-window (gtk-window)
 125   ((expose-fn-text-view :initform (make-instance 'text-view) :reader opengl-window-expose-fn-text-view)
 126    (resize-fn-text-view :initform (make-instance 'text-view) :reader opengl-window-resize-fn-text-view)
 127    (expose-fn :initform nil :accessor opengl-window-expose-fn)
 128    (resize-fn :initform nil :accessor opengl-window-resize-fn)
 129    (drawing-area :initform (make-instance 'gl-drawing-area :height-request 100) :reader opengl-window-drawing-area))
 130   (:metaclass gobject-class)
 131   (:default-initargs
 132       :title "Lisp interactive OpenGL"
 133     :default-width 500
 134     :default-height 500
 135     :window-position :center))
 136
 137 (defmethod initialize-instance :after ((window opengl-window) &key &allow-other-keys)
 138   (setf (text-buffer-text (text-view-buffer (opengl-window-expose-fn-text-view window)))
 139         ";; Expose-fn
 140 "
 141         (text-buffer-text (text-view-buffer (opengl-window-resize-fn-text-view window)))
 142         ";; Resize-fn. Parameters: w h
 143 ")
 144   (let-ui (v-paned :var v
 145                    (:expr (opengl-window-drawing-area window))
 146                    :resize t :shrink nil
 147                    (v-box
 148                     (h-paned
 149                      (scrolled-window
 150                       :hscrollbar-policy :automatic
 151                       :vscrollbar-policy :automatic
 152                       (:expr (opengl-window-expose-fn-text-view window)))
 153                      :resize t :shrink nil
 154                      (scrolled-window
 155                       :hscrollbar-policy :automatic
 156                       :vscrollbar-policy :automatic
 157                       (:expr (opengl-window-resize-fn-text-view window)))
 158                      :resize t :shrink nil)
 159                     (h-box
 160                      (button :label "Update functions" :var update-fns-button) :expand nil
 161                      (button :label "Redraw" :var redraw-button) :expand nil)
 162                     :expand nil)
 163                    :resize t :shrink nil)
 164     (container-add window v)
 165     (connect-signal update-fns-button "clicked"
 166                     (lambda (b)
 167                       (declare (ignore b))
 168                       (update-fns window)))
 169     (connect-signal redraw-button "clicked"
 170                     (lambda (b)
 171                       (declare (ignore b))
 172                       (widget-queue-draw (opengl-window-drawing-area window))))
 173     (let ((area (opengl-window-drawing-area window)))
 174       (setf (gl-drawing-area-on-expose area)
 175             (lambda (w e)
 176               (declare (ignore w e))
 177               (opengl-interactive-on-expose window))
 178             (gl-drawing-area-on-resize area)
 179             (lambda (widget w h)
 180               (declare (ignore widget))
 181               (opengl-interactive-on-resize window w h))))))
 182
 183 (defun opengl-interactive-on-expose (window)
 184   (if (opengl-window-expose-fn window)
 185       (handler-case
 186           (funcall (opengl-window-expose-fn window))
 187         (error (e)
 188           (declare (ignore e))
 189           (setf (opengl-window-expose-fn window) nil)
 190           (progn (gl:clear-color 0 0 0 0)
 191              (gl:cull-face :back)
 192              (gl:depth-func :less)
 193              (gl:disable :dither)
 194              (gl:shade-model :smooth)
 195              (gl:light-model :light-model-local-viewer 1)
 196              (gl:color-material :front :ambient-and-diffuse)
 197              (gl:enable :light0 :lighting :cull-face :depth-test)
 198              (gl:load-identity)
 199              (gl:translate 0 0 -5)
 200              (gl:rotate *theta* 1 1 0)
 201              (gl:light :light0 :position '(0 1 1 0))
 202              (gl:light :light0 :diffuse '(0.2 0.4 0.6 0))
 203              (gl:clear :color-buffer-bit :depth-buffer-bit)
 204              (gl:color 1 1 1)
 205              (gl:front-face :cw)
 206              (glut:solid-teapot 1.5)
 207              (gl:front-face :ccw)
 208              (gl:flush))))
 209       (progn (gl:clear-color 0 0 0 0)
 210              (gl:cull-face :back)
 211              (gl:depth-func :less)
 212              (gl:disable :dither)
 213              (gl:shade-model :smooth)
 214              (gl:light-model :light-model-local-viewer 1)
 215              (gl:color-material :front :ambient-and-diffuse)
 216              (gl:enable :light0 :lighting :cull-face :depth-test)
 217              (gl:load-identity)
 218              (gl:translate 0 0 -5)
 219              (gl:rotate *theta* 1 1 0)
 220              (gl:light :light0 :position '(0 1 1 0))
 221              (gl:light :light0 :diffuse '(0.2 0.4 0.6 0))
 222              (gl:clear :color-buffer-bit :depth-buffer-bit)
 223              (gl:color 1 1 1)
 224              (gl:front-face :cw)
 225              (glut:solid-teapot 1.5)
 226              (gl:front-face :ccw)
 227              (gl:flush))))
 228
 229 (defun opengl-interactive-on-resize (window w h)
 230   (if (opengl-window-resize-fn window)
 231       (handler-case
 232           (funcall (opengl-window-resize-fn window) w h)
 233         (error (e)
 234           (declare (ignore e))
 235           (setf (opengl-window-resize-fn window) nil)
 236           (gl:viewport 0 0 w h)
 237           (gl:matrix-mode :projection)
 238           (gl:load-identity)
 239           (glu:perspective 60 (/ w h) 1 20)
 240           (gl:matrix-mode :modelview)
 241           (gl:load-identity)))
 242       (progn
 243         (gl:viewport 0 0 w h)
 244         (gl:matrix-mode :projection)
 245         (gl:load-identity)
 246         (glu:perspective 60 (/ w h) 1 20)
 247         (gl:matrix-mode :modelview)
 248         (gl:load-identity)
 249         #+nil(glu:look-at 0 0 5 0 0 0 0 1 0)
 250         )))
 251
 252 (defpackage :cl-gtk2-gl-demo-read-package
 253   (:use :cl :cl-opengl))
 254
 255 (defun read-exprs (string)
 256   (with-input-from-string
 257       (stream string)
 258     (let ((eof (gensym)))
 259       (iter (for expr = (read stream nil eof))
 260                         (until (eq expr eof))
 261                         (collect expr)))))
 262
 263 (defun read-fn (string fn-args)
 264   (let ((*package* (find-package :cl-gtk2-gl-demo-read-package)))
 265     (let ((exprs (read-exprs string)))
 266       (when exprs
 267         (eval `(lambda (,@fn-args)
 268                  ,@exprs))))))
 269
 270 (defparameter *resize-fn-args* (list (intern "W" :cl-gtk2-gl-demo-read-package)
 271                                      (intern "H" :cl-gtk2-gl-demo-read-package)))
 272
 273 (defun update-fns (window)
 274   (with-gtk-message-error-handler
 275     (let ((expose-fn (read-fn (text-buffer-text (text-view-buffer (opengl-window-expose-fn-text-view window))) nil))
 276           (resize-fn (read-fn (text-buffer-text (text-view-buffer (opengl-window-resize-fn-text-view window)))
 277                               *resize-fn-args*)))
 278       (assert (or (null expose-fn) (functionp expose-fn)))
 279       (assert (or (null resize-fn) (functionp resize-fn)))
 280       (setf (opengl-window-expose-fn window) expose-fn
 281             (opengl-window-resize-fn window) resize-fn)
 282       (widget-queue-draw (opengl-window-drawing-area window)))))
 283
 284 (defun opengl-interactive ()
 285   (let ((output *standard-output*))
 286     (within-main-loop
 287       (setf *standard-output* output)
 288       (let ((w (make-instance 'opengl-window)))
 289         (widget-show w)))))