[cello-cvs] CVS cello

ktilton ktilton at common-lisp.net
Mon Jun 26 17:05:20 UTC 2006


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)
+      , at stack-args
+     :fm-parent *parent*
+     :kids (c? (the-kids , at dd-kids))))
+
+(defmacro a-row ((&rest stack-args) &body dd-kids)
+  `(mk-part ,(copy-symbol 'row) (ix-row)
+      , at stack-args
+     :fm-parent *parent*
+     :kids (c? (the-kids , at dd-kids))))
+
 (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)
     , at 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]



More information about the Cello-cvs mailing list