Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv27567/cello
Modified Files: cello-ftgl.lisp cello.asd cello.lisp image.lisp ix-styled.lisp ix-text.lisp mg-geometry.lisp window.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:08:56 2004 Author: ktilton
Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.4 cell-cultures/cello/cello-ftgl.lisp:1.5 --- cell-cultures/cello/cello-ftgl.lisp:1.4 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/cello-ftgl.lisp Thu Oct 28 02:08:56 2004 @@ -20,9 +20,6 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.
- -(defpackage #:cello (:use #:cl-ftgl)) - (in-package :cello)
(defmethod font-height ((font ftgl))
Index: cell-cultures/cello/cello.asd diff -u cell-cultures/cello/cello.asd:1.1 cell-cultures/cello/cello.asd:1.2 --- cell-cultures/cello/cello.asd:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/cello.asd Thu Oct 28 02:08:56 2004 @@ -15,8 +15,62 @@ :maintainer "Kenny Tilton ktilton@nyc.rr.com" :licence "MIT" :description "A Portable Common Lisp GUI" - :long-description "The final pieces of a portable Common Lisp GUI (assumes cellocore)" - :components ((:file "cello-ftgl") + :long-description "The final pieces of a portable Common Lisp GUI" + + :depends-on (:cells :cl-opengl :cl-magick) + :components ((:file "cello") + (:file "datetime") + (:file "window-macros" :depends-on ("cello")) + (:file "clipping" :depends-on ("cello")) + (:file "mg-geometry" :depends-on ("cello")) + (:file "coordinate-xform" :depends-on ("mg-geometry")) + (:file "ix-geometry" :depends-on ("coordinate-xform")) + (:file "colors" :depends-on ("ix-geometry")) + (:file "rgb" :depends-on ("colors")) + (:file "frame" :depends-on ("rgb")) + (:file "application" :depends-on ("frame")) + (:file "image" + :depends-on ("application" + "window-macros" "clipping" + "mg-geometry" + "ix-geometry")) + + (:file "ix-layer-expand" :depends-on ("cello" "image" "frame")) + (:file "ix-canvas" :depends-on ("ix-layer-expand")) + (:file "ix-family" :depends-on ("cello" "ix-canvas")) + (:file "font" :depends-on ("image")) + (:file "ix-inline" :depends-on ("ix-geometry" "ix-family")) + (:file "ix-grid" :depends-on ("ix-inline")) + (:file "mouse-click" :depends-on ("ix-grid")) + (:file "control" :depends-on ("mouse-click")) + (:file "focus" :depends-on ("ix-canvas")) + (:file "focus-navigation" :depends-on ("focus")) + (:file "focus-utilities" :depends-on ("focus-navigation")) + (:file "ix-styled" :depends-on ("ix-canvas" "font")) + (:file "ix-text" :depends-on ("ix-styled")) + (:file "lighting" :depends-on ("ix-inline")) + (:file "window" :depends-on ("image" "lighting")) + (:file "ctl-toggle" :depends-on ("control" "ix-text")) + (:file "ctl-markbox" :depends-on ("ctl-toggle")) + (:file "ctl-drag" :depends-on ("ctl-markbox")) + (:file "ctl-selectable" :depends-on ("ctl-drag")) + (:file "slider" :depends-on ("ctl-selectable")) + (:file "window-utilities" :depends-on ("window")) + (:file "window-render" :depends-on ("window-utilities")) + (:file "window-callbacks" :depends-on ("window-utilities")) + (:file "wm-mouse" :depends-on ("window-callbacks")) + + (:file "pick" :depends-on ("wm-mouse")) + (:file "menu" :depends-on ("pick")) + (:file "ix-render" :depends-on ("window-render")) + (:file "ix-polygon" :depends-on ("ix-render")) + (:file "ct-scroll-pane" :depends-on ("ix-polygon")) + (:file "ct-scroll-bar" :depends-on ("ct-scroll-pane")) + (:file "cello-ftgl") (:file "cello-openal") (:file "cello-magick" :depends-on ("cello-ftgl")) )) + + + +
Index: cell-cultures/cello/cello.lisp diff -u cell-cultures/cello/cello.lisp:1.2 cell-cultures/cello/cello.lisp:1.3 --- cell-cultures/cello/cello.lisp:1.2 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/cello.lisp Thu Oct 28 02:08:56 2004 @@ -25,27 +25,11 @@ (:nicknames :clo) (:use #:common-lisp - #-cormanlisp #:clos + #-(or cormanlisp mcl) #:clos #:utils-kt #:cells #:ffx #:cl-opengl - ) - ;;; (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) - ) + #:cl-ftgl + #:cl-magick))
- -(in-package :cello) - -(defparameter *cello-runtime-directory* :unconfigured) -(defparameter *user-temp-directory* :unconfigured) - -(load (merge-pathnames "cellocore-config.lisp" - cl-user::*cello-config-directory*)) - -(defun cellocore-test () - "to be announced") - -(defun cello-runtime-file (file) - (merge-pathnames file - *cello-runtime-directory*)) \ No newline at end of file
Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.5 cell-cultures/cello/image.lisp:1.6 --- cell-cultures/cello/image.lisp:1.5 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/image.lisp Thu Oct 28 02:08:56 2004 @@ -34,30 +34,60 @@ (declare (ignore self)) (assert (not *ogl-listing-p*)))
-(defvar *window-rendering*) +(defvar *ogl-shared-resource-tender*) + +(defclass ogl-shared-resource-tender () + ((display-lists :initform nil :accessor display-lists) + (quadrics :initform nil :accessor quadrics) + (textures :initform nil :accessor textures))) + +(defmethod not-to-be :before ((self ogl-shared-resource-tender)) + (loop for (nil . dl) in (display-lists self) + do (gl-delete-lists dl 1) + finally (setf (display-lists self) nil)) + (loop for (nil . q) in (quadrics self) + do (glu-delete-quadric q))) + +(defmethod ogl-shared-resource-tender ((self ogl-shared-resource-tender)) + self) + +(defmethod ogl-shared-resource-tender (other) + (c-break "ogl-shared-resource-tender undefined for ~a" other)) + +(defmethod ogl-node-window (other) + (c-break "ogl-node-window undefined for ~a" other))
(defmodel ogl-node () ((dsp-list :initarg :dsp-list :accessor dsp-list :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))) - (gl-new-list display-list-name gl_compile) - (trc nil "starting display list" display-list-name self) - (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))) - (trc nil "finished display list" display-list-name self) - (gl-end-list) - (setf (redisplayp *window-rendering*) t) - display-list-name)))) + (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))) + (*ogl-shared-resource-tender* + (ogl-shared-resource-tender self))) + + (gl-new-list display-list-name gl_compile) + (trc nil "starting display list" display-list-name self) + (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))) + (trc nil "finished display list" display-list-name self) + (gl-end-list) + (setf (redisplayp (ogl-node-window self)) t) + display-list-name)))) (gl-name :initarg :gl-name :initform nil :accessor gl-name) (renderer :initarg :renderer :initform nil :accessor renderer)))
+(defmethod not-to-be :after ((self ogl-node)) + (bwhen (dl (^dsp-list)) + (gl-delete-lists dl 1))) + + + + ;;;(defmethod ix-render-prep (self) ;;; (declare (ignore self))) ;;; @@ -133,12 +163,19 @@ (assert (lr self)) (assert (lb self)))
+(defmethod ogl-shared-resource-tender ((self image)) + .w.) + +(defmethod ogl-node-window ((self image)) + .w.)
(defmethod ogl-dsp-list-prep progn ((self image)) (ogl-dsp-list-prep (skin self)))
(defmethod ogl-dsp-list-prep progn ((self wand-texture)) - (texture-name self)) + (texture-name self)) + +
;------------------------------ (def-c-output mouse-over-p ()
Index: cell-cultures/cello/ix-styled.lisp diff -u cell-cultures/cello/ix-styled.lisp:1.3 cell-cultures/cello/ix-styled.lisp:1.4 --- cell-cultures/cello/ix-styled.lisp:1.3 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/ix-styled.lisp Thu Oct 28 02:08:56 2004 @@ -109,16 +109,16 @@ (defmethod ix-find-style (self style-id) (declare (ignore self style-id)))
+ (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::ftgl-get-display-font font)) + (setf (ftgl::ftgl-disp-ready-p font) t) + (fgc-set-face-size (ftgl-ensure-ifont font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res 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.3 cell-cultures/cello/ix-text.lisp:1.4 --- cell-cultures/cello/ix-text.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/ix-text.lisp Thu Oct 28 02:08:56 2004 @@ -69,6 +69,18 @@ (:default-initargs :lighting :off))
+ +(defmethod ogl-dsp-list-prep progn ((self ix-text) &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) + (setf (ftgl::ftgl-disp-ready-p font) t) + (fgc-set-face-size (ftgl-ensure-ifont font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (ix-string-width self (^display-text$))))) + (defmacro alabel (text &rest key-arg-pairs) `(cells::make-part (gensym "ALABEL") 'ix-text ,@key-arg-pairs
Index: cell-cultures/cello/mg-geometry.lisp diff -u cell-cultures/cello/mg-geometry.lisp:1.1 cell-cultures/cello/mg-geometry.lisp:1.2 --- cell-cultures/cello/mg-geometry.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/mg-geometry.lisp Thu Oct 28 02:08:56 2004 @@ -38,7 +38,8 @@ (defun mkv2 (h v) (make-v2 :h h :v v))
(defun v2= (a b) - (and (= (v2-h a)(v2-h b)) + (and a b + (= (v2-h a)(v2-h b)) (= (v2-v a)(v2-v b))))
(defun v2-add (p1 p2)
Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.4 cell-cultures/cello/window.lisp:1.5 --- cell-cultures/cello/window.lisp:1.4 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/window.lisp Thu Oct 28 02:08:56 2004 @@ -24,12 +24,10 @@
;------------- Window --------------- ; -(defmodel window (focuser ix-lit-scene control) +(defmodel window (focuser ix-lit-scene control ogl-shared-resource-tender) ( (glutw :initarg :glutw :accessor glutw :initform (c? (without-c-dependency (glutw-create self)))) - (display-lists :cell nil :initform nil :accessor display-lists) - (quadrics :cell nil :initform nil :accessor quadrics) (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp) (glut-xy :initarg :glut-xy :unchanged-if 'v2= :initform (mkv2 96 96) :accessor glut-xy) @@ -114,6 +112,12 @@ (defmethod ogl-dsp-list-prep progn ((self window)) (glutw self))
+(defmethod ogl-node-window ((self window)) + self) + +(defmethod ogl-shared-resource-tender ((self window)) + self) + (defun window-menus-basic () (list (list "File" @@ -363,23 +367,7 @@ (when must-find-p (c-break "no mgw matches glutw ~d" gw)))))))
-(defmethod ogl-list-cache ((self image)) - (display-lists .w.)) - -(defmethod (setf ogl-list-cache) (new-value (self image)) - (setf (ogl-list-cache .w.) new-value)) - -(defmethod ogl-list-cache ((self window)) - (display-lists self)) - -(defmethod (setf ogl-list-cache) (new-value (self window)) - (setf (display-lists self) new-value)) - (defmethod not-to-be :before ((self window)) - (loop for (nil . q) in (quadrics self) - do - (glu-delete-quadric q)) - (ogl-lists-delete self) (when (upper self window) ;; better way to detect appropriateness? (when (glutw self) (glut-destroy-window (glutw self))))) @@ -436,7 +424,7 @@ (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) - (trc "paint> win ortho! l r b t n f:" + (trc nil "paint> win ortho! l r b t n f:" (ll self)(lr self) (lb self)(lt self) *mgw-near* *mgw-far*) @@ -460,7 +448,7 @@ (with-metrics (nil nil "ix-paint window call next") (call-next-method)))))
-(defun w-quadric-ensure (key) - (or (cdr (assoc key (quadrics *window-rendering*))) +(defun w-quadric-ensure (ogl-resource-tender key) + (or (cdr (assoc key (quadrics ogl-resource-tender))) (cdar (push (cons key (glu-new-quadric)) - (quadrics *window-rendering*))))) \ No newline at end of file + (quadrics ogl-resource-tender))))) \ No newline at end of file