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