Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv31340

Modified Files: cello-ftgl.lisp cello.lpr image.lisp ix-layer-expand.lisp ix-render.lisp ix-text.lisp lighting.lisp mouse-click.lisp nehe-06.lisp window-callbacks.lisp window-utilities.lisp Log Message:

--- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/11 13:32:24 1.5 @@ -67,7 +67,7 @@ (font-ftgl-ensure (mode style) (face style) (gui-style-size style)))

(defun ftgl-debug () - (let (*w*) + (let (*tkw*) (with-styles ( (make-instance 'gui-style-ftgl :id :button --- /project/cello/cvsroot/cello/cello.lpr 2006/06/05 01:47:49 1.5 +++ /project/cello/cvsroot/cello/cello.lpr 2006/06/11 13:32:24 1.6 @@ -74,7 +74,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'nehe-06::nehe-06 + :on-initialization 'cello::nehe-06 :on-restart 'do-default-restart)

;; End of Project Definition --- /project/cello/cvsroot/cello/image.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/image.lisp 2006/06/11 13:32:24 1.5 @@ -16,8 +16,6 @@

(in-package :cello)

-(defparameter *w* nil) - ; ------------------------------------------------------

--- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/06/11 13:32:24 1.5 @@ -56,7 +56,9 @@ (gl-disable gl_blend) (gl-disable gl_texture_2d) (gl-normal3i 0 0 1) - (gl-rectf (r-left l-box)(r-bottom l-box)(r-right l-box)(r-top l-box))) + + (gl-rectf (r-left l-box) (r-top l-box) (r-right l-box)(r-bottom l-box)) + )

(defmethod ix-layer-expand ((key (eql :normal-out)) &rest args) (declare (ignore args)) --- /project/cello/cvsroot/cello/ix-render.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/ix-render.lisp 2006/06/11 13:32:24 1.4 @@ -17,32 +17,6 @@ (in-package :cello)

-(defmethod ix-paint :before ((self ix-lit-scene)) - (gl-enable gl_color_material) - (when (eql :on (lighting self)) - (trc nil "lighting on!" self) - (gl-enable gl_lighting)) - - (dolist (lm (light-model self)) - ;(trc "lighting model!" self lm) - (gl-light-modelfv (car lm)(cdr lm))) - - (gl-enable gl_auto_normal) - (gl-enable gl_normalize) - - (let (lights) - ;; /// next bit should not descend into a nested lit scene - (fm-traverse self (lambda (self) - (when (typep self 'ix-light) - (setf lights (or lights (^enabled))) - (ix-render-light self)))) - (loop for light in (fixed-lighting self) - do (ix-render-light light)) - (when (and (not lights) (emergency-lighting self)) - (trc nil "emergency lighting" self) - (dolist (e-light (emergency-lighting self)) - (ix-render-light e-light))))) - (defmethod ix-paint :after ((self family)) (dolist (k (kids self)) (trc nil "ixr geo" k (list (px k)(py k)) (list (ll k)(lt k)(lr k)(lb k))) @@ -66,7 +40,7 @@

(defmethod ix-paint (self) (declare (ignorable self)) - (trc nil "ix-render fell through" self (class-of self))) + (trc "ix-render fell through" self (class-of self)))

(defmacro with-ogl-isolation (&body body) `(with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) @@ -74,13 +48,13 @@

(let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self image) &aux (n (gl-name self))) - (trc nil "painting" self (^px)(^py)(^lr)) + (trc "painting, shifting bitmap" self n (^px)(^py)) (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0)

(when n - (trc nil "gl-name" self n) + (trc "pushing gl-name" self n) (gl-push-name n))

(rpchk 'ix-paint t nil self) @@ -89,13 +63,13 @@ (ix-selectable self)) (visible self) (not (collapsed self))) - (with-clipping (self) + (progn ;;with-clipping (self) (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (count-it :ix-render) #+(or) (count-it :ix-render (type-of self)) #+(or) (unless (kids self) (count-it :ix-render-atom)) - (trc nil "ix painting" self) + (trc "ix painting" self (lighting self)) (with-matrix () (with-ogl-isolation (case (lighting self) ;; default is "same as parent" --- /project/cello/cvsroot/cello/ix-text.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/06/11 13:32:24 1.5 @@ -18,6 +18,9 @@

;===========================================================

+(eval-when (compile load eval) + (export '(ix-paint))) + (defmodel ix-text (ix-styled image) ( (text$ :initform nil :initarg :text$ :accessor text$) --- /project/cello/cvsroot/cello/lighting.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/06/11 13:32:24 1.4 @@ -41,19 +41,13 @@

;;----------------------------------------------

-(defun make-lighting (md-name id pos) - (make-instance 'ix-light - :md-name md-name - :id id - :initial-pos pos)) - -(defmodel ix-lit-scene (ix-family) +(defmodel ix-lit-scene () ;; mix in with ix-family ( (clear-rgba :cell nil :initarg :clear-rgba :initform nil :accessor clear-rgba) (light-model :initarg :light-model :initform (list (cons gl_light_model_ambient *dim*)) :accessor light-model) (lights :initarg :lights :accessor lights - :initform (c? (without-c-dependency + :initform nil #+refactor (c? (without-c-dependency (let (lights) (fm-traverse self (lambda (self) (when (typep self 'ix-light) @@ -76,7 +70,32 @@ :diffuse *average* :specular *bright*)))))

- +(defmethod ix-paint :before ((self ix-lit-scene)) + (gl-enable gl_color_material) + (when (eql :on (lighting self)) + (trc nil "lighting on!" self) + (gl-enable gl_lighting)) + + (dolist (lm (light-model self)) + ;(trc "lighting model!" self lm) + (gl-light-modelfv (car lm)(cdr lm))) + + (gl-enable gl_auto_normal) + (gl-enable gl_normalize) + + (let (lights) + ;; /// next bit should not descend into a nested lit scene + #+refactorifneeded + (fm-traverse self (lambda (self) + (when (typep self 'ix-light) + (setf lights (or lights (^enabled))) + (ix-render-light self)))) + (loop for light in (fixed-lighting self) + do (ix-render-light light)) + (when (and (not lights) (emergency-lighting self)) + (trc nil "emergency lighting" self) + (dolist (e-light (emergency-lighting self)) + (ix-render-light e-light)))))

(defun pct-xlate (pct v1 v2 expansion) (let* ((dv (round (- v2 v1) 2)) --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/11 13:32:24 1.5 @@ -77,11 +77,12 @@ (when (or (null new-click) (if (typep self 'window) (ctl-notify-mouse-click self self new-click) - (ctl-notify-mouse-click (fm-parent self) self new-click))) + (ctl-notify-mouse-click (fm-parent self) self new-click))) (call-next-method)))

(defmethod ctl-notify-mouse-click (self clickee click) - (ctl-notify-mouse-click (fm-parent self) clickee click)) + (when (fm-parent self) + (ctl-notify-mouse-click (fm-parent self) clickee click)))

; --------------------------------------------------------

--- /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/11 13:32:24 1.4 @@ -3,10 +3,7 @@ ;;; nehe lesson 06 spinning cube with texture ;;;

-(defpackage :nehe-06 - (:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-magick :cl-ftgl)) - -(in-package :nehe-06) +(in-package :cello)

(defvar *startx*) (defvar *starty*) --- /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/11 13:32:24 1.5 @@ -24,8 +24,7 @@ (progn (trc nil "window using disp list") (gl-call-list (dsp-list self))) - (ix-paint self))) - (incf (frame-ct self)))) + (ix-paint self)))))

(defmethod ctk::togl-timer-using-class ((self ix-togl)) (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox --- /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/11 13:32:24 1.5 @@ -70,8 +70,7 @@ ; --------------- geometry -------------------------------

-(defmethod g-offset ((self cello-window) &optional (accum-h 0) (accum-v 0)) - (mkv2 accum-h accum-v)) +

(defun point-in-box (pt box) (and (<= (r-left box) (v2-h pt) (r-right box))