October 2004 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lisp cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/hedron-decoration.lisp cell-cultures/cellodemo/hedron-render.lisp cell-cultures/cellodemo/light-panel.lisp cell-cultures/cellodemo/tutor-geometry.lisp
by Kenny Tilton 15 Oct '04

15 Oct '04

Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv28025/cellodemo Modified Files: cellodemo.lisp demo-window.lisp hedron-decoration.lisp hedron-render.lisp light-panel.lisp tutor-geometry.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:31 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lisp diff -u cell-cultures/cellodemo/cellodemo.lisp:1.2 cell-cultures/cellodemo/cellodemo.lisp:1.3 --- cell-cultures/cellodemo/cellodemo.lisp:1.2 Fri Oct 1 06:01:10 2004 +++ cell-cultures/cellodemo/cellodemo.lisp Fri Oct 15 05:37:30 2004 @@ -37,7 +37,7 @@ (demo-image-subdir subdir))) (defun ft-jpg () - (mk-part :ft-jpg (ig-zero-tl) + (mk-part :ft-jpg (ix-zero-tl) :px 0 :py 0 :kids (c? (the-kids (a-row (:px 96 :py (downs 96)) Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.3 cell-cultures/cellodemo/demo-window.lisp:1.4 --- cell-cultures/cellodemo/demo-window.lisp:1.3 Fri Oct 1 06:01:10 2004 +++ cell-cultures/cellodemo/demo-window.lisp Fri Oct 15 05:37:30 2004 @@ -26,6 +26,7 @@ (defun cello-test () (let ((cells::*c-debug* (get-internal-real-time))) (run-stylish-demos '(light-panel ft-jpg tu-geo ftgl-test demo-scroller) + ;;'tu-geo 'light-panel :skin (c? (wand-ensure-typed 'wand-texture (car (md-value (fm-other :texture-picker))))) @@ -35,9 +36,9 @@ :lb (c-in (downs 650))))) (defun demo-scroller () - (mk-part :demo-scroller (ig-zero-tl) + (mk-part :demo-scroller (ix-zero-tl) :kids (c? (list - (mk-part :dialog (ig-zero-tl) + (mk-part :dialog (ix-zero-tl) :px 48 :py -48 :outset (u8ths 2) :skin (c? (wand-ensure-typed 'wand-texture @@ -58,7 +59,7 @@ (mk-part :scroller (ix-scroller) :px 0 :py 0 :mac-p t - :scroll-bars '(:hz :vt) + :scroll-bars '(:horizontal :vertical) :start-size (mkv2 (u96ths 150)(u96ths (downs 250))) :resizeable t :content (c? (mk-part :gview (ix-image-file) @@ -164,7 +165,7 @@ :kids (c? (the-kids (demo-window-beef) #+nicetry - (mk-part :wintop (ig-zero-tl) + (mk-part :wintop (ix-zero-tl) :px 0 :py 0 :ll 0 :lt 0 :lr (c? (l-width .parent)) :lb (c? (downs (l-height .parent))) @@ -191,7 +192,7 @@ (when (recording node) (ix-snapshot node (recordingp node)))))) -(defmethod not-to-be :after ((self demo-window)) +(defmethod not-to-be :after ((self window)) (unless (kids *sys*) (cl-openal-shutdown)) (wands-clear)) @@ -203,13 +204,14 @@ (wav-play-till-end nil (car (sound-paths s))))) (defun demo-window-beef () - (mk-part :beef (ix-stack) + (mk-part :beef (ix-inline) + :orientation :vertical :px 0 :py (u8ths (downs 1)) :spacing (u8ths 1) :lb (c? (^fill-parent-down)) :kids (c? (the-kids (demo-control-panel) - (mk-part :demos (ig-zero-tl) + (mk-part :demos (ix-zero-tl) ;;:py (u8ths 4) :lb (c? (^fill-parent-down)) :kid-slots (lambda (self) @@ -231,7 +233,7 @@ (defun demo-control-panel () (a-row (:spacing (u8ths 2) :justify :center) - (mk-part :rate (frame-rate-text)) + #+shh (mk-part :rate (frame-rate-text)) (a-stack (:spacing (u16ths 1)) (texture-picker) (demo-picker)) @@ -330,7 +332,8 @@ :glut-id glut_bitmap_8_by_13) :pre-layer (with-layers +red+) :text$ (c? (string (class-name (md-value .parent))))) - (mk-part :subks (ix-stack) + (mk-part :subks (ix-inline) + :orientation :vertical :kids (c? (loop for subk in (class-direct-subclasses (md-value .parent)) collecting (mk-part :sub (proctor-class) :md-value subk)))))))) Index: cell-cultures/cellodemo/hedron-decoration.lisp diff -u cell-cultures/cellodemo/hedron-decoration.lisp:1.2 cell-cultures/cellodemo/hedron-decoration.lisp:1.3 --- cell-cultures/cellodemo/hedron-decoration.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/hedron-decoration.lisp Fri Oct 15 05:37:30 2004 @@ -23,7 +23,8 @@ (in-package :cello) (defun hedron-options () - (mk-part :options (ix-stack) + (mk-part :options (ix-inline) + :orientation :vertical :spacing (upts 4) :justify :right :kids (c? (the-kids @@ -78,7 +79,8 @@ )))) (defun hedron-tex-options () - (mk-part :tex-options (ix-stack) + (mk-part :tex-options (ix-inline) + :orientation :vertical :justify :left :kids (c? (the-kids (a-row () @@ -92,13 +94,14 @@ (alabel "Shape/Sides") (mk-part :scroller (ix-scroller) :mac-p t - :scroll-bars '(:vt) + :scroll-bars '(:vertical) :start-size (mkv2 (uin 2)(u96ths (downs 96))) :resizeable nil - :content (c? (mk-part :shape (ix-stack) + :content (c? (mk-part :shape (ix-inline) + :orientation :vertical :pre-layer (with-layers +white+ :fill) - :md-value (c-in (list 'cello)) - :kids (c? (loop for shape in '(cube 4 8 12 rhombic-dodecahedron 20 + :md-value (c-in (list 'nurb)) + :kids (c? (loop for shape in '(nurb cube 4 8 12 rhombic-dodecahedron 20 cylinder cone sphere torus sierpinski-sponge teapot cello) collecting (mk-part :rb (ct-text-radio-item) @@ -162,10 +165,11 @@ (alabel label$) (mk-part :scroller (ix-scroller) :mac-p t - :scroll-bars '(:vt) + :scroll-bars '(:vertical) :start-size (mkv2 (uin 2)(u96ths (downs 96))) :resizeable nil - :content (c? (make-part md-name 'ix-stack + :content (c? (make-part md-name 'ix-inline + :orientation :vertical :pre-layer (with-layers +white+ :fill) :md-value (c-in (list (or (when start$ (find-if (lambda (jpeg) Index: cell-cultures/cellodemo/hedron-render.lisp diff -u cell-cultures/cellodemo/hedron-render.lisp:1.2 cell-cultures/cellodemo/hedron-render.lisp:1.3 --- cell-cultures/cellodemo/hedron-render.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/hedron-render.lisp Fri Oct 15 05:37:30 2004 @@ -49,6 +49,65 @@ (ftgl-render font "Cello")) +(defun glut-solid-nurb (nurb) + (glu-nurbs-property nurb glu_display_mode glu_fill) + (draw-test-nurb nurb)) + +(defun glut-wire-nurb (nurb) + (glu-nurbs-property nurb glu_display_mode glu_outline_polygon) + (draw-test-nurb nurb)) + +(defparameter *hill* (make-ff-array :float 0 0 0 0 1 1 1 1)) +(defparameter *hill-controls* (make-ff-array :float -3.0 -3.0 -9 -3.0 -1.0 -9 -3.0 1.0 + -9 -3.0 3.0 -9 -1.0 -3.0 -9 -1.0 -1.0 9 -1.0 1.0 9 -1.0 + 3.0 -9 1.0 -3.0 -9 1.0 -1.0 9 1.0 1.0 9 1.0 3.0 -9 3.0 + -3.0 -9 3.0 -1.0 -9 3.0 1.0 -9 3.0 3.0 -9) + #+not (loop with fv = (fgn-alloc 'glfloat 48 :testnurb) + for u below 4 do + (loop for v below 4 + for base = (+ (* u 12) (* v 3)) + do (setf (eltf fv (+ base 0)) (* 2 (- u 1.5))) + (setf (eltf fv (+ base 1)) (* 2 (- v 1.5))) + (setf (eltf fv (+ base 2)) + (* 3 (if (and (or (eql u 1)(eql u 2)) + (or (eql v 1)(eql v 2))) + 3 -3)))) + finally (return fv))) + +(defparameter *dump-matrix* (fgn-alloc 'glfloat 16 :dump-matrix)) +(defun dump-matrix (matrix-id msg) + (gl-get-floatv matrix-id *dump-matrix*) + (format t "~&~a > ~a matrix> ~{~a ~}" msg + (cond ((eql matrix-id gl_modelview_matrix) 'modelview) + ((eql matrix-id GL_PROJECTION_MATRIX) 'projection)) + (loop for n below 16 collecting (eltf *dump-matrix* n)))) + +(defun dump-viewport ( msg) + (gl-get-floatv GL_VIEWPORT *dump-matrix*) + (format t "~&~a > viewport> ~{~a ~}" msg + (loop for n below 4 collecting (eltf *dump-matrix* n)))) + +;;;glGetFloatv(GL_MODELVIEW_MATRIX,modelview); +;;; glGetFloatv(GL_PROJECTION_MATRIX,projection); +;;; glGetIntegerv(GL_VIEWPORT,viewport); +;;; gluLoadSamplingMatrices (Nurb, modelview, projection, viewport); + +(defun draw-test-nurb (nurb) + (glu-nurbs-property nurb glu_sampling_tolerance 5) + (glu-nurbs-property nurb glu_auto_load_matrix gl_false) + + (gl-enable gl_lighting) + (gl-enable gl_light0) + (gl-enable gl_depth_test) + (gl-enable gl_auto_normal) + (gl-enable gl_normalize) + + (gl-rotatef 330 1 0 0) + (gl-scalef .25 .25 .25) + (glu-begin-surface nurb) + (glu-nurbs-surface nurb 8 *hill* 8 *hill* 12 3 *hill-controls* 4 4 gl_map2_vertex_3) + (glu-end-surface nurb)) + (defparameter *sponge-offset* (loop with fv = (fgn-alloc 'gldouble 3 :sponge) for n below 3 do (setf (eltd fv n) 0) @@ -60,10 +119,10 @@ (declare (ignorable w)) (gl-matrix-mode gl_projection) (with-matrix (t) - (trc nil "tetra frame" (ll self) (lr self) (lb self) (lt self)) - (gl-ortho (ll w) (lr w) (lb w) (lt w) -10000 10000) ;;*mgw-near* *mgw-far*) + (trc nil "ix-paint > hedron ortho" (ll self) (lr self) (lb self) (lt self)) + (gl-ortho (ll w) (lr w) (lb w) (lt w) 10000 -10000) ;*mgw-near* *mgw-far*) ;; was -+ 10k - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (with-matrix (nil) (let ((shape (car (md-value (fm^ :shape)))) (wireframe-p (md-value (fm^ :wireframe))) @@ -158,6 +217,7 @@ (otherwise (string shape))))) :cello) (case shape (cello (list (^text-font))) + (nurb (list (^nurb))) (cone (list base-r height (round slices) (round stacks))) (cylinder (list (quadric self) base-r top-r height (round slices) (round stacks))) ((cube teapot) (list size)) @@ -173,5 +233,5 @@ (gl-disable gl_texture_gen_q) (gl-matrix-mode gl_projection)) - (gl-matrix-mode gl_model-view)) + (gl-matrix-mode gl_modelview)) Index: cell-cultures/cellodemo/light-panel.lisp diff -u cell-cultures/cellodemo/light-panel.lisp:1.2 cell-cultures/cellodemo/light-panel.lisp:1.3 --- cell-cultures/cellodemo/light-panel.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/light-panel.lisp Fri Oct 15 05:37:30 2004 @@ -28,28 +28,44 @@ (defmodel hedron (ix-styled image) ((quadric :initform (c? (glu-new-quadric)) :reader quadric) + (nurb :reader nurb :initform (c? (let ((nurb (glu-new-nurbs-renderer))) + (assert (not (zerop nurb))) + (trc "hedron got new nurbs renderer" self nurb) + (glu-nurbs-property nurb glu_sampling_tolerance 25) + nurb))) (mat-ambi-diffuse :initform nil :initarg :mat-ambi-diffuse :reader mat-ambi-diffuse) (mat-specular :initform nil :initarg :mat-specular :reader mat-specular) (mat-shiny :initform nil :initarg :mat-shiny :reader mat-shiny) - (mat-emission :initform nil :initarg :mat-emission :reader mat-emission)) + (mat-emission :initform nil :initarg :mat-emission :reader mat-emission) + (backdrop :reader backdrop :initarg :backdrop :initform nil)) (:default-initargs :lighting :on :text-font (ftgl-make :extruded *gui-style-default-face* 18 96 9) :rotation (let ((rx 0)(ry 0)(rz 0)) - (c? (let ((spinning (md-value (fm-other :spinning)))) + (c? (bIf (spinning (md-value (fm-other :spinning))) (macrolet ((radj (axis ixid) `(incf ,axis (if spinning (* 10 (v2-h (md-value (fm-other ,ixid)))) 0)))) (when (frame-ct .w.) - (list (radj rx :rotx) - (radj ry :roty) - (radj rz :rotz))))))))) + (list (radj rx :rotx) + (radj ry :roty) + (radj rz :rotz)))) + (list rx ry rz)))))) + +(defmethod ogl-dsp-list-prep progn ((self hedron)) + (trc nil "ogl-dsp-list-prep> doing hedron" self) + (^nurb) + (ogl-dsp-list-prep (backdrop self))) + +(defmethod not-to-be ((self hedron)) + (when (^nurb) + (glu-delete-nurbs-renderer (^nurb)))) (defmethod display-text$ ((self Hedron)) - "quick dirty to satisfy ix-styled ogl-disp-list-prep" - "2Cel2lo") + "quick dirty ugly hack to satisfy ix-styled ogl-disp-list-prep" + "Cello") (defmodel rgba-mixer (ix-stack) ((red :cell nil :initarg :red :initform nil) @@ -106,10 +122,7 @@ :lb (c? (^fill-parent-down))) (hedron-options) (a-stack (:spacing (u8ths 1) - :justify :left - :skin (c? (wand-ensure-typed 'wand-texture - (car (md-value (fm-other :shape-backer))) - :tile-p nil))) + :justify :left) (hedron-tex-options) (mk-part :hedron (hedron) :ll (u96ths -300) :lt (ups (u96ths 300)) @@ -121,11 +134,14 @@ :mat-shiny (c? (md-value (fm-other :hedro-shiny))) :mat-emission (c? (when (md-value (fm-other :lights-on)) (md-value (fm-other :hedro-emission)))) - + :backdrop (c? (assert (not *ogl-listing-p*)) + (wand-ensure-typed 'wand-texture + (car (md-value (fm-other :shape-backer))) + :tile-p nil)) :pre-layer (with-layers (:in 300) +white+ - :off (:wand (skin .parent)) :on + :off (:wand (^backdrop)) :on (:in 20) +gray+ (:out 20) Index: cell-cultures/cellodemo/tutor-geometry.lisp diff -u cell-cultures/cellodemo/tutor-geometry.lisp:1.2 cell-cultures/cellodemo/tutor-geometry.lisp:1.3 --- cell-cultures/cellodemo/tutor-geometry.lisp:1.2 Fri Oct 1 06:01:10 2004 +++ cell-cultures/cellodemo/tutor-geometry.lisp Fri Oct 15 05:37:30 2004 @@ -26,7 +26,7 @@ (/ degrees #.(/ 180 pi))) (defun tu-geo () - (make-instance 'ig-zero-tl + (make-instance 'ix-zero-tl :md-name 'tu-geo :kids (c? (flet ((tu-box (name &rest deets) (apply 'make-instance 'image

1 0

15 Oct '04

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)

1 0

[cells-cvs] CVS update: cell-cultures/config/cl-ftgl-config.lisp cell-cultures/config/cl-magick-config.lisp
by Kenny Tilton 01 Oct '04

01 Oct '04

Update of /project/cells/cvsroot/cell-cultures/config In directory common-lisp.net:/tmp/cvs-serv2293/config Modified Files: cl-ftgl-config.lisp cl-magick-config.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:38 2004 Author: ktilton Index: cell-cultures/config/cl-ftgl-config.lisp diff -u cell-cultures/config/cl-ftgl-config.lisp:1.1 cell-cultures/config/cl-ftgl-config.lisp:1.2 --- cell-cultures/config/cl-ftgl-config.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/config/cl-ftgl-config.lisp Fri Oct 1 06:01:32 2004 @@ -24,7 +24,7 @@ (setq *ftgl-dynamic-lib-path* (merge-pathnames - (make-pathname :name "ftgl_dynamic_MTD" + (make-pathname :name "ftgl_dynamic_MTD_d" :type "dll") cl-user::*cello-dynlib-directory*)) Index: cell-cultures/config/cl-magick-config.lisp diff -u cell-cultures/config/cl-magick-config.lisp:1.1 cell-cultures/config/cl-magick-config.lisp:1.2 --- cell-cultures/config/cl-magick-config.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/config/cl-magick-config.lisp Fri Oct 1 06:01:32 2004 @@ -34,7 +34,7 @@ (setq *cl-magick-source-directory* (merge-pathnames - (make-pathname :directory '(:relative "cello" "cl-magick")) + (make-pathname :directory '(:relative "cl-magick")) cl-user::*devel-root*)) (setq *magick-wand-templates*

1 0

[cells-cvs] CVS update: cell-cultures/cl-opengl/cl-opengl.lisp cell-cultures/cl-opengl/gl-def.lisp cell-cultures/cl-opengl/gl-functions.lisp cell-cultures/cl-opengl/glut-extras.lisp cell-cultures/cl-opengl/ogl-macros.lisp cell-cultures/cl-opengl/ogl-utils.lisp
by Kenny Tilton 01 Oct '04

01 Oct '04

Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv2293/cl-opengl Modified Files: cl-opengl.lisp gl-def.lisp gl-functions.lisp glut-extras.lisp ogl-macros.lisp ogl-utils.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:29 2004 Author: ktilton Index: cell-cultures/cl-opengl/cl-opengl.lisp diff -u cell-cultures/cl-opengl/cl-opengl.lisp:1.2 cell-cultures/cl-opengl/cl-opengl.lisp:1.3 --- cell-cultures/cl-opengl/cl-opengl.lisp:1.2 Sun Jul 4 20:59:45 2004 +++ cell-cultures/cl-opengl/cl-opengl.lisp Fri Oct 1 06:01:29 2004 @@ -58,7 +58,7 @@ #:ups #:ups-most #:ups-more #:downs #:downs-most #:downs-more #:farther #:nearer #:ogl-texture-delete #:ogl-texture-gen #:ogl-tex-gen-setup #:ogl-bounds #:ogl-scissor-box #:ogl-raster-pos-get - #:ogl-pen-move #:ogl-pen-init #:ogl-pen #:ogl-pen-x #:ogl-pen-y + #:ogl-pen-move #:with-bitmap-shifted #:texture-name #:ogl-list-cache #:ogl-lists-delete #:eltgli #:ogl-tex-activate #:gl-name)) Index: cell-cultures/cl-opengl/gl-def.lisp diff -u cell-cultures/cl-opengl/gl-def.lisp:1.1 cell-cultures/cl-opengl/gl-def.lisp:1.2 --- cell-cultures/cl-opengl/gl-def.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/gl-def.lisp Fri Oct 1 06:01:29 2004 @@ -26,7 +26,7 @@ `(defun-ffx ,rtn ,module$ ,name$ (,@type-args) (progn ;;(cells::count-it ,(intern (string-upcase name$) :keyword)) - (glec ',rtn)))) + (glec ',(intern name$))))) (defun aforef (o n) (uffi:deref-array o '(:array :int) n)) Index: cell-cultures/cl-opengl/gl-functions.lisp diff -u cell-cultures/cl-opengl/gl-functions.lisp:1.2 cell-cultures/cl-opengl/gl-functions.lisp:1.3 --- cell-cultures/cl-opengl/gl-functions.lisp:1.2 Sun Jul 4 20:59:45 2004 +++ cell-cultures/cl-opengl/gl-functions.lisp Fri Oct 1 06:01:29 2004 @@ -169,6 +169,7 @@ (defun-ffx :void "open-gl" "glGenTextures" (glsizei n gluint *textures)) (defun-ffx :void "open-gl" "glBindTexture" (glenum target gluint texture)) (defun-ffx :void "open-gl" "glDeleteTextures" (glsizei n gluint *textures)) +(defun-ffx :int "open-gl" "glIsTexture" (gluint textureName)) @@ -373,13 +374,11 @@ (defun-ogl :void "open-gl" "glPixelZoom" (glfloat xfactor glfloat yfactor)) #| display lists |# -(defun-ogl glboolean "open-gl" "glIsList" (gluint list)) +(defun-ogl :int "open-gl" "glIsList" (gluint list)) (defun-ogl :void "open-gl" "glDeleteLists" (gluint list glsizei range )) (defun-ogl gluint "open-gl" "glGenLists" (glsizei range )) (defun-ogl :void "open-gl" "glNewList" (gluint list glenum mode )) (defun-ogl :void "open-gl" "glEndList" ()) (defun-ogl :void "open-gl" "glCallList" (gluint list )) (defun-ogl :void "open-gl" "glCallLists" (glsizei n glenum type glvoid *lists)) - - (defun-ogl :void "open-gl" "glListBase" (gluint base)) Index: cell-cultures/cl-opengl/glut-extras.lisp diff -u cell-cultures/cl-opengl/glut-extras.lisp:1.1 cell-cultures/cl-opengl/glut-extras.lisp:1.2 --- cell-cultures/cl-opengl/glut-extras.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/glut-extras.lisp Fri Oct 1 06:01:29 2004 @@ -37,6 +37,7 @@ (setf *glut-dll* nil *opengl-dll* nil) (ff:unload-foreign-library dll))))) +(defparameter *mg-glut-display-busy* nil) (defun cl-glut-init () (cl-opengl-init) @@ -60,7 +61,8 @@ (print "glut initialised") ) (fgn-free argc)))) - (print "Glut already initialized")))) + (print "Glut already initialized")) + (setf *mg-glut-display-busy* nil))) (defvar *mdepth*) (defvar *selecting*) Index: cell-cultures/cl-opengl/ogl-macros.lisp diff -u cell-cultures/cl-opengl/ogl-macros.lisp:1.1 cell-cultures/cl-opengl/ogl-macros.lisp:1.2 --- cell-cultures/cl-opengl/ogl-macros.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/ogl-macros.lisp Fri Oct 1 06:01:29 2004 @@ -100,8 +100,6 @@ (defun cl-opengl-init () (declare (ignorable load-oglfont-p)) - - (unless *opengl-dll* (print "loading open GL/GLU") (uffi:load-foreign-library @@ -112,7 +110,7 @@ :module "gl-util")))) (defun glec (&optional (id :anon)) - (unless *gl-begun* + (unless (and (boundp '*gl-begun*) *gl-begun*) (let ((e (glgeterror))) (if (zerop e) (unless t ;; (find id '(glutcheckloop glutgetwindow)) Index: cell-cultures/cl-opengl/ogl-utils.lisp diff -u cell-cultures/cl-opengl/ogl-utils.lisp:1.1 cell-cultures/cl-opengl/ogl-utils.lisp:1.2 --- cell-cultures/cl-opengl/ogl-utils.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/ogl-utils.lisp Fri Oct 1 06:01:29 2004 @@ -42,11 +42,12 @@ (defun ogl-texture-gen () (gl-gen-textures 1 *textures-1*) + (glec :ogl-texture-gen) (ff-elt *textures-1* gluint 0)) (let (gl-s-plane gl-t-plane gl-r-plane gl-q-plane) (defun ogl-tex-gen-setup (mode tex-env tex-wrap scale &rest planes) - ;(print `(ogl-tex-gen-setup ,mode ,tex-wrap)) + (ukt::trc nil "ogl-tex-gen-setup:" mode tex-env tex-wrap scale planes) (gl-tex-envf gl_texture_env gl_texture_env_mode tex-env) (gl-tex-parameterf gl_texture_2d gl_texture_min_filter gl_linear ) (gl-tex-parameterf gl_texture_2d gl_texture_mag_filter gl_linear ) @@ -192,28 +193,17 @@ (defun ogl-raster-pos-get () (gl-get-ints-4 gl_current_raster_position)) -(defparameter *ogl-pen* nil) - -(defun ogl-pen () - *ogl-pen*) - -(defun ogl-pen-x () - (car *ogl-pen*)) - -(defun ogl-pen-y () - (cadr *ogl-pen*)) - -(defun ogl-pen-init () - (setq *ogl-pen* (ogl-raster-pos-get)) - ;;(print (list "ogl-pen-init" :to *ogl-pen*)) - (values)) +(defmacro with-bitmap-shifted ((x y) &body body) + (let ((xy (gensym))) + `(let ((,xy (cons ,x ,y))) + (ogl-pen-move (car ,xy) (cdr ,xy)) + (prog1 + (progn ,@body) + (ogl-pen-move (- (car ,xy)) (- (cdr ,xy))))))) (defun ogl-pen-move (x y) - ;(incf (car *ogl-pen*) x) - ;(incf (cadr *ogl-pen*) y) - ;(print (list "ogl-pen-move" x y)) - ;(print (list "in synch?" *ogl-pen* (ogl-raster-pos-get))) - (gl-bitmap 0 0 0 0 (+ x) (+ y))) + ;;(ukt::trc "ogl-pen-moving" x y) + (gl-bitmap 0 0 0 0 x y)) (defclass ogl-texture () ((texture-name :accessor texture-name :initform nil)

1 0

[cells-cvs] CVS update: cell-cultures/cl-magick/cl-magick.lpr cell-cultures/cl-magick/mgk-test.lisp cell-cultures/cl-magick/wand-image.lisp cell-cultures/cl-magick/wand-pixels.lisp cell-cultures/cl-magick/wand-texture.lisp
by Kenny Tilton 01 Oct '04

01 Oct '04

Update of /project/cells/cvsroot/cell-cultures/cl-magick In directory common-lisp.net:/tmp/cvs-serv2293/cl-magick Modified Files: cl-magick.lpr mgk-test.lisp wand-image.lisp wand-pixels.lisp wand-texture.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:20 2004 Author: ktilton Index: cell-cultures/cl-magick/cl-magick.lpr diff -u cell-cultures/cl-magick/cl-magick.lpr:1.1 cell-cultures/cl-magick/cl-magick.lpr:1.2 --- cell-cultures/cl-magick/cl-magick.lpr:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/cl-magick.lpr Fri Oct 1 06:01:19 2004 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "6.2 [Windows] (Jun 26, 2002 11:39)"; 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) Index: cell-cultures/cl-magick/mgk-test.lisp diff -u cell-cultures/cl-magick/mgk-test.lisp:1.1 cell-cultures/cl-magick/mgk-test.lisp:1.2 --- cell-cultures/cl-magick/mgk-test.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/mgk-test.lisp Fri Oct 1 06:01:19 2004 @@ -208,6 +208,7 @@ ) ))) +(defvar *grace*) (defun r6w () (gl-load-identity) @@ -258,7 +259,8 @@ (gl-tex-coord2f 1 0) (v3f -1 -1 1) (gl-tex-coord2f 1 1) (v3f -1 1 1) (gl-tex-coord2f 0 1) (v3f -1 1 -1) - ))) + )) + (wand-render *grace* 0 0 1 -1)) (glut-swap-buffers) (glut-post-redisplay) ) @@ -281,7 +283,9 @@ (gl-depth-func gl_lequal) (gl-hint gl_perspective_correction_hint gl_nicest) (setf *skin6* (mgk:wand-ensure-typed 'wand-texture - (test-image 'jmcbw512 'jpg)))) + (clo::demo-image-file 'shapers "jmcbw512.jpg"))) + (setf *grace* (mgk:wand-ensure-typed 'wand-pixels + (clo::demo-image-file 'shapers "grace.jpg")))) #+test @@ -300,26 +304,27 @@ (gl-load-identity))) (defun cl-magick-test () - (wands-clear) - (setf *skin6* nil) - - (cl-glut-init) - (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns) - - (glut-init-display-mode (+ glut_rgb glut_double)) ;; Display Mode (Rgb And Double Buffered) - (glut-init-window-size wcx wcy) ;; Window Size If We Start In Windowed Mode - - (let ((key "NeHe's OpenGL Framework")) - (uffi:with-cstring (key-native key) - (glut-create-window key-native))) - - (r6init) - (r6reshape wcx wcy) - - (glut-display-func (ff-register-callable 'r6wffx)) - (glut-reshape-func (ff-register-callable 'r6-reshape)) - (glut-keyboard-func (ff-register-callable 'mgwkey)) - (glutmainloop)) + (let ((ogl::*gl-begun* nil)) + (wands-clear) + (setf *skin6* nil) + + (cl-glut-init) + (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns) + + (glut-init-display-mode (+ glut_rgb glut_double)) ;; Display Mode (Rgb And Double Buffered) + (glut-init-window-size wcx wcy) ;; Window Size If We Start In Windowed Mode + + (let ((key "NeHe's OpenGL Framework")) + (uffi:with-cstring (key-native key) + (glut-create-window key-native))) + + (r6init) + (r6reshape wcx wcy) + + (glut-display-func (ff-register-callable 'r6wffx)) + (glut-reshape-func (ff-register-callable 'r6-reshape)) + (glut-keyboard-func (ff-register-callable 'mgwkey)) + (glutmainloop))) #+test (cl-magic-test) Index: cell-cultures/cl-magick/wand-image.lisp diff -u cell-cultures/cl-magick/wand-image.lisp:1.1 cell-cultures/cl-magick/wand-image.lisp:1.2 --- cell-cultures/cl-magick/wand-image.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/wand-image.lisp Fri Oct 1 06:01:19 2004 @@ -94,22 +94,23 @@ (ff-elt *mgk-rows* :unsigned-long 0))) (defun wand-get-image-pixels (wand - &optional (first-col 0) (first-row 0) - (last-col (magick-get-image-width wand)) - (last-row (magick-get-image-height wand))) - (let* ((columns (- last-col first-col)) - (rows (- last-row first-row)) - (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) - ;;(print (list "wand-get-image-pixels got" (* 3 columns rows) pixels)) - (uffi:with-cstring (rgbc "RGB") - (magick-get-image-pixels wand first-col first-row columns rows rgbc 0 pixels )) - #+works (progn - (uffi:with-cstring (cpath "C:\\TEST.JPG") ;; p) - (print `(writeimage ,(magick-write-image wand cpath)))) - (uffi:with-cstring (cpath "C:\\TEST.GIF") ;; p) - (print `(writeimage ,(magick-write-image wand cpath)))) - (uffi:with-cstring (cpath "C:\\TEST.BMP") ;; p) - (print `(writeimage ,(magick-write-image wand cpath))))) - - (values pixels columns rows))) + &optional (first-col 0) (first-row 0) + (last-col (magick-get-image-width wand)) + (last-row (magick-get-image-height wand))) + (let* ((columns (- last-col first-col)) + (rows (- last-row first-row)) + (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) + ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) + (uffi:with-cstring (rgbc "RGB") + (magick-get-image-pixels wand first-col first-row columns rows rgbc 0 pixels )) + #+testing (progn + (incf testn) + (uffi:with-cstring (cpath (format nil "C:\\TEST~a.JPG" testn)) ;; p) + (print `(writeimage ,(magick-write-image wand cpath)))) + (uffi:with-cstring (cpath (format nil "C:\\TEST~a.GIF" testn)) ;; p) + (print `(writeimage ,(magick-write-image wand cpath)))) + #+not (uffi:with-cstring (cpath "C:\\TEST.BMP") ;; p) + (print `(writeimage ,(magick-write-image wand cpath))))) + + (values pixels columns rows))) Index: cell-cultures/cl-magick/wand-pixels.lisp diff -u cell-cultures/cl-magick/wand-pixels.lisp:1.1 cell-cultures/cl-magick/wand-pixels.lisp:1.2 --- cell-cultures/cl-magick/wand-pixels.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/wand-pixels.lisp Fri Oct 1 06:01:19 2004 @@ -39,34 +39,37 @@ "only works in ortho mode I think; abstract out raster-pos for perspective" (declare (ignorable right left)) (assert (pixels self)) - + (ukt::trc nil "!!!! pixelrender entry rasterpos:" + (ogl-raster-pos-get) :lrtb (list left right top bottom) + :image-sz sz) (let ((y-move (downs (+ 0 (abs (- top bottom)))))) - (gl-disable gl_texture_2d) - (gl-disable gl_blend) - ;;(clo::trc "wand-render move" 0 y-move top bottom (- top bottom)) - (ogl-pen-move 0 y-move) - - (if (ogl-get-boolean gl_current_raster_position_valid) - (progn #+not (format nil "~&rasterpos ~a OK: ~a" - (ogl-raster-pos-get)ogl::*ogl-pen* #+nah (list left right top bottom) )) - (format t "~&in ~a rasterpos ~a invalid, goffset is ???" - (ogl-raster-pos-get) self )) - #+wait (gl-pixel-zoom (/ (- right left) (car sz)) - (/ (abs (- top bottom)) (cdr sz))) - #+not (print (list "draw pixels sz, lbox" left right (file-path$ self) sz - :tby top bottom y-move)) + (with-bitmap-shifted (0 y-move) + (clo::trc nil "wand-render pixels move" 0 y-move :top top :bottom bottom) + #+hush + (if (ogl-get-boolean gl_current_raster_position_valid) + (progn + (format t "~&rasterpos ~a OK: ~a" + (ogl-raster-pos-get) (list left right top bottom) )) + (format t "~&in wand-render rasterpos ~a invalid, goffset is ???" + (ogl-raster-pos-get) self )) + #+wait (gl-pixel-zoom (/ (- right left) (car sz)) + (/ (abs (- top bottom)) (cdr sz))) + #+not (print (list "draw pixels sz, lbox" left right (file-path$ self) sz + :tby top bottom y-move)) - (unless (zerop (gl-is-enabled gl_scissor_test)) - (print `(scissor-box2 ,(ogl-bounds (ogl-scissor-box))))) - ;;(gl-disable GL_LIGHTING) - ;;(gl-disable GL_COLOR_MATERIAL) - ;;(gl-disable GL_DEPTH_TEST) - ;;(gl-disable GL_cull_face - ;;(gl-scalef 1000 1000 1000) - (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) - (gl-polygon-mode gl_front_and_back gl_fill) - ;;(cells::trc nil "wand-pixelling" ogl::*ogl-pen* (ogl-raster-pos-get)) - (gl-draw-pixels (car sz) (cdr sz) - gl_rgb gl_unsigned_byte (pixels self)) - (ogl::glec :draw-pixels) - (ogl-pen-move 0 (- y-move)))) \ No newline at end of file + #+shh (unless (zerop (gl-is-enabled gl_scissor_test)) + (print `(scissor-box2 ,(ogl-bounds (ogl-scissor-box))))) + (gl-disable GL_LIGHTING) + (gl-disable GL_COLOR_MATERIAL) + (gl-disable GL_DEPTH_TEST) + (gl-disable GL_cull_face) + ;(gl-scalef 1000 1000 1000) + ;(gl-disable gl_scissor_test) ;; debugging try + ;(gl-enable gl_blend) ;; debugging try + (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) + (gl-polygon-mode gl_front_and_back gl_fill) + (cells::trc nil "wand-pixelling" (ogl-raster-pos-get)) + + (gl-draw-pixels (car sz) (cdr sz) + gl_rgb gl_unsigned_byte (pixels self)) + (ogl::glec :draw-pixels)))) \ No newline at end of file Index: cell-cultures/cl-magick/wand-texture.lisp diff -u cell-cultures/cl-magick/wand-texture.lisp:1.2 cell-cultures/cl-magick/wand-texture.lisp:1.3 --- cell-cultures/cl-magick/wand-texture.lisp:1.2 Sun Jul 4 20:59:44 2004 +++ cell-cultures/cl-magick/wand-texture.lisp Fri Oct 1 06:01:19 2004 @@ -38,22 +38,25 @@ (cons (bfit (car c1)(car c2)(car c3)) (bfit (cdr c1)(cdr c2)(cdr c3))))) - (defmethod initialize-instance :after ((self wand-texture) &key) - (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) - (expt 2 (floor (log (cdr (image-size self)) 2))))) - (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2))) - (expt 2 (ceiling (log (cdr (image-size self)) 2))))) - (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) - (unless (equal (image-size self) best-fit-sz) - ;;(print `(tex-refit ,(image-size self) to ,best-fit-sz)) - (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) - ;;; gaussian-filter 0) - (setf (image-size self) best-fit-sz)) - - ;(print `(new image size ,(image-size self))) - (setf (texture-name self) - (wand-image-to-texture self)) - )) + (defmethod texture-name :around ((self wand-texture)) + (or (call-next-method) + (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) + (expt 2 (floor (log (cdr (image-size self)) 2))))) + (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2))) + (expt 2 (ceiling (log (cdr (image-size self)) 2))))) + (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) + (unless (equal (image-size self) best-fit-sz) + ;;(print `(tex-refit ,(image-size self) to ,best-fit-sz)) + (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) + ;;; gaussian-filter 0) + (setf (image-size self) best-fit-sz)) + + ;(print `(new image size ,(image-size self))) + (let ((tx (wand-image-to-texture self))) + (if (plusp tx) + (setf (texture-name self) tx) + (break "bad tx name ~a for ~a" tx self)))))) + (defun wand-texture-activate (wand) ;(print `(wand-texture-activate ,(texture-name wand))) @@ -61,12 +64,14 @@ (defparameter *textures-1* (fgn-alloc 'gluint 1 :ignore)) (defun wand-image-to-texture (self) - (let ((tx (progn (gl-gen-textures 1 *textures-1*) - (ff-elt *textures-1* gluint 0))) + (let ((tx (ogl-texture-gen) #+not (progn (gl-gen-textures 1 *textures-1*) + (ff-elt *textures-1* gluint 0))) (pixels (wand-get-image-pixels (mgk-wand self) 0 0 (car (image-size self)) (cdr (image-size self))))) ;; (assert (not *ogl-listing-p*)) + (assert (plusp tx)) + (ukt::trc "!!!!wand-image-to-texture genning new tx:" tx) (gl-bind-texture gl_texture_2d tx) (progn ;; useless?? @@ -90,12 +95,12 @@ (defmethod wand-render ((self wand-texture) left top right bottom &aux (sz (image-size self))) - #+not (format t "~&wand-render tex ~a ~a ~a" (texture-name self) self - :size sz :bbox (list left top right bottom)) - ;;(assert *ogl-listing-p*) - (with-attrib (gl_texture_bit);; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) + (ukt::trc nil "wand-render tex-name:" (texture-name self) (tile-p self) self + :size sz :bbox (list left top right bottom)) + + (with-attrib (gl_texture_bit);; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (wand-texture-activate self) - #+tilingworksbutslower + #+slower (ogl-tex-gen-setup gl_object_linear gl_modulate (if (tile-p self) gl_repeat gl_clamp) (/ 1 (max (car sz)(cdr sz))) @@ -108,7 +113,7 @@ do (loop for x from left below right by (car sz) for x-rem = (- right x) - do ;(print `(tex tiling ,x ,y)) + do ;; (print `(tex tiling ,x ,y)) (flet ((vxy (tx ty) (let ((x-fraction (min tx (/ x-rem (car sz)))) @@ -120,13 +125,10 @@ (flet ((vxy (tx ty) (let ((abs-x (+ left (* tx (- right left)))) (abs-y (+ top (downs (* ty (abs (- top bottom))))))) - ;(print `(tex full,(cons tx ty) to-vertex ,(cons abs-x abs-y))) + ;;(print `(tex full,(cons tx ty) to-vertex ,(cons abs-x abs-y))) (gl-tex-coord2f tx ty) (gl-vertex3f abs-x abs-y 0)))) (with-gl-begun (gl_quads) (vxy 0 0)(vxy 0 1)(vxy 1 1)(vxy 1 0))) - ))) - - - ) \ No newline at end of file + ))))R \ No newline at end of file

1 0

[cells-cvs] CVS update: cell-cultures/cl-ftgl/cl-ftgl.lisp
by Kenny Tilton 01 Oct '04

01 Oct '04

Update of /project/cells/cvsroot/cell-cultures/cl-ftgl In directory common-lisp.net:/tmp/cvs-serv2293/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:13 2004 Author: ktilton Index: cell-cultures/cl-ftgl/cl-ftgl.lisp diff -u cell-cultures/cl-ftgl/cl-ftgl.lisp:1.3 cell-cultures/cl-ftgl/cl-ftgl.lisp:1.4 --- cell-cultures/cl-ftgl/cl-ftgl.lisp:1.3 Wed Sep 29 04:50:43 2004 +++ cell-cultures/cl-ftgl/cl-ftgl.lisp Fri Oct 1 06:01:12 2004 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.3 2004/09/29 02:50:43 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.4 2004/10/01 04:01:12 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -461,7 +461,7 @@ (setf (ftgl-ifont font) (ftgl-font-make font)))) (defun ftgl-font-make (font) - (print (list "ftgl-font-make entry" font)) + ;;(print (list "ftgl-font-make entry" font)) (let ((path (merge-pathnames (make-pathname :name (string (ftgl-face font)) :type "ttf") *font-directory-path*))) @@ -478,13 +478,6 @@ (defun ftgl-render (font s) (let ((df (ftgl-get-display-font font))) - (when (typep font 'ftgl-texture) - (assert cello::*w*) - (ukt::trc "ftgl-render sees texture,font" - (fgc-char-texture df (char-code #\a)) font - (gl-is-texture (fgc-char-texture df (char-code #\a))) - (gl-is-enabled gl_texture_2d))) - (uffi:with-cstring (cs s) (fgc-render df cs))))

1 0

[cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lisp cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/tutor-geometry.lisp
by Kenny Tilton 01 Oct '04

01 Oct '04

Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv2293/cellodemo Modified Files: cellodemo.lisp demo-window.lisp tutor-geometry.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:10 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lisp diff -u cell-cultures/cellodemo/cellodemo.lisp:1.1 cell-cultures/cellodemo/cellodemo.lisp:1.2 --- cell-cultures/cellodemo/cellodemo.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/cellodemo.lisp Fri Oct 1 06:01:10 2004 @@ -42,22 +42,19 @@ :kids (c? (the-kids (a-row (:px 96 :py (downs 96)) (mk-part :imk-jpg (ix-image-file) + :pre-layer (c? (with-layers +red+ :fill (:wand (^wander)))) :md-value (c? (demo-image-file "shapers" "grace.jpg"))) (a-stack () - (loop for n below 10 + (loop for face in '(antquabi bookosb + georgiai framd times + gothic impact + lucon micross + palab) collect (mk-part :xxx (ix-text) - :text-font (let ((myn n)) - (c? (font-ftgl-ensure :texture - (or (elt '(antquabi bookosb - georgiai framd times - gothic impact - lucon micross - palab) - myn) - *gui-style-default-face*) - 24))) - :text$ "Hello, world!"))) - ) + :pre-layer (with-layers (:rgba +white+)) + :text-font (let ((myface face)) + (c? (font-ftgl-ensure :texture myface 24))) + :text$ "Hello, world!")))) (mk-part :zee (ix-text) :md-value (c? (if (visible (fm-other :ft-jpg)) (without-c-dependency (frame-ct .w.)) 0)) @@ -65,17 +62,17 @@ :justify-hz :center :py (c? (py-maintain-pt (pb (psib)))) :pre-layer (with-layers (:out 1500) +blue+) - :zoom (c? (if (without-c-dependency (< 200 (- (frame-ct .w.) (^md-value)))) + :zoom (c? (let ((start (^md-value))) + (if (without-c-dependency (< 200 (- (frame-ct .w.) start))) .cache - (progn (trc "zooming") - (make-list 3 :initial-element (min 2.0 (/ (- (frame-ct .w.) (^md-value)) + (make-list 3 :initial-element (min 2.0 (/ (- (frame-ct .w.) start) 100.0)))))) - :rotation (c? (if (without-c-dependency (< 200 (- (frame-ct .w.) (^md-value)))) + :rotation (c? (let ((start (^md-value))) + (if (without-c-dependency (< 200 (- (frame-ct .w.) start))) .cache - (progn - (trc "rotating") - (list (* 360 (/ (min 200 (- (frame-ct .w.) (^md-value))) 100.0)) + (list (* 360 (/ (min 200 (- (frame-ct .w.) start)) 100.0)) 1 1 1)))) + :text-font (c? (font-ftgl-ensure :texture *gui-style-default-face* 24 )) - :text$ "Hello, world!"))))) + :text$ "hello, world!"))))) Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.2 cell-cultures/cellodemo/demo-window.lisp:1.3 --- cell-cultures/cellodemo/demo-window.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/demo-window.lisp Fri Oct 1 06:01:10 2004 @@ -30,9 +30,9 @@ :skin (c? (wand-ensure-typed 'wand-texture (car (md-value (fm-other :texture-picker))))) :focus (c-in nil) - :display-continuous (c-in nil) + :display-continuous (c-in t) :clear-rgba (list 0 0 0 1) - :lb (c-in (downs 750))))) + :lb (c-in (downs 650))))) (defun demo-scroller () (mk-part :demo-scroller (ig-zero-tl) @@ -85,22 +85,12 @@ (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 + :id :label :face *gui-style-button-face* - :sizes '(18 18 18 18 18) + :sizes '(12 12 12 12 12) :text-color +white+) (make-instance 'gui-style-ftgl :id :default @@ -145,7 +135,7 @@ :name "bingo" :type "mpg") *user-temp-directory*)))) - ;;;:display-continuous t + :display-continuous nil :md-name :demo-w :title$ "Hello, world" :skin nil @@ -160,7 +150,7 @@ :directory `(:relative "graphics" "out") :name (format nil "snap-me-~3,,,'0@A" (snapshot-release-id self)) - :type "png") + :type "jpg") cl-user::*devel-root*)) :pre-layer (c? (with-layers @@ -245,7 +235,7 @@ (a-stack (:spacing (u16ths 1)) (texture-picker) (demo-picker)) - #+nah (a-stack (:spacing (u96ths 6) + (a-stack (:spacing (u96ths 6) :justify :center :outset (u96ths 6) :visible (c? (not (snapshot-release-id .w.))) Index: cell-cultures/cellodemo/tutor-geometry.lisp diff -u cell-cultures/cellodemo/tutor-geometry.lisp:1.1 cell-cultures/cellodemo/tutor-geometry.lisp:1.2 --- cell-cultures/cellodemo/tutor-geometry.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/tutor-geometry.lisp Fri Oct 1 06:01:10 2004 @@ -36,11 +36,9 @@ :pre-layer (c? (with-layers (:disable gl_texture_2d) :off - (:line-width 3) + (:line-width 2) (:rgba (^skin)) - :line-frame - (:poly-mode gl_front_and_back gl_fill) - (:rect -2 -2 2 2))) + :line-frame)) deets))) (the-kids (tu-box :ftgrow

1 0

[cells-cvs] CVS update: cell-cultures/cello/cello-ftgl.lisp cell-cultures/cello/cello-magick.lisp cell-cultures/cello/image.lisp cell-cultures/cello/ix-render.lisp cell-cultures/cello/ix-text.lisp cell-cultures/cello/window-callbacks.lisp cell-cultures/cello/window.lisp
by Kenny Tilton 01 Oct '04

01 Oct '04

Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv2293/cello Modified Files: cello-ftgl.lisp cello-magick.lisp image.lisp ix-render.lisp ix-text.lisp window-callbacks.lisp window.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:06 2004 Author: ktilton Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.2 cell-cultures/cello/cello-ftgl.lisp:1.3 --- cell-cultures/cello/cello-ftgl.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/cello-ftgl.lisp Fri Oct 1 06:01:05 2004 @@ -247,7 +247,7 @@ (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) + (trc nil "(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) Index: cell-cultures/cello/cello-magick.lisp diff -u cell-cultures/cello/cello-magick.lisp:1.1 cell-cultures/cello/cello-magick.lisp:1.2 --- cell-cultures/cello/cello-magick.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/cello-magick.lisp Fri Oct 1 06:01:05 2004 @@ -81,8 +81,9 @@ (defparameter *mapping-textures* nil) (defun ix-render-wand (wand l-box) - (when wand - (apply 'wand-render wand (r-bounds l-box)))) + (if wand + (apply 'wand-render wand (r-bounds l-box)) + (trc "ix-render-wand sees no wand" l-box))) ;;;(defun wand-centered-bounds (wand size) ;;; (let* ((raw-w (magick-get-image-width (^mgk-wand))) Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.3 cell-cultures/cello/image.lisp:1.4 --- cell-cultures/cello/image.lisp:1.3 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/image.lisp Fri Oct 1 06:01:05 2004 @@ -48,11 +48,12 @@ (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) *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)))) Index: cell-cultures/cello/ix-render.lisp diff -u cell-cultures/cello/ix-render.lisp:1.2 cell-cultures/cello/ix-render.lisp:1.3 --- cell-cultures/cello/ix-render.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/ix-render.lisp Fri Oct 1 06:01:05 2004 @@ -81,47 +81,46 @@ (let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self image) &aux (n (gl-name self))) - (gl-translatef (px self) (py self) 0) - (ogl-pen-move (px self) (py self)) ; /// combine former in here? - - (when n - (trc nil "gl-name" self n) - (gl-push-name n)) - - (rpchk 'ix-paint t nil self) - (when (and (not (c-stopped)) - (or (not *selecting*) - (ix-selectable self)) - (visible self) - (not (collapsed self))) - (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) - #+not (count-it :ix-render (type-of self)) - #+not (unless (kids self) - (count-it :ix-render-atom)) - (trc nil "ix painting" self) - (trc nil "ix-render around rendering" 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))))))) - (gl-translatef (- (px self)) (- (py self)) 0) - (ogl-pen-move (- (px self)) (- (py self))) - + (with-bitmap-shifted ((px self)(py self)) + (gl-translatef (px self) (py self) 0) + + + (when n + (trc nil "gl-name" self n) + (gl-push-name n)) + + (rpchk 'ix-paint t nil self) + (when (and (not (c-stopped)) + (or (not *selecting*) + (ix-selectable self)) + (visible self) + (not (collapsed self))) + (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) + #+not (count-it :ix-render (type-of self)) + #+not (unless (kids self) + (count-it :ix-render-atom)) + (trc nil "ix painting" 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))))))) + (gl-translatef (- (px self)) (- (py self)) 0)) + (when n (gl-pop-name)))) Index: cell-cultures/cello/ix-text.lisp diff -u cell-cultures/cello/ix-text.lisp:1.2 cell-cultures/cello/ix-text.lisp:1.3 --- cell-cultures/cello/ix-text.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/ix-text.lisp Fri Oct 1 06:01:05 2004 @@ -112,15 +112,13 @@ (ty (+ (lb self) (v2-v (inset self)) (round (glut-bitmap-y-orig (font-ffi-glut-id font)))))) - (ogl-pen-move tx ty) + (with-bitmap-shifted (tx ty) - #+shh (if (ogl-get-boolean gl_current_raster_position_valid) - (trc "rasterpos ok" self :g-offset (g-offset self)) - (trc "rasterpos offscreen" self :g-offset (g-offset self))) - (trc nil "raster pos valid?" (ogl-get-boolean gl_current_raster_position_valid)) - (glut-bitmap-string (font-ffi-glut-id font) t$) - (ogl-pen-move (- tx) (- ty)) - ))) + #+shh (if (ogl-get-boolean gl_current_raster_position_valid) + (trc "rasterpos ok" self :g-offset (g-offset self)) + (trc "rasterpos offscreen" self :g-offset (g-offset self))) + (trc nil "raster pos valid?" (ogl-get-boolean gl_current_raster_position_valid)) + (glut-bitmap-string (font-ffi-glut-id font) t$))))) (defmethod ix-render-in-font ((font font-glut-stroke) self) (bwhen (t$ (^display-text$)) Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.2 cell-cultures/cello/window-callbacks.lisp:1.3 --- cell-cultures/cello/window-callbacks.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/window-callbacks.lisp Fri Oct 1 06:01:05 2004 @@ -102,7 +102,11 @@ (window-display *w*)))) (defmethod window-display ((self window)) - (ix-paint self) ;; (gl-call-list (dsp-list self)) + + (bif (dl (dsp-list self)) + (gl-call-list (dsp-list self)) + (ix-paint self)) + (glut-swap-buffers) (incf (frame-ct self)) Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.2 cell-cultures/cello/window.lisp:1.3 --- cell-cultures/cello/window.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/window.lisp Fri Oct 1 06:01:05 2004 @@ -294,7 +294,7 @@ (glm gl_max_viewport_dims #x3386 ) ) - (trc nil "glutw-create'd window XY" (glut-get-window) self :from (glut-xy self) :to + (trc "glutw-create'd window XY" (glut-get-window) self :from (glut-xy self) :to (list (glut-get glut_window_x)(glut-get glut_window_y) (glut-get glut_window_width)(glut-get glut_window_height))) @@ -437,15 +437,13 @@ (progn ;; with-render-lock ((glut-get-window)) (glutmainloopevent) ) - (sleep 0.1) - )))) + (sleep 0.1))))) - -(defmethod ix-paint ((self window)) +(defmethod ix-paint :around ((self window)) (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) - (trc nil "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*) @@ -459,18 +457,15 @@ (gl-matrix-mode gl_model-view) (gl-load-identity) (gl-light-modeli gl_light_model_two_side 0) - (ogl-pen-init) - (ogl-pen-move 0 (ups (l-height self))) - - (when (clear-rgba self) - (apply #'gl-clear-color (clear-rgba self))) - - (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) - (with-metrics (nil nil "ix-paint window call next") - (call-next-method)) - (ogl-pen-move 0 (downs (l-height self))) - )) + (with-bitmap-shifted (0 (ups (l-height self))) + (trc nil "with initial window shift, rasterpos now" (ogl-raster-pos-get)) + (when (clear-rgba self) + (apply #'gl-clear-color (clear-rgba self))) + + (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) + (with-metrics (nil nil "ix-paint window call next") + (call-next-method))))) (defun w-quadric-ensure (key) (or (cdr (assoc key (quadrics *window-rendering*)))

1 0