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