From 36df86bab7a9566edc11c0f5b20650c739dfa68e Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sat, 19 Sep 2009 17:25:57 +0400 Subject: [PATCH] Add opengl-interactive demo --- gtk-glext/demo.lisp | 174 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 172 insertions(+), 2 deletions(-) diff --git a/gtk-glext/demo.lisp b/gtk-glext/demo.lisp index 87eb476..ed1cd6d 100644 --- a/gtk-glext/demo.lisp +++ b/gtk-glext/demo.lisp @@ -1,7 +1,8 @@ (defpackage :gtk-glext-demo - (:use :cl :gtk :gtkglext :gobject :glib) + (:use :cl :gtk :gtkglext :gobject :glib :iter) (:export :run - #:planet)) + #:planet + #:opengl-interactive)) (in-package :gtk-glext-demo) @@ -119,3 +120,172 @@ (gl:matrix-mode :modelview) (gl:load-identity) (glu:look-at 0 0 5 0 0 0 0 1 0)) + +(defclass opengl-window (gtk-window) + ((expose-fn-text-view :initform (make-instance 'text-view) :reader opengl-window-expose-fn-text-view) + (resize-fn-text-view :initform (make-instance 'text-view) :reader opengl-window-resize-fn-text-view) + (expose-fn :initform nil :accessor opengl-window-expose-fn) + (resize-fn :initform nil :accessor opengl-window-resize-fn) + (drawing-area :initform (make-instance 'gl-drawing-area :height-request 100) :reader opengl-window-drawing-area)) + (:metaclass gobject-class) + (:default-initargs + :title "Lisp interactive OpenGL" + :default-width 500 + :default-height 500 + :window-position :center)) + +(defmethod initialize-instance :after ((window opengl-window) &key &allow-other-keys) + (setf (text-buffer-text (text-view-buffer (opengl-window-expose-fn-text-view window))) + ";; Expose-fn +" + (text-buffer-text (text-view-buffer (opengl-window-resize-fn-text-view window))) + ";; Resize-fn. Parameters: w h +") + (let ((v (make-instance 'v-paned)) + (lower-v-box (make-instance 'v-box)) + (h (make-instance 'h-paned)) + (buttons (make-instance 'h-box)) + (update-fns-button (make-instance 'button :label "Update functions")) + (redraw-button (make-instance 'button :label "Redraw"))) + (container-add window v) + (paned-pack-1 v (opengl-window-drawing-area window) :resize t :shrink nil) + (paned-pack-2 v lower-v-box :resize t :shrink nil) + (box-pack-start lower-v-box h) + (let ((scrolled (make-instance 'scrolled-window + :hscrollbar-policy :automatic + :vscrollbar-policy :automatic))) + (container-add scrolled (opengl-window-expose-fn-text-view window)) + (paned-pack-1 h scrolled :resize t :shrink nil)) + (let ((scrolled (make-instance 'scrolled-window + :hscrollbar-policy :automatic + :vscrollbar-policy :automatic))) + (container-add scrolled (opengl-window-resize-fn-text-view window)) + (paned-pack-2 h scrolled :resize t :shrink nil)) + (box-pack-start lower-v-box buttons :expand nil) + (box-pack-start buttons update-fns-button :expand nil) + (box-pack-start buttons redraw-button :expand nil) + (connect-signal update-fns-button "clicked" + (lambda (b) + (declare (ignore b)) + (update-fns window))) + (connect-signal redraw-button "clicked" + (lambda (b) + (declare (ignore b)) + (widget-queue-draw (opengl-window-drawing-area window)))) + (let ((area (opengl-window-drawing-area window))) + (setf (gl-drawing-area-on-expose area) + (lambda (w e) + (declare (ignore w e)) + (opengl-interactive-on-expose window)) + (gl-drawing-area-on-resize area) + (lambda (widget w h) + (declare (ignore widget)) + (opengl-interactive-on-resize window w h)))))) + +(defun opengl-interactive-on-expose (window) + (if (opengl-window-expose-fn window) + (handler-case + (funcall (opengl-window-expose-fn window)) + (error (e) + (declare (ignore e)) + (setf (opengl-window-expose-fn window) nil) + (progn (gl:clear-color 0 0 0 0) + (gl:cull-face :back) + (gl:depth-func :less) + (gl:disable :dither) + (gl:shade-model :smooth) + (gl:light-model :light-model-local-viewer 1) + (gl:color-material :front :ambient-and-diffuse) + (gl:enable :light0 :lighting :cull-face :depth-test) + (gl:load-identity) + (gl:translate 0 0 -5) + (gl:rotate *theta* 1 1 0) + (gl:light :light0 :position '(0 1 1 0)) + (gl:light :light0 :diffuse '(0.2 0.4 0.6 0)) + (gl:clear :color-buffer-bit :depth-buffer-bit) + (gl:color 1 1 1) + (gl:front-face :cw) + (glut:solid-teapot 1.5) + (gl:front-face :ccw) + (gl:flush)))) + (progn (gl:clear-color 0 0 0 0) + (gl:cull-face :back) + (gl:depth-func :less) + (gl:disable :dither) + (gl:shade-model :smooth) + (gl:light-model :light-model-local-viewer 1) + (gl:color-material :front :ambient-and-diffuse) + (gl:enable :light0 :lighting :cull-face :depth-test) + (gl:load-identity) + (gl:translate 0 0 -5) + (gl:rotate *theta* 1 1 0) + (gl:light :light0 :position '(0 1 1 0)) + (gl:light :light0 :diffuse '(0.2 0.4 0.6 0)) + (gl:clear :color-buffer-bit :depth-buffer-bit) + (gl:color 1 1 1) + (gl:front-face :cw) + (glut:solid-teapot 1.5) + (gl:front-face :ccw) + (gl:flush)))) + +(defun opengl-interactive-on-resize (window w h) + (if (opengl-window-resize-fn window) + (handler-case + (funcall (opengl-window-resize-fn window) w h) + (error (e) + (declare (ignore e)) + (setf (opengl-window-resize-fn window) nil) + (gl:viewport 0 0 w h) + (gl:matrix-mode :projection) + (gl:load-identity) + (glu:perspective 60 (/ w h) 1 20) + (gl:matrix-mode :modelview) + (gl:load-identity))) + (progn + (gl:viewport 0 0 w h) + (gl:matrix-mode :projection) + (gl:load-identity) + (glu:perspective 60 (/ w h) 1 20) + (gl:matrix-mode :modelview) + (gl:load-identity) + #+nil(glu:look-at 0 0 5 0 0 0 0 1 0) + ))) + +(defpackage :cl-gtk2-gl-demo-read-package + (:use :cl :cl-opengl)) + +(defun read-exprs (string) + (with-input-from-string + (stream string) + (let ((eof (gensym))) + (iter (for expr = (read stream nil eof)) + (until (eq expr eof)) + (collect expr))))) + +(defun read-fn (string fn-args) + (let ((*package* (find-package :cl-gtk2-gl-demo-read-package))) + (let ((exprs (read-exprs string))) + (when exprs + (eval `(lambda (,@fn-args) + ,@exprs)))))) + +(defparameter *resize-fn-args* (list (intern "W" :cl-gtk2-gl-demo-read-package) + (intern "H" :cl-gtk2-gl-demo-read-package))) + +(defun update-fns (window) + (with-gtk-message-error-handler + (let ((expose-fn (read-fn (text-buffer-text (text-view-buffer (opengl-window-expose-fn-text-view window))) nil)) + (resize-fn (read-fn (text-buffer-text (text-view-buffer (opengl-window-resize-fn-text-view window))) + *resize-fn-args*))) + (assert (or (null expose-fn) (functionp expose-fn))) + (assert (or (null resize-fn) (functionp resize-fn))) + (setf (opengl-window-expose-fn window) expose-fn + (opengl-window-resize-fn window) resize-fn) + (widget-queue-draw (opengl-window-drawing-area window))))) + +(defun opengl-interactive () + (let ((output *standard-output*)) + (within-main-loop + (setf *standard-output* output) + (let ((w (make-instance 'opengl-window))) + (widget-show w))))) -- 1.7.10.4