[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Mon Jul 3 00:35:12 UTC 2006
Update of /project/cello/cvsroot/cello
In directory clnet:/tmp/cvs-serv10432
Modified Files:
application.lisp cello-window.lisp cello.lpr ctl-toggle.lisp
image.lisp ix-opengl.lisp ix-paint.lisp ix-text.lisp
ix-togl.lisp nehe-06.lisp
Log Message:
--- /project/cello/cvsroot/cello/application.lisp 2006/06/05 01:47:49 1.4
+++ /project/cello/cvsroot/cello/application.lisp 2006/07/03 00:35:12 1.5
@@ -22,7 +22,8 @@
(defun cello-reset (&optional (system-type 'mg-system))
(ffx-reset)
- (cells-reset 'tk-client-queue-handler)
+ (cells-reset 'tk-user-queue-handler)
+ (makunbound 'ogl::*gl-stop*)
(when system-type
(setf *sys* (make-instance system-type :md-name 'mgsys)))
(values))
--- /project/cello/cvsroot/cello/cello-window.lisp 2006/06/26 17:05:20 1.1
+++ /project/cello/cvsroot/cello/cello-window.lisp 2006/07/03 00:35:12 1.2
@@ -72,7 +72,7 @@
;
(case (ctk::tk-event-type (ctk::xsv type xe))
(:virtualevent )
- (:KeyPress )
+ (:KeyPress ) ;; this and next handled as app virtual events because Tcl events useless
(:KeyRelease )
(:ButtonPress )
(:ButtonRelease )
--- /project/cello/cvsroot/cello/cello.lpr 2006/06/26 17:05:20 1.7
+++ /project/cello/cvsroot/cello/cello.lpr 2006/07/03 00:35:12 1.8
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -26,7 +26,6 @@
(make-instance 'module :name "ix-styled.lisp")
(make-instance 'module :name "ix-text.lisp")
(make-instance 'module :name "ix-togl.lisp")
- (make-instance 'module :name "window-callbacks.lisp")
(make-instance 'module :name "lighting.lisp")
(make-instance 'module :name "ctl-toggle.lisp")
(make-instance 'module :name "ctl-markbox.lisp")
--- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/06/05 01:47:49 1.2
+++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/07/03 00:35:12 1.3
@@ -111,6 +111,7 @@
))
:ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15))))
+
(defmacro mk-twisted (twisted-name (label-class &rest label-args)
(twisted-class &rest twisted-args))
`(mk-part :twisted-group (ix-zero-tl)
--- /project/cello/cvsroot/cello/image.lisp 2006/06/26 17:05:20 1.7
+++ /project/cello/cvsroot/cello/image.lisp 2006/07/03 00:35:12 1.8
@@ -17,7 +17,7 @@
(in-package :cello)
(eval-when (compile load eval)
- (export '(ix-view)))
+ (export '(ix-view ix-stack ix-row ix-stack-lazy ix-row-lazy a-stack a-row a-stack-lazy a-row-lazy)))
; ------------------------------------------------------
(defmodel ogl-quadric-based (ogl-node)
@@ -69,8 +69,7 @@
;;------- IXFamily -----------------------------
;;
(defmodel ix-family (ix-view family)
- (
- (styles :initform nil :reader styles :initarg :styles)
+ ((styles :initform nil :reader styles :initarg :styles)
(effective-styles :reader effective-styles :initarg :effective-styles
:initform nil #+(or) (ix-family-effective-styles))
@@ -80,33 +79,55 @@
(kids-ever-shown
:initarg :kids-ever-shown
:initform (c? (or .cache (^showkids)))
- :reader kids-ever-shown)
- ))
+ :reader kids-ever-shown)))
(defmodel ix-inline (geo-inline ix-view)())
+(defmodel ix-inline-lazy (geo-inline-lazy ix-view)())
(defmodel ix-stack (ix-inline)
()
(:default-initargs
:orientation :vertical))
+(defmodel ix-stack-lazy (ix-inline-lazy)
+ ()
+ (:default-initargs
+ :orientation :vertical))
+
(defmodel ix-row (ix-inline)
()
(:default-initargs
:orientation :horizontal))
+(defmodel ix-row-lazy (ix-inline-lazy)
+ ()
+ (:default-initargs
+ :orientation :horizontal))
+
(defmacro a-stack ((&rest stack-args) &body dd-kids)
`(mk-part ,(copy-symbol 'stk) (ix-stack)
, at stack-args
:fm-parent *parent*
:kids (c? (the-kids , at dd-kids))))
+(defmacro a-stack-lazy ((&rest stack-args) &body dd-kids)
+ `(mk-part ,(copy-symbol 'stk) (ix-stack-lazy)
+ , at stack-args
+ :fm-parent *parent*
+ :kids (c? (the-kids , at dd-kids))))
+
(defmacro a-row ((&rest stack-args) &body dd-kids)
`(mk-part ,(copy-symbol 'row) (ix-row)
, at stack-args
:fm-parent *parent*
:kids (c? (the-kids , at dd-kids))))
+(defmacro a-row-lazy ((&rest stack-args) &body dd-kids)
+ `(mk-part ,(copy-symbol 'row) (ix-row-lazy)
+ , at stack-args
+ :fm-parent *parent*
+ :kids (c? (the-kids , at dd-kids))))
+
(defmethod focus-starting ((self ix-family))
(some #'focus-find-first (kids self)))
@@ -115,13 +136,7 @@
`(let* ((,kid ,self))
(find-prior ,kid (kids (fm-parent ,kid))))))
-(defmethod md-awaken :after ((self ix-view))
- (assert (px self))
- (assert (py self))
- (assert (ll self))
- (assert (lt self))
- (assert (lr self))
- (assert (lb self)))
+
(defmethod ogl-shared-resource-tender ((self ix-view))
.w.)
@@ -164,6 +179,7 @@
(v2 (v2-h v))
(ix-view (inset-h (inset v)))))
+
(defun inset-v (v)
(etypecase v
(number v)
@@ -190,7 +206,7 @@
(g-offset (fm-parent self) oh ov))))
(defun w-bottom-left (self)
- (v2-move (g-offset self)
+ (v2-add (g-offset self)
(ll self)
(+ (lb self) (l-height .w.))))
--- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/06/26 17:05:20 1.1
+++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/07/03 00:35:12 1.2
@@ -55,7 +55,7 @@
(defmodel ogl-node ()
((ogl-context :cell nil :initform nil :accessor ogl-context)
(dsp-list :initarg :dsp-list :accessor dsp-list
- :initform (c-formula (:lazy :until-asked)
+ :initform nil #+not (c-formula (:lazy :until-asked)
(assert (not *ogl-listing-p*))
(progn
(ogl-dsp-list-prep self)
@@ -66,12 +66,12 @@
(*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)
+ (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 "ix-paint" self)
(ix-paint self)))
- (trc nil "finished display list" display-list-name self)
+ (trc nil "---------------finished display list" display-list-name self)
(gl-end-list)
(setf (redisplayp .og.) t)
display-list-name)))))
--- /project/cello/cvsroot/cello/ix-paint.lisp 2006/06/26 17:05:20 1.1
+++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/07/03 00:35:12 1.2
@@ -25,11 +25,13 @@
(c-assert (px k) () "pX is null in ~a" k)
(c-assert (py k) () "pY is null in ~a" k)
- (count-it :call-list)
+
(if (dsp-list k)
(progn
- (trc nil "ix-paint calling list" (dsp-list k))
- (gl-call-list (dsp-list k)))
+ (count-it :call-list)
+ (trc "ix-paint calling list" (dsp-list k))
+ (gl-call-list (dsp-list k))) ; 06/0629 edit caret presences causes INVALID_OP on
+ ; first run only in a session; just continue from
(ix-paint k))))
(defun rpchk (id pfail psucc &optional self)
@@ -50,6 +52,7 @@
(let ((ixr-box (mkr 0 0 0 0)))
(defmethod ix-paint :around ((self ix-view) &aux (n (gl-name self)))
(trc nil "painting, shifting bitmap" self n (^px)(^py) (pre-layer self))
+
(with-bitmap-shifted ((px self)(py self))
(gl-translatef (px self) (py self) 0)
@@ -69,6 +72,55 @@
(count-it :ix-render)
#+(or) (count-it :ix-paint (type-of self))
#+(or) (unless (kids self)
+ (count-it :ix-render-atom))
+ (trc nil "ix painting" self (^px)(^py)(l-box self))
+ (with-matrix ()
+ (with-ogl-isolation
+ (case (lighting self) ;; default is "same as parent"
+ (:on (gl-enable gl_lighting))
+ (:off (gl-disable gl_lighting)))
+
+ (gl-enable gl_color_material)
+ (bif (pre-layer (pre-layer self))
+ (progn
+ (assert (functionp pre-layer))
+ (count-it :pre-layer)
+ (nr-make ixr-box (ll self) (lt self) (lr self) (lb self))
+
+ (funcall pre-layer self ixr-box :before)
+ (call-next-method self)
+ (funcall pre-layer self ixr-box :after))
+ (call-next-method self)))))))
+ (when n
+ (gl-pop-name))
+ (gl-translatef (- (px self)) (- (py self)) 0))
+
+ ))
+
+#+new
+(let ((ixr-box (mkr 0 0 0 0)))
+ (defmethod ix-paint :around ((self ix-view) &aux (n (gl-name self)))
+ (trc nil "painting, shifting bitmap" self n (^px)(^py) (pre-layer self))
+ (when (or (c-stopped)
+ (not (^visible))
+ (collapsed self))
+ (return-from ix-paint))
+
+ (with-bitmap-shifted ((px self)(py self))
+ (gl-translatef (px self) (py self) 0)
+
+
+ (when n
+ (trc "pushing gl-name" self n)
+ (gl-push-name n))
+
+ (rpchk 'ix-paint t nil self)
+ (when (or (not *selecting*)(ix-selectable 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-paint (type-of self))
+ #+(or) (unless (kids self)
(count-it :ix-render-atom))
(trc nil "ix painting" self (lighting self))
(with-matrix ()
--- /project/cello/cvsroot/cello/ix-text.lisp 2006/06/26 17:05:20 1.6
+++ /project/cello/cvsroot/cello/ix-text.lisp 2006/07/03 00:35:12 1.7
@@ -19,7 +19,7 @@
;===========================================================
(eval-when (compile load eval)
- (export '(ix-paint)))
+ (export '(ix-paint inset)))
(defmodel ix-text (ix-styled ix-view)
(
@@ -51,7 +51,8 @@
(inset :cell nil :initarg :inset
:unchanged-if 'v2=
- :initform (mkv2 0 0))
+ :initform (mkv2 0 0)
+ :accessor inset)
(ll :initform (c? (- (inset-h self))))
(lt :initform (c? (ups 0 (font-ascent (text-font self)) (inset-v self))))
(lr :initform (c? (^lr-width (+ (cond
--- /project/cello/cvsroot/cello/ix-togl.lisp 2006/06/26 17:05:20 1.1
+++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/07/03 00:35:12 1.2
@@ -85,6 +85,8 @@
(trc nil "window-display > continuous specified so posting redisplay" self)
(ctk:togl-post-redisplay (ctk:togl-ptr self))))))
+
+
(defmethod ix-togl-event-handler (self xe)
"Tk does not go inside Togl OpenGL-land, so Cello Classic effectively begins here"
(TRC nil "ix-togl-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) )
--- /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/26 17:05:20 1.5
+++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/07/03 00:35:12 1.6
@@ -142,7 +142,7 @@
(gl-tex-coord2f 1 1) (v3f -1 1 1)
(gl-tex-coord2f 0 1) (v3f -1 1 -1)
))
- #+ifuwanttoseepixmap
+ ;;#+ifuwanttoseepixmap
(wand-render *grace* 0 0 1 -1)
(progn
@@ -171,7 +171,7 @@
(setf *skin6* (mgk:wand-ensure-typed 'wand-texture
(test-image "jmcbw512" "jpg")))
(setf *grace* (mgk:wand-ensure-typed 'wand-pixels
- (test-image "turing" "gif"))))
+ (test-image "grace" "jpg")))) ; "turing" "gif"))))
(defun print-frame-rate (window)
(with-slots (frame-count t0) window
@@ -188,8 +188,8 @@
(setq t0 time)
(setq frame-count 0)))))
-(defun test-image (filename filetype)
+(defun test-image (filename filetype &optional (subdir "shapers"))
(make-pathname
- :directory '(:absolute "0dev" "user" "graphics" "shapers")
+ :directory `(:absolute "0dev" "user" "graphics" ,subdir)
:name (string filename)
:type (string filetype)))
More information about the Cello-cvs
mailing list