Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv28025/cello Modified Files: cello-ftgl.lisp cello-magick.lisp cello.lisp cello.lpr ct-scroll-bar.lisp ct-scroll-pane.lisp ctl-drag.lisp ctl-markbox.lisp ctl-selectable.lisp ctl-toggle.lisp image.lisp ix-family.lisp ix-geometry.lisp ix-grid.lisp ix-inline.lisp ix-render.lisp ix-styled.lisp menu.lisp pick.lisp to-do.lisp window-callbacks.lisp window.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:22 2004 Author: ktilton Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.3 cell-cultures/cello/cello-ftgl.lisp:1.4 --- cell-cultures/cello/cello-ftgl.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/cello-ftgl.lisp Fri Oct 15 05:37:21 2004 @@ -188,8 +188,6 @@ :clipped nil :kids (c? (loop for mode in '(:bitmap :pixmap :texture :outline :polygon :extruded) collect (mk-part :rb (ct-radio-labeled) - :text-font (font-ftgl-ensure :texture - *gui-style-default-face* 12) :associated-value mode :title$ (string-capitalize (format nil "~d" mode)))))) @@ -198,7 +196,8 @@ :kids (c? (the-kids (loop repeat cols collecting - (mk-part :fstk (ix-stack) + (mk-part :fstk (ix-inline) + :orientation :vertical :kids (c? (let ((col-no (kid-no self))) (loop for row-no below (ceiling (length fns) cols) when (mk-font-show col-no row-no) Index: cell-cultures/cello/cello-magick.lisp diff -u cell-cultures/cello/cello-magick.lisp:1.2 cell-cultures/cello/cello-magick.lisp:1.3 --- cell-cultures/cello/cello-magick.lisp:1.2 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/cello-magick.lisp Fri Oct 15 05:37:21 2004 @@ -26,8 +26,9 @@ (eval-when (compile load eval) (defmethod ix-layer-expand ((key (eql :wand)) &rest args) - `(progn ;; (cells::trc "ix-layer-expand draw wand for" self) - (ix-render-wand ,(car args) l-box)))) + `(let ((wand ,(car args))) + (cells::trc nil "ix-layer-expand draw wand for" self wand) + (ix-render-wand wand l-box)))) (def-c-output recording () (when old-value Index: cell-cultures/cello/cello.lisp diff -u cell-cultures/cello/cello.lisp:1.1 cell-cultures/cello/cello.lisp:1.2 --- cell-cultures/cello/cello.lisp:1.1 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/cello.lisp Fri Oct 15 05:37:21 2004 @@ -32,217 +32,7 @@ #:cl-opengl ) ;;; (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) - - (:export access-allowed resource-key-held accesscontrol focus-shared-by - ct-toggle-choice-controlaction - ct-zoomers zoom-step zoom-limit - make-foldertab ct-toggle-choice - ix-shadow client client-offset ^client-offset - ix-ensure-in-view-image - - ^parent-height ^parent-width - open-browser-with-file clipped turn-edit-active - content ^content caret-rect ^caret-rect edit-requires-activation edit-ip-compute - canvas text-font ^sel-rect ^text-font ix-string-width font-caret-height nres-to-res nr-offset - column-spacing pb cs-waiting-ex - lvalue-in-frame-h lvalue-in-frame-v - cttext-find-ip-fixed cttext-find-ip-variable - s-focuser wdw swdw focuser focus-text-mini focuser focus ^focus ^focused-on - ctl-handle-over focus-editactive-do ct-selector-stack ct-selector-row - mk-twisted-part mk-twisted do-virtual-key-functions selector - ix-bar-chart ix-detail key-evt ^key-evt initialselection-first - ix-canvas ix-canvas-nested ix-canvas-parent-sized ix-canvas-kid-sized s-canvas w-kill edit-requires-activation - ct-edit-caret ^textual-focus ^edit-active ix-edit-selection - ix-blob ix-dd-bitmap ig-splitter ix-icon - folder-tab-grid folder-tab - ct-tab-header ix-details ^details ix-details-column ix-details-column-ex column-specs ^column-specs - ct-fsm-assume-value fully-enabled markbox-frame associated-value - ct-polygon ct-scroll-rocker ct-scroll-pane igscroller ix-scroller-multi a-scroller ^scroll-stepv2 - ix-scroll-bar-hz ix-scroll-bar-vt ix-scroll-fill - ct-key-valued ct-details ct-icon - ^make-ix-detail-columns make-ix-details do-click - with-one-invalidation with-modality - canvas-to-screen-point canvas-to-screen-rect - nr-outset current-folder focus-minded - focus-lose focus-gain a-stack-of-kids - ^lbmax? ^lrmax? - inset-h inset-v openstate - row-padding wrap$ - inset outset with-window-message - ix-stack-of-kids - focus-debug - buttons-shifted gunscaled - kbd-modifiers ^kbd-modifiers - ll lt lr lb ^ll ^lt ^lr ^lb l-rect - l-height - ^prior-sib - l-width ^best-fit-targetres - px ^px *mouse-where* - py ^py - ^dd-bit-map - visible collapsed layers - ^visible ^collapsed ^layers - was-handled - - ^py-maintain-pt ^px-maintain-pl - ^centered-h? ^centered-v? - ^px-maintain-pr ^py-maintain-pb - ^lr-maintain-pr ^lr-width ^insetlr ^inset-width ^fillright ^fill-right-type ^fill-down ^inset-height - ^fill-parent-right ^fill-parent-down - - - ^prior-sib-pb ^cell-pr ^cell-width - - mk-gr g-offset g-offset-h g-offset-v offset-within - - ^inset-lb - ^lb-maintain-pb ^lb-height find-ix-under pr - colpadding all-cell-width ix-orientation-opposite - selection-set1 v2-xlate selection-set - do-gpprint - current-tab - ix-table - radio-on-name - - - frame :black :red - - focused-on focus-thickness focus ^focus focus-change - edit-active - focused-descendant focus-family focus-find-first ;; /// vestigial? - focus-navi-leave focus-navigate - tabstopp tab-mode - - ;;; userActivity ^userActivity - - multi-text cello-reset - - ix-text - ;----- - text$ ^text$ - char-mask ^char-mask - maxcharwidth ^maxcharwidth - justify-hz ^justify-hz justify-vt ^justify-vt - im-label - - ht-phrase - ^px-self-centered spacing-hz - ^py-self-centered - - ix-text-tall - ;--------- - text-height ^text-height - formatted$ ^formatted$ - - ix-family - ;------- - styles ^styles - effective-styles ^effective-styles - showkids ^showkids - kids-ever-shown ^kids-ever-shown - - ig-zero-tl ix-kid-sized im-matrix ix-oriented im-oriented-cell - ix-stack ig-row ix-row ix-row-flow ix-row-fv - - image ix-bits backpict ^backpict texturearrayinfo ^texturearrayinfo - im-pix-file - - target-res ^target-res - - ix-grid - ;----- - col-ct ^col-ct - all-cell-width ^all-cell-width - all-cell-height ^all-cell-height - row-offsets ^row-offsets - col-offsets ^col-offsets - row-justifys ^row-justifys - col-justifys ^col-justifys - html-to-parts - - ix-paint - - control - ;------ - click-evt ^click-evt ^in-drag - title$ ^title$ enabled ^enabled hilited ^hilited - control-do-action - - ct-button ct-check-text - - ct-drag - - ct-sizer ct-tab-stop - - ct-folder ix-folder - - ctfsm ct-mark-box ct-check-box ct-check-text ct-radio-button ct-radio - ct-reorienter ct-twister - ct-tab-stop-bar ^ix-orientation tabdefs ^tabdefs fixed ^fixed - - ct-selectable ^selected - - ct-exclusive ct-multi-choice - ct-label ct-label-multi-choice ct-label-exclusive - ct-text - user-text$ ^user-text$ - insertion-pt ^insertion-pt - ^caret sm-echo-caret - sel-end ^sel-end sel-rect ^sel-rect sel-range ^sel-range sm-echo-selrange - - ct-selector - selection ^selection - selection-focus ^selection-focus - - tree-view tv-node-directory - - ct-file-drawer drawer-values ^drawer-values ^selectedp - cell-col col-head cell-row row-head - - a-row a-stack - - states make-os-event-buttons-where no-echo-text - - mg-window-activate swindow window - - do-menu-right make-menu-right-items menu-right-select menu-shortc - - current-app-universal-time user-preferences - - getcurrentthread getthreadpriority setthreadpriority - getcurrentprocess getpriorityclass setpriorityclass - - alabel ac-make-font make-style - ix-tabbed-row a-tabbed-row archosw mg-system - tn-browser mktabheaders - - ;--- ooops --------- - make-tv-node - ^tick-count - tv-tree-node-type - context-cursor - do-virtual-key - ^folder-tab-title$ - tick-count - ctradio-turn-to - ix-folder-kids - ^focused-descendant - wants-caret - - ^fm-parent - ix-paint-string - pg-no - focus-on focus-get ix-ensure-in-view - user-pref-set user-pref ^user-pref user-pref-toggle - sampleprinter - do-double-click do-right-button - folder-tab-tab-view - mouse-pos ^mouse-pos mouse-image ^mouse-image - - progress-tracker status-text percent-complete *progress-stepper* - - - )) + ) (in-package :cello) Index: cell-cultures/cello/cello.lpr diff -u cell-cultures/cello/cello.lpr:1.2 cell-cultures/cello/cello.lpr:1.3 --- cell-cultures/cello/cello.lpr:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/cello.lpr Fri Oct 15 05:37:21 2004 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "6.2 [Windows] (May 12, 2004 22:13)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- (in-package :common-graphics-user) @@ -21,7 +21,6 @@ (make-instance 'module :name "ix-canvas.lisp") (make-instance 'module :name "ix-family.lisp") (make-instance 'module :name "font.lisp") - (make-instance 'module :name "ix-inline.lisp") (make-instance 'module :name "ix-grid.lisp") (make-instance 'module :name "mouse-click.lisp") (make-instance 'module :name "control.lisp") Index: cell-cultures/cello/ct-scroll-bar.lisp diff -u cell-cultures/cello/ct-scroll-bar.lisp:1.1 cell-cultures/cello/ct-scroll-bar.lisp:1.2 --- cell-cultures/cello/ct-scroll-bar.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ct-scroll-bar.lisp Fri Oct 15 05:37:21 2004 @@ -24,59 +24,53 @@ (defmodel ct-scroll-bar (control ix-inline) ((overflow :accessor overflow - :initform (c? (ecase (md-name self) - (:hz (/ (l-width (content .parent)) + :initform (c? (ecase (orientation self) + (:horizontal (/ (l-width (content .parent)) (l-width (kid1 .parent)))) - (:vt (/ (l-height (content .parent)) - (l-height (kid1 .parent))))))) + (:vertical (/ (l-height (content .parent)) + (l-height (kid1 .parent))))))) (pct-scrolled :reader pct-scrolled :initform (c? (md-value (find :sbar-slider (^kids) :key 'md-name)))) (scroll-handler :cell nil :initarg :scroll-handler :reader scroll-handler :initform (lambda (self scroll-pct) (let ((mgr (scroll-manager self))) - (ecase (md-name self) - (:hz (setf (px (content mgr)) + (ecase (orientation self) + (:horizontal (setf (px (content mgr)) (* scroll-pct (v2-h (scroll-max mgr))))) - (:vt (setf (py (content mgr)) + (:vertical (setf (py (content mgr)) (* scroll-pct (v2-v (scroll-max mgr))))))))) ) (:default-initargs ;;:pre-layer (with-layers +white+ :fill) :justify :center - :kids (c? (the-kids - (funcall (if (mac-p (upper self ix-scroller)) - 'identity 'nreverse) - (list (scroll-bar-slider (md-name self)) - (scroll-bar-stepper (md-name self) :home))) - (scroll-bar-stepper (md-name self) :end))) - :kid-slots (lambda (self) - (assert (eql :center (justify .parent))) - (ecase (md-name .parent) - (:hz (kid-slots-rowing)) - (:vt (kid-slots-stacking)))) - + :kids (c? (the-kids + (funcall (if (mac-p (upper self ix-scroller)) + 'identity 'nreverse) + (list (scroll-bar-slider (orientation self)) + (scroll-bar-stepper (md-name self) :home))) + (scroll-bar-stepper (md-name self) :end))) :visible (c? (> (^overflow) 1)) ;;:collapsed (c? (not (^visible))) - :px (c? (ecase (md-name self) - (:hz 0) - (:vt (px-maintain-pr (inset-lr .parent))))) - :py (c? (ecase (md-name self) - (:vt 0) - (:hz (py-maintain-pb (inset-lb .parent))))) + :px (c? (ecase (orientation self) + (:horizontal 0) + (:vertical (px-maintain-pr (inset-lr .parent))))) + :py (c? (ecase (orientation self) + (:vertical 0) + (:horizontal (py-maintain-pb (inset-lb .parent))))) :ll 0 :lt 0 - - :lr (c? (ecase (md-name self) - (:hz (- (inset-lr .parent) - (if (or (resize-range .parent) - (scrolls-p .parent :vt)) - *sbar-thickness* 0))) - (:vt *sbar-thickness*))) - :lb (c? (ecase (md-name self) - (:vt (+ (inset-lb .parent) - (if (or (resize-range .parent) - (scrolls-p .parent :hz) ) - (ups *sbar-thickness*) 0))) - (:hz (downs *sbar-thickness*)))))) + + :lr (c? (ecase (orientation self) + (:horizontal (- (inset-lr .parent) + (if (or (resize-range .parent) + (scrolls-p .parent :vertical)) + *sbar-thickness* 0))) + (:vertical *sbar-thickness*))) + :lb (c? (ecase (orientation self) + (:vertical (+ (inset-lb .parent) + (if (or (resize-range .parent) + (scrolls-p .parent :horizontal) ) + (ups *sbar-thickness*) 0))) + (:horizontal (downs *sbar-thickness*)))))) (def-c-output pct-scrolled () @@ -88,7 +82,8 @@ (defun scroll-bar-slider (hz-vt-value) (macrolet ((hz-vt (hz-form vt-form) `(ecase hz-vt-value - (:hz ,hz-form)(:vt ,vt-form)))) + (:horizontal ,hz-form) + (:vertical ,vt-form)))) (make-instance 'ix-slider :md-name :sbar-slider :md-value-fn (lambda (pct) @@ -165,7 +160,7 @@ (* 4 *scroll-stepper-r*)))))))) (defmethod ix-paint ((self ix-slider)) - #+not (when (eql :vt (md-name .parent)) + #+not (when (eql :vertical (md-name .parent)) (trc "slider px" (^px)) (trc "slider py" (^py)) (trc "slider ll" (^ll)) @@ -194,7 +189,7 @@ (:home ,home-form)(:end ,end-form))) (hz-vt (hz-form vt-form) `(ecase hz-vt-value - (:hz ,hz-form)(:vt ,vt-form)))) + (:horizontal ,hz-form)(:vertical ,vt-form)))) (make-instance 'ct-button :md-name home-end-value :ll (- *scroll-stepper-r*) :lt (ups *scroll-stepper-r*) Index: cell-cultures/cello/ct-scroll-pane.lisp diff -u cell-cultures/cello/ct-scroll-pane.lisp:1.1 cell-cultures/cello/ct-scroll-pane.lisp:1.2 --- cell-cultures/cello/ct-scroll-pane.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ct-scroll-pane.lisp Fri Oct 15 05:37:21 2004 @@ -28,7 +28,7 @@ slider trench prettied up |# -(defmodel ct-scroll-manager (focus control ig-zero-tl) +(defmodel ct-scroll-manager (focus control ix-zero-tl) ((content :initform nil :initarg :content :accessor content) (step-x :initform (u96ths 12) :initarg :step-x :accessor step-x) (step-y :initform (u96ths 12) :initarg :step-y :accessor step-y) @@ -56,7 +56,7 @@ (defconstant *sbar-thickness* 16) -(defmodel ix-scroller (ct-scroll-manager ig-zero-tl) +(defmodel ix-scroller (ct-scroll-manager ix-zero-tl) ((mac-p :initarg :mac-p :initform t :reader mac-p) (scroll-bars :cell nil :initform nil :initarg :scroll-bars :accessor scroll-bars) (resizeable :cell nil :initform nil :initarg :resizeable :accessor resizeable) @@ -84,11 +84,11 @@ :ll 0 :lt 0 :px 0 :py 0 :lr (c? (- (inset-lr .parent) - 2 (if (scrolls-p .parent :vt) + 2 (if (scrolls-p .parent :vertical) *sbar-thickness* 0))) :lb (c? (+ (inset-lb .parent) (ups 2) - (if (scrolls-p .parent :hz) + (if (scrolls-p .parent :horizontal) (ups *sbar-thickness*) 0))) :step-x (c? (step-x .parent)) :step-y (c? (step-y .parent))) @@ -103,7 +103,8 @@ :drag-range (c? (resize-range .parent)))) (mapcar (lambda (bar-id) (make-instance 'ct-scroll-bar - :md-name bar-id)) + :md-name bar-id + :orientation bar-id)) (scroll-bars self)))))) (defmacro uskin () Index: cell-cultures/cello/ctl-drag.lisp diff -u cell-cultures/cello/ctl-drag.lisp:1.1 cell-cultures/cello/ctl-drag.lisp:1.2 --- cell-cultures/cello/ctl-drag.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-drag.lisp Fri Oct 15 05:37:21 2004 @@ -65,9 +65,9 @@ ;;;(defmethod context-cursor ((self CTDrag) kbdModifiers) ;;; (declare (ignore kbdmodifiers)) ;;; (ecase (dragdirection self) -;;; (:hz GLUT_CURSOR_LEFT_RIGHT) -;;; (:vt GLUT_CURSOR_UP_DOWN) -;;; (:hz-vt GLUT_CURSOR_CROSSHAIR))) +;;; (:horizontal GLUT_CURSOR_LEFT_RIGHT) +;;; (:vertical GLUT_CURSOR_UP_DOWN) +;;; (:horizontal-vt GLUT_CURSOR_CROSSHAIR))) (defmodel ct-poly-drag (ct-drag ix-polygon)()) Index: cell-cultures/cello/ctl-markbox.lisp diff -u cell-cultures/cello/ctl-markbox.lisp:1.1 cell-cultures/cello/ctl-markbox.lisp:1.2 --- cell-cultures/cello/ctl-markbox.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-markbox.lisp Fri Oct 15 05:37:21 2004 @@ -101,20 +101,22 @@ (defmodel ct-radio-button (ct-mark-box ct-radio-item) ()) (defmodel ct-text-radio-item ( ct-radio-item ct-text)()) -(defmodel ct-radio (ix-family) +(defmodel ct-radio (ix-inline) () (:default-initargs :md-value (c-in nil))) -(defmodel ct-radio-row (ix-row ct-radio) +(defmodel ct-radio-row (ct-radio) () (:default-initargs + :orientation :horizontal :md-value (c-in nil))) -(defmodel ct-radio-stack (ix-stack ct-radio) +(defmodel ct-radio-stack (ct-radio) () (:default-initargs - :md-value (c-in nil))) + :md-value (c-in nil) + :orientation :vertical)) (defun radio-on-name (radio-values) (some (lambda (rb-value) @@ -186,8 +188,7 @@ (trc "rendering radio-push" :unscissored))) (call-next-method)) -(defmodel ct-push-toggle (ct-radio-push-button) +(defmodel ct-push-toggle (ct-toggle ct-button) () (:default-initargs - :md-value (c-in nil) - :radio (c? self))) \ No newline at end of file + :md-value (c-in nil))) \ No newline at end of file Index: cell-cultures/cello/ctl-selectable.lisp diff -u cell-cultures/cello/ctl-selectable.lisp:1.1 cell-cultures/cello/ctl-selectable.lisp:1.2 --- cell-cultures/cello/ctl-selectable.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-selectable.lisp Fri Oct 15 05:37:21 2004 @@ -26,23 +26,22 @@ (defmodel ct-selector () ;; mixin at any node containing CTSelectable's - ((selection :accessor selection :initarg :selection) + ((selection :initform (c-in nil) :accessor selection :initarg :selection) (selection-focus :initarg :selection-focus :reader selection-focus :initform nil) (initial-selection :initform nil :reader initial-selection :cell nil :initarg :initial-selection) - ) - (:default-initargs - :selection (c-in nil) - )) + (multiple-choice-p :initform nil :initarg :multiple-choice-p :accessor multiple-choice-p) + (togglep :initform nil :initarg :togglep :accessor togglep) + )) (defmethod sm-unchanged-p ((self ct-selector) (slotname (eql 'selection)) new-value old-value) (equal new-value old-value)) -(defun initialselection-first (self) +(defun initial-selection-first (self) (do-like-fm-parts (it (self ct-selectable)) (when (enabled it) - (return-from initialselection-first (list it))))) + (return-from initial-selection-first (list it))))) (defmethod md-awaken :after ((self ct-selector)) (when (initial-selection self) @@ -50,11 +49,7 @@ (setf (selection self) (eko ("setting initial selection" self) (funcall (initial-selection self) self)))))) -(def-c-output selection ()) - -(defmodel ct-selector-stack (ct-selector ix-stack)()) -(defmodel ct-exclusive-stack (ct-exclusive ix-stack)()) -(defmodel ct-selector-row (ct-selector ix-row)()) +(defmodel ct-selector-inline (ct-selector ix-inline)()) ;---------- @@ -75,83 +70,41 @@ (:default-initargs :outset (u8ths 1))) -#+test? -(def-c-output kids ((self ct-details)) - ;(trc "ctdetails kids echo" newvalue oldvalue) - ) - (defmodel ct-details-exclusive (ct-exclusive ct-details)()) ;; go generic with CTSelectorNested? (defmodel ct-selectable (control) ((selectedp :initarg :selectedp - :initform (c? (bwhen (selector (selector self)) - (member self (selection selector)))) - :reader selectedp)) + :initform (c? (bwhen (selector (selector self)) + (member (^md-value) (selection selector)))) + :reader selectedp)) (:default-initargs - :bkg-color (c? (if (^enabled) - (if (^hilited) - +blue+ - (if (^selectedp) - +yellow+ - +white+)) - +lt-gray+)) - :pre-layer (with-layers (:rgba (^bkg-color)) - :fill - +black+))) +;;; nah, no image behavior here. put in mixin if desired +;;; :bkg-color (c? (if (^enabled) +;;; (if (^hilited) +;;; +blue+ +;;; (if (^selectedp) +;;; +yellow+ +;;; +white+)) +;;; +lt-gray+)) +;;; :pre-layer (with-layers (:rgba (^bkg-color)) +;;; :fill +;;; +black+) + :ct-action (lambda (self event + &aux + (buttons (evt-buttons event)) + (selector (selector self)) + (selection (selection selector)) + (value (^md-value)) + (now-selected (member value selection))) + (if (multiple-choice-p selector) + (if now-selected + (when (or (togglep selector) + (shift-key-down buttons)) + (selection-set selector (remove value selection))) + (selection-set selector (cons value selection))) + (unless now-selected + (selection-set selector value)))))) (defun selector (self) (upper self ct-selector)) -;===================================== - -(defmodel ct-exclusive (ct-selectable) - () - (:default-initargs - :ct-action #'ct-exclusive-control-action)) - -(defmethod ct-exclusive-control-action (self event) - (declare (ignorable event)) - - (with-metrics (nil nil (nil :type :time #+not :count-only #+not :space - ;; :count 2000 - :interpret-closures t - ;; :count-list (list #'md::bd-bound-slot-value) - ) "CTExclusive-controlAction") - (selection-set1 (selector self) self))) - -;===================================== - -(defmodel ct-multi-choice (ct-selectable) - () - (:default-initargs - :ct-action (lambda (self event - &aux - (buttons (evt-buttons (os-event event))) - (selector (selector self)) - (selection (selection selector))) - (selection-set selector - (if (shift-key-down buttons) - (if (member self selection) - (delete self selection) - (cons self selection)) - (list self)))))) - -;===================================== - -(defmodel ct-toggle-choice (ct-toggle ct-selectable) - () - (:default-initargs - :ct-action #'ct-toggle-choice-controlaction)) - -(defmethod ct-toggle-choice-controlaction (self event - &aux - (buttons (evt-buttons (os-event event))) - (selector (selector self)) - (selection (selection selector))) - (trc "controlaction toggle" self) - (selection-set selector - (if (member self selection) - (remove self selection) - (if (shift-key-down buttons) - (cons self selection) - (list self))))) Index: cell-cultures/cello/ctl-toggle.lisp diff -u cell-cultures/cello/ctl-toggle.lisp:1.1 cell-cultures/cello/ctl-toggle.lisp:1.2 --- cell-cultures/cello/ctl-toggle.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-toggle.lisp Fri Oct 15 05:37:21 2004 @@ -40,17 +40,18 @@ ((inset :unchanged-if 'v2= :initform (mkv2 (upts 4) (upts 4))) (depressed :initarg :depressed :reader depressed :initform (c? (^hilited)))) (:default-initargs + :title$ (c? (string-capitalize (md-name self))) :text$ (c? (^title$)) :clipped t :justify-hz :center :justify-vt :center :style-id :button :skin (c? (skin .w.)) + :text-color (c? (if (^depressed) + +dk-gray+ +white+)) :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) (defl (if (^depressed) (downs (/ thick 3)) 0)) - (push-in (if (^depressed) (xlout (* .5 thick)) 0)) - (tx-color (if (^depressed) - +dk-gray+ +white+))) + (push-in (if (^depressed) (xlout (* .5 thick)) 0))) (declare (ignorable thick defl)) (trc nil "ctbutton" thick defl) @@ -60,7 +61,9 @@ :on (:frame-3d :edge-raised :thickness thick) - (:rgba tx-color)))))) + (:rgba (^text-color))))))) + +(defmodel ct-selectable-button (ct-selectable ct-button)()) ; ---------------- CT FSM --------------------- (defmodel ctfsm (control) @@ -116,7 +119,7 @@ (defmacro mk-twisted (twisted-name (label-class &rest label-args) (twisted-class &rest twisted-args)) - `(mk-part :twisted-group (ig-zero-tl) + `(mk-part :twisted-group (ix-zero-tl) :showkids (c-in nil) :ll (c? (ix-kid-wrap self 'pl)) :lr (c? (ix-kid-wrap self 'pr)) @@ -145,7 +148,7 @@ (defmacro mk-twisted-part (twisted-name (label$ &rest label-args) twisted-part) - `(mk-part :twisted-group (ig-zero-tl) + `(mk-part :twisted-group (ix-zero-tl) :showkids (c-in nil) :ll (c? (ix-kid-wrap self 'pl)) :lr (c? (ix-kid-wrap self 'pr)) Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.4 cell-cultures/cello/image.lisp:1.5 --- cell-cultures/cello/image.lisp:1.4 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/image.lisp Fri Oct 15 05:37:21 2004 @@ -45,8 +45,6 @@ (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) (trc nil "starting display list" display-list-name self) (let ((*ogl-listing-p* self) @@ -97,6 +95,7 @@ ; ; appearance ; + (gui-styles :initarg :gui-styles :initform nil :accessor gui-styles) (sound :initarg :sound :initform nil :accessor sound) ; (lighting :initarg :lighting :initform nil :accessor lighting) @@ -126,10 +125,20 @@ (:default-initargs :renderer 'ix-paint )) -(defmethod ogl-dsp-list-prep progn ((self image)) - (skin self)) +(defmethod md-awaken :after ((self image)) + (assert (px self)) + (assert (py self)) + (assert (ll self)) + (assert (lt self)) + (assert (lr self)) + (assert (lb self))) + +(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)) ;------------------------------ (def-c-output mouse-over-p () Index: cell-cultures/cello/ix-family.lisp diff -u cell-cultures/cello/ix-family.lisp:1.1 cell-cultures/cello/ix-family.lisp:1.2 --- cell-cultures/cello/ix-family.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-family.lisp Fri Oct 15 05:37:21 2004 @@ -31,7 +31,7 @@ (effective-styles :reader effective-styles :initarg :effective-styles :initform nil #+not (ix-family-effective-styles)) - (outset :cell nil :initarg :outset :initform 0 :accessor outset) + (outset :initarg :outset :initform 0 :accessor outset) (showkids :initarg :showkids :initform nil :accessor showkids) (kids-ever-shown @@ -48,7 +48,7 @@ ;;-------- ZeroTL ---------------------------- ;; -(defmodel ig-zero-tl (ix-family) +(defmodel ix-zero-tl (ix-family) () (:default-initargs :ll (c? (- (outset self))) @@ -69,32 +69,76 @@ :lr (c? (ix-kid-wrap self 'pr)) :lb (c? (ix-kid-wrap self 'pb)))) -;----------- OfKids ----------------------- +;--------------- ix-inline ----------------------------- ; -(defmacro smkidp (outset-optr min-max attribute) - `(c? (,outset-optr - (if (^kids) - (with-dynamic-fn (roomy (kid) (not (collapsed kid))) - (,min-max ,attribute - :test roomy)) - 0) - (outset self)))) + +(defmodel ix-inline (ix-zero-tl) + ((orientation :initarg :orientation :initform nil :accessor orientation + :documentation ":vertical (for a column) or :horizontal (row)") + (justify :initarg :justify :accessor justify + :initform (c? (ecase (orientation self) + (:vertical :left) + (:horizontal :top)))) + (spacing :initarg :spacing :initform 0 :accessor spacing)) + (:default-initargs + :lr (c? (+ (^outset) + (ecase (orientation self) + (:vertical (loop for k in (^kids) + maximizing (l-width k))) + (:horizontal (bif (lk (last1 (^kids))) + (pr lk) 0))))) + :lb (c? (+ (downs (^outset)) + (ecase (orientation self) + (:vertical (bif (lk (last1 (^kids))) + (pb lk) 0)) + (:horizontal (downs (loop for k in (^kids) + maximizing (l-height k))))))) + :kid-slots (lambda (self) + (ecase (orientation .parent) + (:vertical (list + (mk-kid-slot (px :if-missing t) + (c? (^px-self-centered (justify .parent)))) + (mk-kid-slot (py) + (c? (py-maintain-pt + (^prior-sib-pb self (spacing .parent))))))) + (:horizontal (list + (mk-kid-slot (py :if-missing t) + (c? (^py-self-centered (justify .parent)))) + (mk-kid-slot (px) + (c? (px-maintain-pl + (^prior-sib-pr self (spacing .parent))))))))))) + +(defmodel ix-stack (ix-inline) + () + (:default-initargs + :orientation :vertical)) + +(defmodel ix-row (ix-inline) + () + (:default-initargs + :orientation :horizontal)) +(defmacro a-stack ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'a-stack) (ix-inline) + ,@stack-args + :orientation :vertical + :kids (c? (packed-flat! ,@dd-kids)))) -(defun v2-in-subframe (super h v sub) - (if (eql super sub) ;; bingo - (values h v) - (dolist (kid (kids super)) - (multiple-value-bind (subh sub-v) - (v2-in-subframe kid h v sub) - (when subh - (return-from v2-in-subframe (values (- subh (px kid)) - (- sub-v (py kid))))))))) +(defmacro a-row ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'a-stack) (ix-inline) + ,@stack-args + :orientation :horizontal + :kids (c? (packed-flat! ,@dd-kids)))) + +#| archive + +(defmodel ix-row-fv (family-values ix-row)()) +(defmodel ix-inline-fv (family-values ix-inline)()) ;-------------------------- IMMatrix ------------------------------------------ -(defmodel im-matrix (ig-zero-tl) +(defmodel im-matrix (ix-zero-tl) ((columns :cell nil :initarg :columns :initform nil :accessor columns) (indent-hz :cell nil :initarg :indent-hz :initform 0 :accessor indent-hz) (spacing-hz :cell nil :initarg :spacing-hz :initform 0 :accessor spacing-hz) @@ -121,3 +165,28 @@ (pt psib)) 0)))))))) +;--------------- IGRowFlow ---------------------------- + +(defmodel ix-row-flow (ix-row) + ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) + (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) + (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) + (:default-initargs + :lb (c? (ix-kid-wrap self 'pb)) + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (py) + (c? (py-maintain-pt + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)) (l-width .parent)) + (^prior-sib-pb self (spacing-vt .parent)) + (^prior-sib-pt self)))))) + (mk-kid-slot (px) + (c? (px-maintain-pl + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)) (l-width .parent)) + 0 + ph))))))))) + +|# \ No newline at end of file Index: cell-cultures/cello/ix-geometry.lisp diff -u cell-cultures/cello/ix-geometry.lisp:1.2 cell-cultures/cello/ix-geometry.lisp:1.3 --- cell-cultures/cello/ix-geometry.lisp:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/ix-geometry.lisp Fri Oct 15 05:37:21 2004 @@ -66,6 +66,18 @@ (incf ,offset-h (px ,from)) (incf ,offset-v (py ,from)))))) +;----------- OfKids ----------------------- +; + +(defun v2-in-subframe (super h v sub) + (if (eql super sub) ;; bingo + (values h v) + (dolist (kid (kids super)) + (multiple-value-bind (subh sub-v) + (v2-in-subframe kid h v sub) + (when subh + (return-from v2-in-subframe (values (- subh (px kid)) + (- sub-v (py kid))))))))) (defun mk-gr (ap) (c-assert ap) (count-it :mk-gr) Index: cell-cultures/cello/ix-grid.lisp diff -u cell-cultures/cello/ix-grid.lisp:1.1 cell-cultures/cello/ix-grid.lisp:1.2 --- cell-cultures/cello/ix-grid.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-grid.lisp Fri Oct 15 05:37:21 2004 @@ -24,7 +24,7 @@ (defmacro u-grid () `(fm-parent self)) -(defmodel ix-grid (ig-zero-tl) +(defmodel ix-grid (ix-zero-tl) ((col-ct :initarg :col-ct :initform nil :accessor col-ct) (row-ct :initarg :row-ct :initform nil :accessor row-ct) ; Index: cell-cultures/cello/ix-inline.lisp diff -u cell-cultures/cello/ix-inline.lisp:1.1 cell-cultures/cello/ix-inline.lisp:1.2 --- cell-cultures/cello/ix-inline.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-inline.lisp Fri Oct 15 05:37:21 2004 @@ -21,123 +21,3 @@ ;;; IN THE SOFTWARE. (in-package :cello) - -;--------------- ix-inline ----------------------------- -; - -(defmodel ix-inline (ig-zero-tl) - ((justify :cell nil :initarg :justify :initform nil :accessor justify) - (spacing :cell nil :initarg :spacing :initform 0 :accessor spacing))) - -;--------------- Stacks ------------------------------ -; - - -(defmodel ix-stack (ix-inline) - () - (:default-initargs - :lr (c? (^lr-width (+ (or (loop for k in (^kids) - maximizing (l-width k)) - 0) - (outset self)))) - :lb (c? (+ (downs (outset self)) - (bif (lk (last1 (^kids))) - (pb lk) 0))) - :justify :left - :kid-slots (lambda (self) - (declare (ignore self)) - (kid-slots-stacking)))) - -(defun kid-slots-stacking () - (list - (mk-kid-slot (px :if-missing t) - (c? (^px-self-centered (justify .parent)))) - (mk-kid-slot (py) - (c? (py-maintain-pt - (^prior-sib-pb self (spacing .parent))))))) - -(defmodel ix-stack-of-kids (ix-stack) - () - (:default-initargs - :ll (c? (- (or (loop for k in (^kids) - minimizing (pl k)) - 0) - (outset self))) - :lr (c? (+ (or (loop for k in (^kids) - maximizing (pr k)) - 0) - (outset self))) - :lb (c? (+ (downs (outset self)) - (bif (lk (last1 (^kids))) - (pb lk) 0))) - :justify :left)) - -(defmacro a-stack ((&rest stack-args) &body dd-kids) - `(mk-part ,(copy-symbol 'a-stack) (ix-stack) - ,@stack-args - :kids (c? (packed-flat! ,@dd-kids)))) - -(defmacro a-stack-of-kids ((&rest stack-args) &body dd-kids) - `(mk-part ,(copy-symbol 'a-stack) (ix-stack-of-kids) - ,@stack-args - :kids (c? (packed-flat! ,@dd-kids)))) - - - -;----------------------- IXRow ------------------------------ -; - - -(defmodel ix-row (ix-inline) - () - (:default-initargs - :ll (c? (- (outset self))) - :lt (c? (ups (outset self))) - :lb (c? (downs (outset self) (^lb-height (fm-max-kid self 'l-height)))) - :lr (c? (+ (outset self) (bif (lk (last1 (^kids))) - (pr lk) 0))) - :justify :top - :kid-slots (lambda (self) - (declare (ignore self)) - (kid-slots-rowing)))) - -(defun kid-slots-rowing () - (list - (mk-kid-slot (py :if-missing t) - (c? (^py-self-centered (justify .parent)))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (^prior-sib-pr self (spacing .parent))))))) - -(defmodel ix-row-fv (family-values ix-row)()) -(defmodel ix-stack-fv (family-values ix-stack)()) -;--------------- IGRowFlow ---------------------------- - -(defmodel ix-row-flow (ix-row) - ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) - (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) - (:default-initargs - :lb (c? (ix-kid-wrap self 'pb)) - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (py) - (c? (py-maintain-pt - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - (^prior-sib-pb self (spacing-vt .parent)) - (^prior-sib-pt self)))))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - 0 - ph))))))))) - -(defmacro a-row ((&rest row-args) &body dd-kids) - `(mk-part ,(copy-symbol 'a-row) (ix-row) - ,@row-args - :spacing 0 - :kids (c? (packed-flat! ,@dd-kids)))) - Index: cell-cultures/cello/ix-render.lisp diff -u cell-cultures/cello/ix-render.lisp:1.3 cell-cultures/cello/ix-render.lisp:1.4 --- cell-cultures/cello/ix-render.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/ix-render.lisp Fri Oct 15 05:37:21 2004 @@ -81,6 +81,7 @@ (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)) (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0) Index: cell-cultures/cello/ix-styled.lisp diff -u cell-cultures/cello/ix-styled.lisp:1.2 cell-cultures/cello/ix-styled.lisp:1.3 --- cell-cultures/cello/ix-styled.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/ix-styled.lisp Fri Oct 15 05:37:21 2004 @@ -69,10 +69,10 @@ (defun styles-default () *styles*) -(defun gui-style (style) +(defun gui-style (self style) (when style ;;(print `(gui-style ,style ,(styles-default))) - (or (find style (styles-default) :key 'id) + (or (ix-find-style self style) (find :default (styles-default) :key 'id) (break "gui-style cannot find requested style ~a" style)))) @@ -81,7 +81,7 @@ :initform nil :reader style-id) - (style :initform (c? (gui-style (^style-id))) + (style :initform (c? (gui-style self (^style-id))) :initarg :style :reader style) @@ -102,6 +102,13 @@ (with-layers (:rgba (^text-color))))))) +(defmethod ix-find-style ((self image) style-id) + (or (find style-id (^gui-styles) :key 'id) + (ix-find-style .parent style-id))) + +(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) @@ -110,18 +117,7 @@ (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$))) - ) + (ix-string-width self (^display-text$)))) (ftgl::ftgl-get-display-font font)) (defmethod make-style-font ((style gui-style-glut-stroke)) Index: cell-cultures/cello/menu.lisp diff -u cell-cultures/cello/menu.lisp:1.1 cell-cultures/cello/menu.lisp:1.2 --- cell-cultures/cello/menu.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/menu.lisp Fri Oct 15 05:37:21 2004 @@ -34,12 +34,14 @@ :pre-layer (with-layers +lt-gray+ :fill) :kids (c? (mapcar #'make-menu menus)))) -(defmodel ct-menu (control ix-styled ix-stack) +(defmodel ct-menu (control ix-styled ix-inline) ((items :initarg :items :reader items :initform nil)) (:default-initargs + :orientation :vertical :style-id :button :kids (c? (the-kids - (mk-part :title-items (ix-stack) + (mk-part :title-items (ix-inline) + :orientation :vertical :kids (c? (the-kids (mk-part :title (ix-text) :lighting :off @@ -63,9 +65,10 @@ -(defmodel ct-menu-items (ix-stack window) +(defmodel ct-menu-items (ix-inline window) () (:default-initargs + :orientation :vertical :self-sizing t :lighting :off :outset (u96ths 4) Index: cell-cultures/cello/pick.lisp diff -u cell-cultures/cello/pick.lisp:1.2 cell-cultures/cello/pick.lisp:1.3 --- cell-cultures/cello/pick.lisp:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/pick.lisp Fri Oct 15 05:37:21 2004 @@ -58,7 +58,7 @@ ;;(format t "~&perspective sees aspect: ~a" aspect) (glu-perspective 45 aspect 0.1 100.0)) ;;OQ: appropriate for ortho? - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) #+not (let ((*ogl-listing-p* target) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) @@ -69,7 +69,7 @@ (gl-matrix-mode gl_projection) (gl-pop-matrix) - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (let ((hits (gl-render-mode gl_render))) (print `(:hits ,hits)) Index: cell-cultures/cello/to-do.lisp diff -u cell-cultures/cello/to-do.lisp:1.1 cell-cultures/cello/to-do.lisp:1.2 --- cell-cultures/cello/to-do.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/to-do.lisp Fri Oct 15 05:37:21 2004 @@ -6,17 +6,11 @@ in not-to-be of Window, free os font stuff -do up a display lists slot, maybe now rather than later. read up on efficiency, -and see how deep one can go allocating display lists - when that is done, worry about not leaking foreign-allocated data look at more helpers like with-matrix, and auto-normal, and auto-detecting functions not meant to be called within begin/end -look at a lighting preview control, xyz with sliders for positioning, -sliders for ambient and diffuse - double-clicks mousedown in w, mouseup out, mmosemove back in, click still alive [glut says they fix this] @@ -31,8 +25,6 @@ get ctdrag working on :vt and both and an arbitrary (for things like z) do a polar coordinate dragger for rotation - -lights (and lighting) should be slots in MGWindow, and lights pulled in as kids of the window toggling nested off in starter-w does not redraw unchecked, tho simple cover/uncover works Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.3 cell-cultures/cello/window-callbacks.lisp:1.4 --- cell-cultures/cello/window-callbacks.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/window-callbacks.lisp Fri Oct 15 05:37:21 2004 @@ -84,33 +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 *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox + (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)) (bif (dl (dsp-list self)) - (gl-call-list (dsp-list self)) + (progn + (trc nil "window using disp list") + (gl-call-list (dsp-list self))) (ix-paint self)) (glut-swap-buffers) - (incf (frame-ct self)) (trc nil "window-display > rendered w " self (glutgetwindow)) + (incf (frame-ct self)) (when (display-continuous self) (trc nil "window-display > continuous specified so posting redisplay" self) (glut-post-redisplay))) Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.3 cell-cultures/cello/window.lisp:1.4 --- cell-cultures/cello/window.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/window.lisp Fri Oct 15 05:37:21 2004 @@ -81,6 +81,7 @@ :initform 0 :accessor gl-name-highest)) (:default-initargs + :px 0 :py 0 :kids (c? (the-kids (^content)) #+not (the-kids (mk-part :wstuff (ix-kid-sized) :px 0 :py (c? (bif (n (nsib)) @@ -386,19 +387,18 @@ (defmethod 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 nil "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) + (trc "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) + (trc nil "mg-window-reshape > new window wid,hei:" self width height) +;;; (gl-load-identity) (setf (lr self) (+ (ll self) (scr2log width))) (setf (lb self) (- (lt self) (scr2log height)))) - - (defun run-window (new-window &optional run-init-func) (when run-init-func (funcall run-init-func)) @@ -416,34 +416,27 @@ (bwhen (s (ix-sound-find new-window :open)) (ix-sound-install new-window s)) - #+nah (do () - ((or (c-stopped) - (zerop (glut-get-window)))) - ;;(format t "before main loop ~a | ~&" (glut-get-window)) - (progn ;; with-render-lock ((glut-get-window)) - (glutmainloopevent)) - (sleep 0.1) - ) (handler-bind ((error #'(lambda (c) (print `(bingo glut leave ,c)) (c-stop :top-handler) (glut-leave-main-loop)))) + #+fasterbutcannotbreak (glutmainloop) - #+nah ;; before re-enabling wotk out how to get idel func called if present + ;; before re-enabling wotk out how to get idle func called if present + ;;#+breakable (do () ((or (c-stopped) (zerop (glut-get-window)))) ;;(format t "before main loop ~a | ~&" (glut-get-window)) - (progn ;; with-render-lock ((glut-get-window)) - (glutmainloopevent) - ) - (sleep 0.1))))) + (glutmainloopevent) + (setf (tick-count new-window) (os-tickcount)) + (sleep 0.05))))) (defmethod ix-paint :around ((self window)) (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) - (trc nil "paint> win ortho! l r b t n f:" + (trc "paint> win ortho! l r b t n f:" (ll self)(lr self) (lb self)(lt self) *mgw-near* *mgw-far*) @@ -454,7 +447,7 @@ *mgw-far* ))) (projection) - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (gl-load-identity) (gl-light-modeli gl_light_model_two_side 0)