Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv15578
Modified Files: cello-magick.lisp cello-openal.lisp cello.lisp cello.lpr ctl-drag.lisp ctl-markbox.lisp focus-utilities.lisp focus.lisp image.lisp ix-polygon.lisp ix-styled.lisp ix-text.lisp lighting.lisp nehe-06.lisp slider.lisp window-callbacks.lisp window-utilities.lisp Added Files: cello-window.lisp ix-opengl.lisp ix-paint.lisp ix-togl.lisp Removed Files: ix-render.lisp Log Message: Ongoing merge with Celtk
--- /project/cello/cvsroot/cello/cello-magick.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/cello-magick.lisp 2006/06/26 17:05:20 1.4 @@ -55,7 +55,7 @@ (ogl::glec :snapshot) (record-frame recording pixels columns rows))))
-(defmodel ix-wander (image) +(defmodel ix-wander (ix-view) ((wander :initarg :wander :accessor wander :initform nil)) ;;///just use skin? (:default-initargs :pre-layer (c? (with-layers (:wand (^wander)))))) @@ -80,12 +80,6 @@ (apply 'wand-render wand (r-bounds l-box)) (trc nil "ix-render-wand sees no wand" l-box)))
-;;;(defun wand-centered-bounds (wand size) -;;; (let* ((raw-w (magick-get-image-width (^mgk-wand))) -;;; (over-w (- raw-w (v2-w size))) -;;; (raw-h (magick-get-image-height (^mgk-wand))) -;;; (over-h (- raw-h (v2-h size)))) -;;; (when (or (plusp over-w)(plusp over-h)) -;;; (list (max 0 ( +
--- /project/cello/cvsroot/cello/cello-openal.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/cello-openal.lisp 2006/06/26 17:05:20 1.3 @@ -75,7 +75,7 @@ oal::*audio-files*))))))
(defun ix-sound-spec-find (self key) - (when (typep self 'image) + (when (typep self 'ix-view) (or (cdr (assoc key (sound self))) (ix-sound-spec-find .parent key))))
--- /project/cello/cvsroot/cello/cello.lisp 2006/06/05 01:47:49 1.5 +++ /project/cello/cvsroot/cello/cello.lisp 2006/06/26 17:05:20 1.6 @@ -27,7 +27,8 @@ #:kt-opengl #:cl-openal #:cl-ftgl - #:cl-magick)) + #:cl-magick) + (:export #:cello-window-event-handler #:with-layers #:visible #:ix-togl))
;;; in step one we will just have Celtk playing the part of Freeglut ;;; --- /project/cello/cvsroot/cello/cello.lpr 2006/06/11 13:32:24 1.6 +++ /project/cello/cvsroot/cello/cello.lpr 2006/06/26 17:05:20 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -37,7 +37,7 @@ (make-instance 'module :name "window-utilities.lisp") (make-instance 'module :name "wm-mouse.lisp") (make-instance 'module :name "pick.lisp") - (make-instance 'module :name "ix-render.lisp") + (make-instance 'module :name "ix-paint.lisp") (make-instance 'module :name "ix-polygon.lisp") (make-instance 'module :name "cello-ftgl.lisp") (make-instance 'module :name "cello-magick.lisp") @@ -46,6 +46,8 @@ :projects (list (make-instance 'project-module :name "..\Celtk\CELTK") (make-instance 'project-module :name + "..\Cells\gui-geometry\gui-geometry") + (make-instance 'project-module :name "cffi-extender\cffi-extender") (make-instance 'project-module :name "kt-opengl\kt-opengl") @@ -54,7 +56,9 @@ (make-instance 'project-module :name "cl-ftgl\cl-ftgl") (make-instance 'project-module :name - "cl-openal\cl-openal")) + "cl-openal\cl-openal") + (make-instance 'project-module :name + "cl-freetype\cl-freetype")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cello/cvsroot/cello/ctl-drag.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ctl-drag.lisp 2006/06/26 17:05:20 1.5 @@ -16,7 +16,7 @@
(in-package :cello)
-(defmodel ct-drag (control image) +(defmodel ct-drag (control ix-view) ((drag-pct :initarg :drag-pct :accessor drag-pct :unchanged-if 'v2= :initform (c-in (mkv2 0 0))) --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/06/26 17:05:20 1.5 @@ -22,7 +22,7 @@ (defmethod ix-layer-expand ((self (eql :x-mark)) &rest args) `(ix-render-x-mark ,(car args) l-box)))
-(defmodel ct-mark-box (ct-toggle image) +(defmodel ct-mark-box (ct-toggle ix-view) ((kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector) ) (:default-initargs --- /project/cello/cvsroot/cello/focus-utilities.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/focus-utilities.lisp 2006/06/26 17:05:20 1.4 @@ -65,7 +65,7 @@ ; 990329 /// kt Resurrect eventually ; (defmethod focus-scroll-into-view ((focus focus)) - ;; temp to get going (image-scroll-into-view focus) + ;; temp to get going (view-scroll-into-view focus) )
(defmethod focus-scroll-into-view (other) --- /project/cello/cvsroot/cello/focus.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/focus.lisp 2006/06/26 17:05:20 1.3 @@ -34,6 +34,8 @@ it without it being a kid there
|# +(eval-when (compile load eval) + (export '(^focus focus)))
(defmodel focuser (ix-canvas) ( --- /project/cello/cvsroot/cello/image.lisp 2006/06/11 17:52:06 1.6 +++ /project/cello/cvsroot/cello/image.lisp 2006/06/26 17:05:20 1.7 @@ -16,22 +16,16 @@
(in-package :cello)
+(eval-when (compile load eval) + (export '(ix-view))) ; ------------------------------------------------------
- -;;;(defmethod ix-render-prep (self) -;;; (declare (ignore self))) -;;; -;;;(defmethod ix-render-prep :after ((self family)) -;;; (dolist (k (^kids)) -;;; (ix-render-prep k))) - (defmodel ogl-quadric-based (ogl-node) ((quadric :initform nil :initarg :quadric :reader quadric)))
; ---------------------------------------------
-(defmodel image (geometer model) +(defmodel ix-view (ogl-node geometer model) (; ; visibility ; @@ -74,7 +68,7 @@
;;------- IXFamily ----------------------------- ;; -(defmodel ix-family (image family) +(defmodel ix-family (ix-view family) ( (styles :initform nil :reader styles :initarg :styles)
@@ -89,18 +83,30 @@ :reader kids-ever-shown) ))
-(defmodel ix-inline (geo-inline image)()) +(defmodel ix-inline (geo-inline ix-view)())
(defmodel ix-stack (ix-inline) () (:default-initargs :orientation :vertical))
-(defmodel ix-row (geo-row ix-inline) +(defmodel ix-row (ix-inline) () (:default-initargs :orientation :horizontal))
+(defmacro a-stack ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'stk) (ix-stack) + ,@stack-args + :fm-parent *parent* + :kids (c? (the-kids ,@dd-kids)))) + +(defmacro a-row ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'row) (ix-row) + ,@stack-args + :fm-parent *parent* + :kids (c? (the-kids ,@dd-kids)))) + (defmethod focus-starting ((self ix-family)) (some #'focus-find-first (kids self)))
@@ -109,7 +115,7 @@ `(let* ((,kid ,self)) (find-prior ,kid (kids (fm-parent ,kid))))))
-(defmethod md-awaken :after ((self image)) +(defmethod md-awaken :after ((self ix-view)) (assert (px self)) (assert (py self)) (assert (ll self)) @@ -117,16 +123,16 @@ (assert (lr self)) (assert (lb self)))
-(defmethod ogl-shared-resource-tender ((self image)) +(defmethod ogl-shared-resource-tender ((self ix-view)) .w.)
-(defmethod ogl-node-window ((self image)) +(defmethod ogl-node-window ((self ix-view)) .w.)
-(defmethod path ((self image)) +(defmethod path ((self ix-view)) (path (fm-parent self)))
-(defmethod ogl-dsp-list-prep progn ((self image)) +(defmethod ogl-dsp-list-prep progn ((self ix-view)) (ogl-dsp-list-prep (skin self)))
(defmethod ogl-dsp-list-prep progn ((self wand-texture)) @@ -134,7 +140,7 @@
(defmacro uskin () `(labels ((usk (self) - (when (typep self 'image) + (when (typep self 'ix-view) (or (skin self) (usk .parent))))) (usk self))) @@ -142,13 +148,13 @@ ;------------------------------ (defobserver mouse-over-p () (bwhen (p .parent) - (when (typep p 'image) + (when (typep p 'ix-view) (with-integrity(:change) (setf (mouse-over-p p) new-value)))))
-(defmethod ix-selectable ((self image)) nil) +(defmethod ix-selectable ((self ix-view)) nil)
-(defmethod ix-click-transparent ((self image)) +(defmethod ix-click-transparent ((self ix-view)) nil)
@@ -156,13 +162,13 @@ (etypecase v (number v) (v2 (v2-h v)) - (image (inset-h (inset v))))) + (ix-view (inset-h (inset v)))))
(defun inset-v (v) (etypecase v (number v) (v2 (v2-v v)) - (image (inset-h (inset v))))) + (ix-view (inset-h (inset v)))))
(defmethod call-^fillright (self filled padding) (- (inset-lr filled) @@ -173,7 +179,7 @@ (setf (px self) (v2-h new-offset)) (setf (py self) (v2-v new-offset)))
-(defmethod g-offset ((self image) &optional (accum-h 0) (accum-v 0)) +(defmethod g-offset ((self ix-view) &optional (accum-h 0) (accum-v 0)) (trc nil "goffset self" self 'px (px self) 'py (py self) 'fm-parent (fm-parent self)) (let ( (oh (+ accum-h (or (px self) 0))) @@ -194,7 +200,7 @@ (defmethod gunscaled (self value) (gunscaled (fm-parent self) value))
-(defmethod visible-fully ((self image)) ;; this used to be an :around on visible, but then focus-first +(defmethod visible-fully ((self ix-view)) ;; this used to be an :around on visible, but then focus-first (and (visible self) ;; could not find focus on page it was /going to/ (not yet visi) (or (null (fm-parent self)) ;; ...not sure who need visible to go up all the way (visible (fm-parent self))))) @@ -206,7 +212,7 @@ (defmethod visible ((other null)) (c-break "visible called on NIL"))
-(defmethod dbg-awake ((ap image)) +(defmethod dbg-awake ((ap ix-view)) (and (dbg-awake-num ap 'px) (dbg-awake-num ap 'py) (dbg-awake-num ap 'll) @@ -230,11 +236,11 @@
; ------------------- right-click -------------------------
-(defmethod make-menu-right-items ((self image)) +(defmethod make-menu-right-items ((self ix-view)) (bwhen (f (menu-right-items-factory self)) (funcall f self)))
-(defmethod menu-right-select ((self image) item) +(defmethod menu-right-select ((self ix-view) item) (when item (bwhen (h (menu-select-handler self)) (funcall h self item)))) --- /project/cello/cvsroot/cello/ix-polygon.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/ix-polygon.lisp 2006/06/26 17:05:20 1.3 @@ -17,7 +17,7 @@ (in-package :cello)
;------------------------------------------------------------ -(defmodel ix-polygon (image) +(defmodel ix-polygon (ix-view) ((fore-color :initarg :fore-color :initform +black+ :accessor fore-color) (poly-style :initarg :poly-style :initform nil :accessor poly-style) (poly-thickness :initarg :poly-thickness :initform (u96ths 1) :accessor poly-thickness) --- /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/26 17:05:20 1.5 @@ -88,7 +88,7 @@ (with-layers (:rgba (^text-color)))))))
-(defmethod ix-find-style ((self image) style-id) +(defmethod ix-find-style ((self ix-view) style-id) (or (find style-id (^gui-styles) :key 'id) (ix-find-style .parent style-id)))
@@ -104,7 +104,7 @@ (unless (ftgl::ftgl-disp-ready-p font) (setf (ftgl::ftgl-disp-ready-p font) t) (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font) - (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (round (ftgl::ftgl-size font)) (ftgl::ftgl-target-res font))) (ix-string-width self (display-text$ self))))) ;; ugh. make better. subclass must have display-text$
--- /project/cello/cvsroot/cello/ix-text.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/06/26 17:05:20 1.6 @@ -21,7 +21,7 @@ (eval-when (compile load eval) (export '(ix-paint)))
-(defmodel ix-text (ix-styled image) +(defmodel ix-text (ix-styled ix-view) ( (text$ :initform nil :initarg :text$ :accessor text$)
@@ -73,7 +73,7 @@ (unless (ftgl::ftgl-disp-ready-p font) (setf (ftgl::ftgl-disp-ready-p font) t) (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font) - (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (round (ftgl::ftgl-size font)) (ftgl::ftgl-target-res font))) (ix-string-width self (^display-text$)))))
(defmacro alabel (text &rest key-arg-pairs) @@ -109,37 +109,6 @@ 0)))
-(defmodel frame-rate-text (ix-text) - ((frame-rate :initarg :frame-rate :accessor frame-rate - :initform (c? (cons (now)(frame-ct .w.))))) - (:default-initargs - :style-id :button - :style (make-instance 'gui-style-ftgl - :id :button - :face *gui-style-button-face* - :sizes '(16 16 16 16 16) - :text-color +white+) - :inset (mkv2 (upts 2)(upts 0)) - ;;:lt 15 :lb -5 - :char-mask "999" - :text$ (let (last) - (c? (let ((this (^frame-rate))) - (prog1 - (cond - ((null last) - (setf last this) - "not yet") - ((> .5 (- (car this)(car last))) - .cache) - (t - (prog1 - (format nil "~3,1f" - (/ (- (cdr this) (cdr last)) - (- (car this) (car last)))) - (setf last this))) - ))))) - :lighting :off - :pre-layer (with-layers :off +red+ :on)))
#+(or) (format nil "~3,1f" pi) --- /project/cello/cvsroot/cello/lighting.lisp 2006/06/11 13:32:24 1.4 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/06/26 17:05:20 1.5 @@ -41,7 +41,7 @@
;;----------------------------------------------
-(defmodel ix-lit-scene () ;; mix in with ix-family +(defmodel ogl-lit-scene () ;; mix in with ix-family ( (clear-rgba :cell nil :initarg :clear-rgba :initform nil :accessor clear-rgba) (light-model :initarg :light-model :initform (list (cons gl_light_model_ambient *dim*)) @@ -70,7 +70,7 @@ :diffuse *average* :specular *bright*)))))
-(defmethod ix-paint :before ((self ix-lit-scene)) +(defmethod ix-paint :before ((self ogl-lit-scene)) (gl-enable gl_color_material) (when (eql :on (lighting self)) (trc nil "lighting on!" self) --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/11 13:32:24 1.4 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/26 17:05:20 1.5 @@ -24,7 +24,6 @@ (defparameter *skin6* nil)
(defun nehe-06 () ;; ACL project manager needs a zero-argument function, in project package - (setf ogl::*gl-begun* nil) (test-window 'nehe-06-demo))
(defmodel nehe-06-demo (window) @@ -35,7 +34,7 @@ (mk-stack (:packing (c?pack-self)) (make-instance 'nehe06 :fm-parent *parent* - :width 400 :height 400 + :width 700 :height 500 :timer-interval 2 #+later (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" --- /project/cello/cvsroot/cello/slider.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/slider.lisp 2006/06/26 17:05:20 1.4 @@ -16,7 +16,7 @@
(in-package :cello)
-(defmodel ct-jumper (control image)()) +(defmodel ct-jumper (control ix-view)())
(defun ix-slider-jumper-action (self e) (slider-set .parent --- /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/26 17:05:20 1.6 @@ -16,37 +16,5 @@
(in-package :cello)
-(defmethod ctk::togl-display-using-class ((self ix-togl)) - (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox - (c-stopped)) - (with-metrics (nil nil "ctk::togl-display-using-class") - (bif (dl (dsp-list self)) - (progn - (trc nil "window using disp list") - (gl-call-list (dsp-list self))) - (ix-paint self)))))
-(defmethod ctk::togl-timer-using-class ((self ix-togl)) - (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox - (c-stopped)) - (with-metrics (nil nil "ctk::togl-display-using-class") - (when (display-continuous self) - (trc nil "window-display > continuous specified so posting redisplay" self) - (ctk:togl-post-redisplay (ctk:togl-ptr self)))))) - -(defmethod ctk::do-on-key-down ((self ix-togl) &rest args &aux (keysym (car args))) - (funcall (if (schar keysym 1) 'do-cello-special-keydown 'do-cello-keydown) - (or (focus self) self) - (mk-os-event (keyboard-modifiers ctk::.tkw) (mkv2 0 0)))) - -(defmethod do-cello-keydown (self k event) - (declare (ignorable self k event))) - -(defmethod do-cello-special-keydown :around (self k event) - (when self - (unless (call-next-method) - (do-cello-special-keydown .parent k event)))) - -(defmethod do-cello-special-keydown (self k event) - (declare (ignorable self k event)))
--- /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/26 17:05:20 1.6 @@ -25,13 +25,13 @@
(defmethod do-double-click (self os-event &key) (declare (ignorable self os-event)) - ;;(trc "*** No special do-double-click for image, event:" self osEvent) + ;;(trc "*** No special do-double-click for ix-view, event:" self osEvent) nil)
; ------------------- right button --------------------------------------
(defun geo-dump (i) - (when (typep i 'image) + (when (typep i 'ix-view) (print (list :pxy (cons (px i)(py i)) :lt (lt i) :lb (lb i))) (geo-dump (fm-parent i))))
@@ -46,14 +46,14 @@ ;;(c-stop :inspecting) (inspect i))))))
-(defmethod do-right-button :around (image buttons wxwy) +(defmethod do-right-button :around (self buttons wxwy) (declare (ignorable buttons wxwy)) - (when image + (when self (or (call-next-method) - (do-right-button (fm-parent image) buttons wxwy)))) + (do-right-button (fm-parent self) buttons wxwy))))
-(defmethod do-right-button (image buttons wxwy) - (declare (ignorable image buttons wxwy))) +(defmethod do-right-button (self buttons wxwy) + (declare (ignorable self buttons wxwy)))
(defmethod do-menu-right (self buttons wxwy) (declare (ignorable buttons self wxwy))) @@ -82,8 +82,8 @@
; ---------------------- finding parts ------------------------------
-(defun mouseimage-control (w) - (fm-ascendant-if (mouse-image w) +(defun mouseview-control (w) + (fm-ascendant-if (mouse-view w) (lambda (node) (and (typep node 'control) (fully-enabled node)))))
--- /project/cello/cvsroot/cello/cello-window.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/cello-window.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #|
Copyright (C) 2004 by Kenneth William Tilton
This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cello)
;------------- Window --------------- ;
(defmodel cello-window (celtk:window focuser) ;; control ogl-shared-resource-tender) ( ;;; (mouse-pos :initarg :mouse-pos :initform (c-in nil) :accessor mouse-pos) ;logical coords. Try to maintain for now. ;;; ;;; (mouse-view :initarg :mouse-view :accessor mouse-view ;;; :initform (c? (let ((mp (^mouse-pos))) ;;; (trc nil "mouseview sees pos" .w. mp) ;;; (when mp ;;; (eko (nil "mouseview >" self) ;;; (without-c-dependency ;;; (find-ix-under self mp))))))) ;;; ;;; (mouse-control :initarg :mouse-control :accessor mouse-control ;;; :initform (c? (bwhen (node (^mouse-view)) ;;; (eko (nil "possible mousecontrol" node) ;;; (fm-ascendant-if node #'fully-enabled))))) ;;; ;;; (mouse-cursor :initarg :mouse-cursor :initform nil :accessor mouse-cursor) ;;; ;;; (mouse-up-evt :cell :ephemeral :initarg :mouse-up-evt :initform (c-in nil) :accessor mouse-up-evt) ;;; (mouse-down-evt :cell :ephemeral :initarg :mouse-down-evt :initform (c-in nil) :accessor mouse-down-evt) ;;; (double-click? :initform (c-in nil) :accessor double-click?) ;;; ;;; (tick-count :initarg :tick-count :initform (c-in nil) :accessor tick-count) ;;; (tick-fine :initarg :tick-fine :initform (c-in nil) :accessor tick-fine) (gl-name-highest :cell nil :initarg :gl-name-highest :initform 0 :accessor gl-name-highest)) (:default-initargs :px 0 :py 0 ;;:gl-name (c-in nil) ;;:focus (c-in nil) :ll 0 :lt 0 :lr (c-in (scr2log 1100)) :lb (c-in (scr2log -800)) ;; :tick-count (c-in (os-tickcount)) :event-handler 'cello-window-event-handler ))
(defmethod path ((self cello-window)) ".") (defmethod parent-path ((self cello-window)) "")
(defmethod cello-window-event-handler (self xe) (declare (ignorable self)) (TRC nil "cello-window-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) ) ; ; this next bit is actually offered as a template. suggest users subclass cello-window, ; specialize cello-window-event-handler on that subclass, handle what you want else ; call-next-method. eventually some generic stuff will be landing in here. ; (case (ctk::tk-event-type (ctk::xsv type xe)) (:virtualevent ) (:KeyPress ) (:KeyRelease ) (:ButtonPress ) (:ButtonRelease ) (:MotionNotify ) (:EnterNotify ) (:LeaveNotify ) (:FocusIn ) (:FocusOut ) (:KeymapNotify ) (:Expose ) (:GraphicsExpose ) (:NoExpose ) (:VisibilityNotify ) (:CreateNotify ) (:DestroyNotify ) (:UnmapNotify ) (:MapNotify ) (:MapRequest ) (:ReparentNotify ) (:ConfigureNotify ) (:ConfigureRequest ) (:GravityNotify ) (:ResizeRequest ) (:CirculateNotify ) (:CirculateRequest ) (:PropertyNotify ) (:SelectionClear ) (:SelectionRequest ) (:SelectionNotify ) (:ColormapNotify ) (:ClientMessage ) (:MappingNotify ) (:ActivateNotify ) (:DeactivateNotify ) (:MouseWheelEvent)))
(defmethod context-cursor (other kbd-modifiers) (if (and other (fm-parent other)) (context-cursor (fm-parent other) kbd-modifiers) (cello-cursor :arrow)))
(defun cello-cursor (cursor-id) (ecase cursor-id (:crosshair #+celtk 'crosshair #+glut GLUT_CURSOR_CROSSHAIR) (:arrow #+celtk 'arrow #+glut GLUT_CURSOR_LEFT_ARROW) (:i-beam #+celtk 'ibeam #+glut (break)) (:watch #+celtk 'watch #+glut (break))))
;------------------------------------------
(defmethod ix-selectable ((self cello-window)) t)
--- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #|
Copyright (C) 2004 by Kenneth William Tilton
This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cello)
(defgeneric ogl-dsp-list-prep (self) (:method-combination progn) (:documentation "Do stuff needed before render but not needed/wanted in display list"))
(defmethod ogl-dsp-list-prep progn (self) (declare (ignore self)) (assert (not *ogl-listing-p*)))
(defvar *ogl-shared-resource-tender*)
(defclass ogl-shared-resource-tender () ((display-lists :initform nil :accessor display-lists) (quadrics :initform nil :accessor quadrics) (textures :initform nil :accessor textures)))
(defmethod not-to-be :before ((self ogl-shared-resource-tender)) (loop for (nil . dl) in (display-lists self) do (gl-delete-lists dl 1) finally (setf (display-lists self) nil)) (loop for (nil . q) in (quadrics self) do (glu-delete-quadric q)))
(defmethod ogl-shared-resource-tender ((self ogl-shared-resource-tender)) self)
(defmethod ogl-shared-resource-tender (other) (c-break "ogl-shared-resource-tender undefined for ~a" other))
(defmethod ogl-node-window (other) (c-break "ogl-node-window undefined for ~a" other))
(define-symbol-macro .og. (or (ogl-context self) (setf (ogl-context self) (upper self ctk::togl))))
(defmodel ogl-node () ((ogl-context :cell nil :initform nil :accessor ogl-context) (dsp-list :initarg :dsp-list :accessor dsp-list :initform (c-formula (:lazy :until-asked) (assert (not *ogl-listing-p*)) (progn (ogl-dsp-list-prep self) (when (without-c-dependency (every 'dsp-list (kids self))) (let ((display-list-name (or .cache (gl-gen-lists 1))) (*ogl-shared-resource-tender* (ogl-shared-resource-tender self))) (gl-new-list display-list-name gl_compile) (trc nil "starting display list" display-list-name self) (let ((*ogl-listing-p* self) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "ix-paint" self) (ix-paint self))) (trc nil "finished display list" display-list-name self) (gl-end-list) (setf (redisplayp .og.) t) display-list-name))))) (gl-name :initarg :gl-name :initform nil :accessor gl-name)))
(defun render (self) (let (*selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "ix-paint" self) (trc nil "render" self (^height)) (ix-paint self))))
(defmodel ogl-family () ()
(:default-initargs :gl-name (c? (incf (gl-name-highest .w.))) :clipped nil))
(defobserver dsp-list () (when old-value (gl-delete-lists old-value 1)))
(defmethod not-to-be :after ((self ogl-node)) (bwhen (dl (slot-value self 'dsp-list)) ;; don't trigger lazy cell (gl-delete-lists dl 1)))
--- /project/cello/cvsroot/cello/ix-paint.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #|
Copyright (C) 2004 by Kenneth William Tilton
This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cello)
(defmethod ix-paint :after ((self family)) (dolist (k (kids self)) (trc nil "ixr geo" k (list (px k)(py k)) (list (ll k)(lt k)(lr k)(lb k))) (trc nil "render kid pxy" k (px k)(py k) :rpos-before (ogl-get-boolean gl_current_raster_position_valid) (ogl-raster-pos-get)) (c-assert (px k) () "pX is null in ~a" k) (c-assert (py k) () "pY is null in ~a" k)
(count-it :call-list) (if (dsp-list k) (progn (trc nil "ix-paint calling list" (dsp-list k)) (gl-call-list (dsp-list k))) (ix-paint k))))
(defun rpchk (id pfail psucc &optional self) (declare (ignorable pfail)) (if (not (ogl-get-boolean gl_current_raster_position_valid)) (trc nil "rasterpos INVALID" id :self self :rpos (ogl-raster-pos-get)) (trc psucc "rasterpos OK" id :self self (ogl-raster-pos-get))))
(defmethod ix-paint (self) (declare (ignorable self)) (trc nil "ix-paint fell through" self (class-of self)))
(defmacro with-ogl-isolation (&body body) `(with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) ,@body))
(let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self ix-view) &aux (n (gl-name self))) (trc nil "painting, shifting bitmap" self n (^px)(^py) (pre-layer self)) (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0)
(when n (trc "pushing 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))) (progn ;;with-clipping (self) (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (count-it :ix-render) #+(or) (count-it :ix-paint (type-of self)) #+(or) (unless (kids self) (count-it :ix-render-atom)) (trc nil "ix painting" self (lighting self)) (with-matrix () (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))))
(defmethod ix-render-layer ((nada null) g-box) (break "NIL layer detected" g-box))
(defmethod ix-render-layer :around (key g-box) (declare (ignore g-box)) (count-it :render-layer) (count-it :render-layer (type-of key)) (call-next-method))
;------------------- --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #|
Copyright (C) 2004 by Kenneth William Tilton
This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cello)
(eval-when (compile load eval) (export '(ix-togl-event-handler)))
;------------- Window --------------- ;
(defmodel ix-togl ( #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view) ( (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp) (display-continuous :initarg :display-continuous :initform nil :accessor display-continuous) (activep :initarg :activep :initform nil :accessor activep)
(mouse-pos :initarg :mouse-pos :initform (c-in nil) :accessor mouse-pos) ;logical coords. Try to maintain for now.
(mouse-view :initarg :mouse-view :accessor mouse-view :initform (c? (let ((mp (^mouse-pos))) (trc nil "mouseview sees pos" .w. mp) (when mp (eko (nil "mouseview >" self) (without-c-dependency (find-ix-under self mp)))))))
(mouse-control :initarg :mouse-control :accessor mouse-control :initform (c? (bwhen (node (^mouse-view)) (eko (nil "possible mousecontrol" node) (fm-ascendant-if node #'fully-enabled)))))
(mouse-up-evt :cell :ephemeral :initarg :mouse-up-evt :initform (c-in nil) :accessor mouse-up-evt) (mouse-down-evt :cell :ephemeral :initarg :mouse-down-evt :initform (c-in nil) :accessor mouse-down-evt) (double-click? :initform (c-in nil) :accessor double-click?)
(tick-count :initarg :tick-count :initform (c-in nil) :accessor tick-count) (tick-fine :initarg :tick-fine :initform (c-in nil) :accessor tick-fine) ) (:default-initargs :px 0 :py 0 :gl-name (c-in nil) :activep (c-in nil) :clear-rgba (list 0 0 0 1)
:ll 0 :lt 0 :lr (c-in (scr2log 1100))
[257 lines skipped]