[cells-cvs] CVS update: cell-cultures/cello/cello-ftgl.lisp cell-cultures/cello/image.lisp cell-cultures/cello/ix-render.lisp cell-cultures/cello/ix-styled.lisp cell-cultures/cello/ix-text.lisp cell-cultures/cello/mouse-click.lisp cell-cultures/cello/slider.lisp cell-cultures/cello/window-callbacks.lisp cell-cultures/cello/window.lisp
Kenny Tilton
ktilton at common-lisp.net
Wed Sep 29 02:50:11 UTC 2004
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 , at 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 , at body)
-;;; (when (redisplayp *w*)
-;;; (w-post-redisplay *w*)))
-;;; (progn , at 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)
More information about the Cells-cvs
mailing list