Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv13558/cello
Modified Files: cello-ftgl.lisp image.lisp ix-render.lisp ix-styled.lisp ix-text.lisp mouse-click.lisp slider.lisp window-callbacks.lisp window.lisp Log Message: Resolve problems with FTGL. Texture fonts will require upcoming fix in FTGL 2.1 currently in testing Date: Wed Sep 29 04:50:09 2004 Author: ktilton
Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.1 cell-cultures/cello/cello-ftgl.lisp:1.2 --- cell-cultures/cello/cello-ftgl.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/cello-ftgl.lisp Wed Sep 29 04:50:09 2004 @@ -77,10 +77,72 @@ (defmethod make-style-font ((style gui-style-ftgl)) (font-ftgl-ensure (mode style) (face style) (gui-style-size style)))
-(defmethod ogl-dsp-list-prep progn ((self ftgl)) - "Do stuff needed before render but not needed/wanted in display list" - (ftgl::ftgl-get-display-font self)) - +(defun ftgl-debug () + (let (*w*) + (with-styles ( + (make-instance 'gui-style-ftgl + :id :button + :face *gui-style-button-face* + :sizes '(12 12 12 12 12) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :label + :face *gui-style-button-face* + :sizes '(14 14 14 14 14) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :unique + :face *gui-style-button-face* + :sizes '(24 24 24 24 24) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :unique2 + :face *gui-style-button-face* + :sizes '(18 18 18 18 18) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :default + :mode :texture + :face *gui-style-button-face* + :sizes '(14 9 14 14 14) + :text-color +green+)) + (run-window (make-instance 'ftgl-window) + (lambda () + ;;; -- not sure how much of this new reset stuff is necessary --- + (cl-opengl-init) + (cl-ftgl-reset) + (cl-ftgl-init)))))) + +(defmodel ftgl-window (window) + () + (:default-initargs + :idler nil + :display-continuous t + :ll 0 :lt 0 + :lr (c-in (scr2log 900)) + :lb (c-in (scr2log -900)) + :md-name :ftgl-w + :title$ "Hello, ftgl" + :skin nil + :lighting :off + :clear-rgba (list 0 0 0 1) + :pre-layer (c? (with-layers +blue+ :off)) + :clipped nil + :kids (c? (the-kids + (a-stack (:md-name :ftgl-debug :spacing (upts 10) :px 0 :py (downs (uin 1)) + :justify :left + :outset (u8ths 1)) + (loop for s in (list "hell" ;;"hlwr" ;;"hlwr 1212" + "hi2" + "hello, world 222" "1212" + ) + for n upfrom 0 + collecting (mk-part :sample (ix-text) + :lighting :off + :text$ s + :style-id :unique + :pre-layer (c? (with-layers (:rgba (if (^mouse-over-p) + +red+ +blue+)))))))))))
(defun ftgl-test () @@ -185,6 +247,9 @@ (trc nil "ix-render-in-font ftgl-texture" :pxy (pxy self) (l-rect self) t$)
(gl-enable gl_texture_2d) + (trc "(gl-is-enabled gl_texture_2d)!!!!!!!" (gl-is-enabled gl_texture_2d) + (ogl-get-boolean gl_texture_2d)) + ;;(assert (ogl-get-boolean gl_texture_2d)) (gl-disable gl_lighting) (gl-enable gl_blend) (gl-blend-func gl_src_alpha gl_one_minus_src_alpha)
Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.2 cell-cultures/cello/image.lisp:1.3 --- cell-cultures/cello/image.lisp:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/image.lisp Wed Sep 29 04:50:09 2004 @@ -38,22 +38,24 @@
(defmodel ogl-node () ((dsp-list :initarg :dsp-list :accessor dsp-list - :initform (c? (ogl-dsp-list-prep self) - (when (every 'dsp-list (kids self)) - (let ((display-list-name (or .cache (gl-gen-lists 1))) - (*window-rendering* (nearest self window))) - - (assert (not *ogl-listing-p*)) - (gl-new-list display-list-name gl_compile) - (let ((*ogl-listing-p* self) - *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) - (with-metrics (nil nil "(funcall renderer)" self) - (ix-paint self))) - (gl-end-list) - (setf (redisplayp *window-rendering*) t) - #+nah (when (typep self 'window) - (c-break "got display list for ~a" self)) - display-list-name)))) + :initform (c-formula (:lazy :until-asked) + (assert *w*) + (assert (not *ogl-listing-p*)) + (ogl-dsp-list-prep self) + (when (every 'dsp-list (kids self)) + (let ((display-list-name (or .cache (gl-gen-lists 1))) + (*window-rendering* (nearest self window))) + (trc nil "display-list-name" display-list-name self) + + (gl-new-list display-list-name gl_compile) + + (let ((*ogl-listing-p* self) + *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) + (with-metrics (nil nil "(funcall renderer)" self) + (ix-paint self))) + (gl-end-list) + (setf (redisplayp *window-rendering*) t) + display-list-name)))) (gl-name :initarg :gl-name :initform nil :accessor gl-name) (renderer :initarg :renderer :initform nil :accessor renderer)))
Index: cell-cultures/cello/ix-render.lisp diff -u cell-cultures/cello/ix-render.lisp:1.1 cell-cultures/cello/ix-render.lisp:1.2 --- cell-cultures/cello/ix-render.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-render.lisp Wed Sep 29 04:50:09 2004 @@ -47,10 +47,7 @@ (when (and (not lights) (emergency-lighting self)) (trc nil "emergency lighting" self) (dolist (e-light (emergency-lighting self)) - (ix-render-light e-light)))) - - ) - + (ix-render-light e-light)))))
(defmethod ix-paint :after ((self family)) (dolist (k (kids self)) @@ -63,7 +60,9 @@
(unless (typep k 'window) ;; GLUT gives subwindows their own display callback (count-it :call-list) - (gl-call-list (dsp-list k))))) + (if (dsp-list k) + (gl-call-list (dsp-list k)) + (ix-paint k)))))
(defun rpchk (id pfail psucc &optional self) (declare (ignorable pfail)) @@ -86,7 +85,7 @@ (ogl-pen-move (px self) (py self)) ; /// combine former in here?
(when n - (trc "gl-name" self n) + (trc nil "gl-name" self n) (gl-push-name n))
(rpchk 'ix-paint t nil self)
Index: cell-cultures/cello/ix-styled.lisp diff -u cell-cultures/cello/ix-styled.lisp:1.1 cell-cultures/cello/ix-styled.lisp:1.2 --- cell-cultures/cello/ix-styled.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-styled.lisp Wed Sep 29 04:50:09 2004 @@ -73,7 +73,8 @@ (when style ;;(print `(gui-style ,style ,(styles-default))) (or (find style (styles-default) :key 'id) - (find :default (styles-default) :key 'id)))) + (find :default (styles-default) :key 'id) + (break "gui-style cannot find requested style ~a" style))))
(defmodel ix-styled () ((style-id :initarg :style-id @@ -81,6 +82,7 @@ :reader style-id)
(style :initform (c? (gui-style (^style-id))) + :initarg :style :reader style)
(text-font :reader text-font :initarg :text-font @@ -100,8 +102,27 @@ (with-layers (:rgba (^text-color)))))))
-(defmethod ogl-dsp-list-prep progn ((self ix-styled)) - (ogl-dsp-list-prep (text-font self))) +(defmethod ogl-dsp-list-prep progn ((self ix-styled) &aux (font (text-font self))) + (assert (not *ogl-listing-p*)) + (trc nil "ogl-dsp-list-prep sub-prepping font" font) + (typecase font + (ftgl-extruded + (unless (ftgl::ftgl-disp-ready-p font) + (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (ix-string-width self (^display-text$))) + (ftgl-texture + #+not (loop with x for c across (^display-text$) + do (pushnew (fgc-char-texture (ftgl::ftgl-get-metrics-font font)(char-code c)) x) + finally (trc "font,string,textures" font (^display-text$) x)) + #+no? (unless (ftgl::ftgl-disp-ready-p font) + (trc "setting face size" font) + (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + ;;(trc (eql 12 (ftgl::ftgl-size font)) "forcing glyphs" (ftgl::ftgl-face font) (^display-text$)) + #+not (ix-string-width self (^display-text$))) + ) + (ftgl::ftgl-get-display-font font))
(defmethod make-style-font ((style gui-style-glut-stroke)) (make-font-glut-stroke
Index: cell-cultures/cello/ix-text.lisp diff -u cell-cultures/cello/ix-text.lisp:1.1 cell-cultures/cello/ix-text.lisp:1.2 --- cell-cultures/cello/ix-text.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-text.lisp Wed Sep 29 04:50:09 2004 @@ -154,6 +154,11 @@ :initform (c? (cons (now)(frame-ct .w.))))) (:default-initargs :style-id :button + :style (make-instance 'gui-style-ftgl + :id :button + :face *gui-style-button-face* + :sizes '(16 16 16 16 16) + :text-color +white+) :inset (mkv2 (upts 2)(upts 0)) ;;:lt 15 :lb -5 :char-mask "999"
Index: cell-cultures/cello/mouse-click.lisp diff -u cell-cultures/cello/mouse-click.lisp:1.1 cell-cultures/cello/mouse-click.lisp:1.2 --- cell-cultures/cello/mouse-click.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/mouse-click.lisp Wed Sep 29 04:50:09 2004 @@ -74,14 +74,7 @@ (focus-navigate (focus (click-window self)) (clickee self))))
(to-be self) ;; unnecessary? 2301kt just moved this from after next line - (trc "echo click set self clickee" self (clickee self)) - (bwhen (c (cells::md-slot-cell (clickee self) 'click-evt)) - (trc "echo click-evt cell" c) - (dolist (u (cells::c-users c)) - (trc "echo click-evt cell user" c u)) - (if (c-debug c) - (trace ctl-notify-mouse-click) - (untrace ctl-notify-mouse-click))) + (trc nil "echo click set self clickee" self (clickee self))
(when (clickee self) (setf (click-evt (clickee self)) self)))
Index: cell-cultures/cello/slider.lisp diff -u cell-cultures/cello/slider.lisp:1.1 cell-cultures/cello/slider.lisp:1.2 --- cell-cultures/cello/slider.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/slider.lisp Wed Sep 29 04:50:09 2004 @@ -91,7 +91,7 @@
(def-c-output tracked-pct () (when new-value - (trc "tracked-pct output sets slider" self) + (trc nil "tracked-pct output sets slider" self) (slider-set self new-value)))
(defun make-slider (md-name &key (md-value-fn 'identity) @@ -104,5 +104,5 @@
(defun slider-set (self value) (assert (typep self 'ix-slider)) - (trc "slider set") + (trc nil "slider set") (setf (drag-pct (second (kids self))) value))
Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.1 cell-cultures/cello/window-callbacks.lisp:1.2 --- cell-cultures/cello/window-callbacks.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/window-callbacks.lisp Wed Sep 29 04:50:09 2004 @@ -51,33 +51,6 @@ (w-post-redisplay *w*))) (apply callback args))))))
-;;;(defmacro def-Window-callback (fn-name args &body body) -;;; `(ff-defun-callable :cdecl :void ,fn-name ,args -;;; (window-callback fn-name (lambda ,args ,@body)))) -;;; -;;;(defun window-callback (fn-name callback) -;;; (unless (c-stopped) -;;; ;; -;;; ;; this next bit makes sense because no cell rule evaluation could -;;; ;; depend on something touched during a callback, but then no cell -;;; ;; rule should dynamically encompass a callback, so...why reset -;;; ;; the calculators (dependents) global? it is necessary -;;; ;; because, when an error occurs, error-handling can cause -;;; ;; re-entrance and, if a cell rule was being evaluated, suddenly -;;; ;; the programmer is looking at an error about "too many dependencies" -;;; ;; instead of the original error. there is probably a better way to handle -;;; ;; all this, but for now... 2003-04-05kwt -;;; ;; -;;; (let* (cells::*c-calculators* -;;; (*w* (mg-window-current))) -;;; (if *w* -;;; (prog2 -;;; (setf (redisplayp *w*) nil) -;;; (progn ,@body) -;;; (when (redisplayp *w*) -;;; (w-post-redisplay *w*))) -;;; (progn ,@body)))))) - (def-window-callback mgwkey (k x y) (trc "mgwkey" k x y (glutgetwindow)) (bwhen (w *w*) @@ -111,14 +84,25 @@ (bwhen (w (mg-window-current)) (ix-idle w))))
+#+bzzzt +(defun dnr (n) + (locally (declare (special %displaying%)) + (print `(dnr ,n)) + (unless (and (boundp '%displaying%) %displaying%) + (let ((%displaying% t)) + (when (< n 2) + (dnr (1+ n))))))) + + (def-window-callback mg-glut-display () - (unless (or (c-stopped) (null *w*)) + (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox + (c-stopped) (null *w*)) (with-metrics (nil nil "mg-glut-display") - (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) + (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) (window-display *w*))))
(defmethod window-display ((self window)) - (gl-call-list (dsp-list self)) + (ix-paint self) ;; (gl-call-list (dsp-list self)) (glut-swap-buffers)
(incf (frame-ct self))
Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.1 cell-cultures/cello/window.lisp:1.2 --- cell-cultures/cello/window.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/window.lisp Wed Sep 29 04:50:09 2004 @@ -384,12 +384,12 @@ (glut-destroy-window (glutw self)))))
(defmethod mg-window-reshape (self width height) - (trc "mg-window-reshape" self width height) + (trc nil "mg-window-reshape" self width height) (gl-viewport 0 0 width height) (gl-matrix-mode gl_projection) (gl-load-identity)
- (trc "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) + (trc nil "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) (gl-ortho 0 width (- height) 0 *mgw-near* *mgw-far*) (gl-load-identity) (trc nil "mg-window-reshape > new window wid,hei:" self width height) @@ -403,7 +403,8 @@ (when run-init-func (funcall run-init-func)) (let ((ogl::*gl-stop* nil) - (ogl::*gl-begun* nil)) ;;/// wrap these two in a macro? + (ogl::*gl-begun* nil) ;;/// wrap these two in a macro? + *w* *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (setf cello::*sys* nil) (cello-reset 'mg-system)