From ktilton at common-lisp.net  Sun Jun 15 17:05:13 2008
From: ktilton at common-lisp.net (ktilton)
Date: Sun, 15 Jun 2008 13:05:13 -0400 (EDT)
Subject: [cello-cvs] CVS cello/cl-freetype
Message-ID: <20080615170513.D5A6581009@common-lisp.net>

Update of /project/cello/cvsroot/cello/cl-freetype
In directory clnet:/tmp/cvs-serv21009/cl-freetype

Log Message:
Directory /project/cello/cvsroot/cello/cl-freetype added to the repository





From ktilton at common-lisp.net  Sun Jun 15 17:07:02 2008
From: ktilton at common-lisp.net (ktilton)
Date: Sun, 15 Jun 2008 13:07:02 -0400 (EDT)
Subject: [cello-cvs] CVS cello/cl-freetype
Message-ID: <20080615170702.2167F81029@common-lisp.net>

Update of /project/cello/cvsroot/cello/cl-freetype
In directory clnet:/tmp/cvs-serv21245/cl-freetype

Added Files:
	cl-freetype.asd cl-freetype.lisp cl-freetype.lpr cl-rsrc.lisp 
	ft-defs.lisp ft-functions.lisp ft-test.lisp 
Log Message:
Unfinished (a bit) Lisp freetype hack by Yusuke Shinyama, no guarantees on the spelling


--- /project/cello/cvsroot/cello/cl-freetype/cl-freetype.asd	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/cl-freetype.asd	2008/06/15 17:07:02	1.1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

;; cl-freetype.asd

(in-package :asdf)

(defsystem cl-freetype
    :name "cl-freetype"
  :author "Yusuke Shinyama <yusuke at cs dot nyu dot edu>"
  :version "0.1"
  :depends-on (:cffi-extender :cl-rsrc)
  :serial t
  :components ((:file "cl-freetype")
               (:file "ft-defs")
               (:file "ft-functions")))
    
--- /project/cello/cvsroot/cello/cl-freetype/cl-freetype.lisp	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/cl-freetype.lisp	2008/06/15 17:07:02	1.1
;;;  cl-freetype
;;;

(defpackage #:cl-freetype
  (:nicknames #:ft)
  (:use #:common-lisp #:ffx #:cffi-uffi-compat #:cl-rsrc)
  (:export #:*freetype-dynamic-lib-path*
	   #:*default-face*
	   #:*face-registry*

	   ;; these should be moved to somewhere else.
	   #:get-lisp-object
	   #:with-lisp-pointer
	   
	   #:initialize-ft
	   #:done-ft
	   #:with-ft-face
	   #:get-new-face
	   #:with-ft-memory-face
	   #:get-new-memory-face
	   #:done-face
	   #:set-char-size
	   #:set-pixel-sizes
	   #:get-char-index
	   #:get-kerning
	   #:load-glyph
	   #:load-char
	   #:render-glyph
	   #:get-first-char
	   #:get-next-char
	   #:get-postscript-name

	   #:get-face-spec
	   #:get-face-by-spec
	   #:get-face
	   
	   #:ft-glyph-format/none
	   #:ft-glyph-format/composite
	   #:ft-glyph-format/bitmap
	   #:ft-glyph-format/outline
	   #:ft-glyph-format/plotter
	   
	   #:ft-encoding/none
	   #:ft-encoding/ms-symbol
	   #:ft-encoding/unicode
	   #:ft-encoding/sjis
	   #:ft-encoding/gb2312
	   #:ft-encoding/big5
	   #:ft-encoding/wansung
	   #:ft-encoding/johab
	   #:ft-encoding/ms-sjis
	   #:ft-encoding/ms-gb2312
	   #:ft-encoding/ms-big5
	   #:ft-encoding/ms-wansung
	   #:ft-encoding/ms-johab
	   #:ft-encoding/adobe-standard
	   #:ft-encoding/adobe-expert
	   #:ft-encoding/adobe-custom
	   #:ft-encoding/adobe-latin-1
	   #:ft-encoding/old-latin-2
	   #:ft-encoding/apple-roman

	   #:ft-render-mode/normal
	   #:ft-render-mode/mono
	   #:ft-render-mode/light
	   #:ft-render-mode/lcd
	   #:ft-render-mode/lcd-v
	   #:ft-render-mode/max

	   #:ft-pixel-mode/none
	   #:ft-pixel-mode/mono
	   #:ft-pixel-mode/grays
	   #:ft-pixel-mode/gray2
	   #:ft-pixel-mode/gray4
	   #:ft-pixel-mode/lcd
	   #:ft-pixel-mode/lcd-v

	   #:ft-outline/none
	   #:ft-outline/owner
	   #:ft-outline/even-odd-fill
	   #:ft-outline/reverse-fill
	   #:ft-outline/ignore-dropouts

	   #:ft-get-tag
	   #:ft-curve-tag/on
	   #:ft-curve-tag/conic
	   #:ft-curve-tag/cubic

	   #:ft-kerning/default
	   #:ft-kerning/unfitted
	   #:ft-kerning/unscaled

	   #:ft-face-flag/scalable
	   #:ft-face-flag/fixed-sizes
	   #:ft-face-flag/fixed-width
	   #:ft-face-flag/sfnt
	   #:ft-face-flag/horizontal
	   #:ft-face-flag/vertical
	   #:ft-face-flag/kerning
	   #:ft-face-flag/fast-glyphs
	   #:ft-face-flag/multiple-masters
	   #:ft-face-flag/glyph-names
	   #:ft-face-flag/external-stream

	   #:ft-load/default
	   #:ft-load/no-scale
	   #:ft-load/no-hinting
	   #:ft-load/render
	   #:ft-load/no-bitmap
	   #:ft-load/vertical-layout
	   #:ft-load/force-autohint
	   #:ft-load/crop-bitmap
	   #:ft-load/pedantic
	   #:ft-load/ignore-global-advance-width
	   #:ft-load/no-recurse
	   #:ft-load/ignore-transform
	   #:ft-load/monochrome
	   #:ft-load/linear-design
	   #:ft-load/sbits-only
	   #:ft-load/no-autohint

	   #:ft-has-kerning
	   #:ft-is-scalable
	   #:from-ft
	   #:to-ft

	   #:ft-vector
	   #:ft-vector/y
	   #:ft-vector/x

	   #:ft-bbox
	   #:ft-bbox/xmin
	   #:ft-bbox/ymin
	   #:ft-bbox/xmax
	   #:ft-bbox/ymax

	   #:ft-generic
	   #:ft-generic/data
	   #:ft-generic/finalizer

	   #:ft-bitmap-size
	   #:ft-bitmap-size/width
	   #:ft-bitmap-size/height
	   #:ft-bitmap-size/size
	   #:ft-bitmap-size/x-ppem
	   #:ft-bitmap-size/y-ppem

	   #:ft-glyph-metrics
	   #:ft-glyph-metrics/width
	   #:ft-glyph-metrics/height
	   #:ft-glyph-metrics/vert-advance
	   #:ft-glyph-metrics/vert-bearing/y
	   #:ft-glyph-metrics/vert-bearing/x
	   #:ft-glyph-metrics/hori-advance
	   #:ft-glyph-metrics/hori-bearing/y
	   #:ft-glyph-metrics/hori-bearing/x

	   #:ft-sizerec
	   #:ft-sizerec/metrics/x-scale
	   #:ft-sizerec/metrics/y-scale
	   #:ft-sizerec/metrics/x-ppem
	   #:ft-sizerec/metrics/y-ppem
	   #:ft-sizerec/metrics/ascender
	   #:ft-sizerec/metrics/descender
	   #:ft-sizerec/metrics/height
	   #:ft-sizerec/metrics/max-advance
	   
	   #:ft-charmaprec
	   #:ft-charmaprec/face
	   #:ft-charmaprec/encoding
	   #:ft-charmaprec/platform-id
	   #:ft-charmaprec/encoding-id

	   #:ft-bitmap
	   #:ft-bitmap/n-contours
	   #:ft-bitmap/contours
	   #:ft-bitmap/n-points
	   #:ft-bitmap/tags
	   #:ft-bitmap/points
	   #:ft-bitmap/flags

	   #:ft-facerec/num-faces
	   #:ft-facerec/face-index
	   #:ft-facerec/face-flags
	   #:ft-facerec/style-flags
	   #:ft-facerec/num-glyphs
	   #:ft-facerec/family-name
	   #:ft-facerec/style-name
	   #:ft-facerec/num-charmaps
	   #:ft-facerec/charmaps
	   #:ft-facerec/units-per-em
	   #:ft-facerec/ascender
	   #:ft-facerec/descender
	   #:ft-facerec/height
	   #:ft-facerec/max-advance-width
	   #:ft-facerec/max-advance-height
	   #:ft-facerec/bbox/ymin
	   #:ft-facerec/bbox/ymax
	   #:ft-facerec/bbox/xmin
	   #:ft-facerec/bbox/xmax
	   #:ft-facerec/size
	   #:ft-facerec/charmap

	   #:ft-glyphslotrec/metrics/width
	   #:ft-glyphslotrec/metrics/height
	   #:ft-glyphslotrec/metrics/vert-advance
	   #:ft-glyphslotrec/metrics/vert-bearing/y
	   #:ft-glyphslotrec/metrics/vert-bearing/x
	   #:ft-glyphslotrec/metrics/hori-advance
	   #:ft-glyphslotrec/metrics/hori-bearing/y
	   #:ft-glyphslotrec/metrics/hori-bearing/x
	   #:ft-glyphslotrec/advance/x
	   #:ft-glyphslotrec/advance/y
	   #:ft-glyphslotrec/format
	   #:ft-glyphslotrec/bitmap-top
	   #:ft-glyphslotrec/bitmap-left
	   #:ft-glyphslotrec/bitmap/rows
	   #:ft-glyphslotrec/bitmap/width
	   #:ft-glyphslotrec/bitmap/pitch
	   #:ft-glyphslotrec/bitmap/pixel-mode
	   #:ft-glyphslotrec/bitmap/buffer
	   #:ft-glyphslotrec/outline/flags
	   #:ft-glyphslotrec/outline/tags
	   #:ft-glyphslotrec/outline/n-points
	   #:ft-glyphslotrec/outline/points
	   #:ft-glyphslotrec/outline/n-contours
	   #:ft-glyphslotrec/outline/contours

	   ))

(in-package :cl-freetype)


(defparameter *freetype-dynamic-lib-path* 
  #+(or mswindows win32)
  #p"/windows/system32/freetype6.dll"

  #+(or darwin macosx)
  #p"/usr/X11R6/lib/libfreetype.dylib"
)

(defparameter *default-face* :courier)

(defparameter *face-registry*
  #+(or win32 mswindows)
  '((:helvetica :file #p"/windows/fonts/arial.ttf")
    (:helvetica-bold :file #p"/windows/fonts/arialbd.ttf")
    (:helvetica-italic :file #p"/windows/fonts/ariali.ttf")
    (:helvetica-bold-italic :file #p"/windows/fonts/arialbi.ttf")
    (:courier :file #p"/windows/fonts/cour.ttf")
    (:courier-bold :file #p"/windows/fonts/courbd.ttf")
    (:courier-italic :file #p"/windows/fonts/couri.ttf")
    (:courier-bold-italic :file #p"/windows/fonts/courbi.ttf")
    (:times :file #p"/windows/fonts/times.ttf")
    (:times-bold :file #p"/windows/fonts/timesbd.ttf")
    (:times-italic :file #p"/windows/fonts/timesi.ttf")
    (:times-bold-italic :file #p"/windows/fonts/timesbi.ttf")
    (:symbol :file #p"/windows/fonts/symbol.ttf")
    )

  #+(or darwin macosx)
  '((:helvetica :rsrc #p"/System/Library/Fonts/Helvetica.dfont" "Helvetica")
    (:helvetica-bold :rsrc #p"/System/Library/Fonts/Helvetica.dfont" "Helvetica Bold")
    (:courier :rsrc #p"/System/Library/Fonts/Courier.dfont" "Courier")
    (:courier-bold :rsrc #p"/System/Library/Fonts/Courier.dfont" "Courier Bold")
    (:times :rsrc #p"/System/Library/Fonts/Times.dfont" "Times")
    (:times-bold :rsrc #p"/System/Library/Fonts/Times.dfont" "Times Bold")
    (:times-italic :rsrc #p"/System/Library/Fonts/Times.dfont" "Times Italic")
    (:times-bold-italic :rsrc #p"/System/Library/Fonts/Times.dfont" "Times Bold Italic")
    (:symbol :rsrc #p"/System/Library/Fonts/Symbol.dfont" "Symbol")
    (:zapf-dingbats :rsrc #P"/System/Library/Fonts/ZapfDingbats.dfont" "Zapf Dingbats")
    )
  )

; strint32:
;   Converts 4-char string into 32bit int.
;   ex. (strint32 "abcd") -> ((('a'*256)+'b')*256)+'c')*256+'d'
(defmacro strint32 (str)
  (assert (= (length str) 4))
  (reduce (lambda (r c) (logior (* 256 r) (char-code c)))
	  str :initial-value 0))

; def-struct-rec:
;
;   This allows you to define a struct within another struct:
;     (def-struct-rec :point (x :int) (y :int))
;     (def-struct-rec :rect (topleft :point) (bottomright :point))
;
;   You can access fields as follows:
;     (point/x point1)
;     (rect/topleft/x rect1)
;
;   NOTICE: you should use this macro for *all* structs
;           which can be recursively included in other structs.
;
(eval-when (compile load eval)
  (defvar *recursive-structs* nil))
(defmacro def-struct-rec (typename &rest decls)
  (declare (special *recursive-structs*))
  (labels ((expand1 (prefix decl)
	     (let* ((fname (if prefix 
			       (intern (concatenate 'string 
						    (symbol-name prefix) "/"
						    (symbol-name (car decl))))
			       (car decl)))
		    (ftype (cadr decl))
		    (struct1 (assoc ftype *recursive-structs*)))
	       (if struct1
		   (apply 'append (mapcar (lambda (d) (expand1 fname d)) (cdr struct1)))
		   (list (list fname ftype))))))
    (let* ((expanded 
	    (apply 'append
		   (mapcar (lambda (d) (expand1 nil d)) decls)))
	   (accessors
	    (apply 'append
		   (mapcar (lambda (d)
			     (let* ((slotname (car d))
				    (funcname (intern
					       (concatenate 'string
							    (string-left-trim ":" (symbol-name typename)) "/" 
							    (symbol-name slotname))))
				    )
			       `((defun ,funcname (struct) 
				   (get-slot-value struct (quote ,typename) (quote ,slotname)))
				 (defun (setf ,funcname) (value struct)
				   (setf (get-slot-value struct (quote ,typename) (quote ,slotname)) value))
				 )
			       ))
			   expanded)))
	   )
    (push (cons typename expanded) *recursive-structs*)
    `(progn (def-struct ,typename , at expanded)
	    , at accessors))))


;  Utility to carry lisp objects within callbacks.
;
;  usage:
;    (ff-defun-callable :cdecl :void mycallback ((* :void) mydata)
;      (get-lisp-object mydata))
;
;    (with-lisp-pointer (mydata (make-my-lisp-object))
;      (register-callback (ff-register-callable 'mycallback))
;      (some-foreign-function mydata)
;    )
;
(defvar *working-objects* (make-hash-table))

(defun get-lisp-object (objid)
  (gethash (pointer-address objid) *working-objects*))

(defun deregister-lisp-object (objid)
  (remhash (pointer-address objid) *working-objects*))

(defun register-lisp-object (objid object)
  (assert (not (gethash (pointer-address objid) *working-objects*)))
  (setf (gethash (pointer-address objid) *working-objects*) object))

(defmacro with-lisp-pointer ((var form) &body body)
  `(with-foreign-object (,var :int)
     (register-lisp-object ,var ,form)
     , at body
     (deregister-lisp-object ,var))
  )


;;  Face manager
;;
(defun get-face-spec (face-name)
  (let ((p (or (assoc face-name *face-registry*)
	       (assoc *default-face* *face-registry*))))
    (format t "get-face-spec: ~a~%" p)
    (when (not p)
      (error "Face not found: ~a" face-name))
    (case (cadr p)
      (:file
       (list :face-file (caddr p)))
      (:rsrc
       (destructuring-bind (rsrc-path rsrc-name) (cddr p)
	 (list :face-data (with-rsrc-fork (resfork rsrc-path)
			    (or (get-resource-by-name resfork "sfnt" rsrc-name)
				(error "Not found: ~a in ~a" rsrc-name rsrc-path))))))
      (else
       (error "Illegal face-spec: ~a" p))

[27 lines skipped]
--- /project/cello/cvsroot/cello/cl-freetype/cl-freetype.lpr	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/cl-freetype.lpr	2008/06/15 17:07:02	1.1

[121 lines skipped]
--- /project/cello/cvsroot/cello/cl-freetype/cl-rsrc.lisp	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/cl-rsrc.lisp	2008/06/15 17:07:02	1.1

[306 lines skipped]
--- /project/cello/cvsroot/cello/cl-freetype/ft-defs.lisp	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/ft-defs.lisp	2008/06/15 17:07:02	1.1

[723 lines skipped]
--- /project/cello/cvsroot/cello/cl-freetype/ft-functions.lisp	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/ft-functions.lisp	2008/06/15 17:07:02	1.1

[864 lines skipped]
--- /project/cello/cvsroot/cello/cl-freetype/ft-test.lisp	2008/06/15 17:07:02	NONE
+++ /project/cello/cvsroot/cello/cl-freetype/ft-test.lisp	2008/06/15 17:07:02	1.1

[1048 lines skipped]


From ktilton at common-lisp.net  Mon Jun 16 12:39:26 2008
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 16 Jun 2008 08:39:26 -0400 (EDT)
Subject: [cello-cvs] CVS cello
Message-ID: <20080616123926.431854060@common-lisp.net>

Update of /project/cello/cvsroot/cello
In directory clnet:/tmp/cvs-serv9119

Modified Files:
	cello-magick.lisp cello-window.lisp control.lisp 
	ctl-selectable.lisp ctl-toggle.lisp focus-navigation.lisp 
	focus-utilities.lisp focus.lisp image.lisp ix-styled.lisp 
	ix-text.lisp ix-togl.lisp lighting.lisp mouse-click.lisp 
	window-utilities.lisp wm-mouse.lisp 
Log Message:
nothing special

--- /project/cello/cvsroot/cello/cello-magick.lisp	2007/02/02 20:11:00	1.7
+++ /project/cello/cvsroot/cello/cello-magick.lisp	2008/06/16 12:39:20	1.8
@@ -53,6 +53,8 @@
       (ogl::glec :snapshot)
       (record-frame recording pixels columns rows))))
 
+(export! ix-image-file)
+
 (defmd ix-image-file (ix-view)
   (:documentation "Quick way to drop a view of a binary JPG, PNG, GIF, etc into a Cello window")
   image-path
--- /project/cello/cvsroot/cello/cello-window.lisp	2008/04/11 09:22:46	1.8
+++ /project/cello/cvsroot/cello/cello-window.lisp	2008/06/16 12:39:20	1.9
@@ -33,6 +33,7 @@
     :lb (c-in (scr2log -800))
     ;; :tick-count (c-in (os-tickcount))
     :event-handler 'cello-window-event-handler
+    :registry? t
     ))
 
 (defmethod path ((self cello-window))  ".")
--- /project/cello/cvsroot/cello/control.lisp	2008/04/11 09:22:46	1.10
+++ /project/cello/cvsroot/cello/control.lisp	2008/06/16 12:39:20	1.11
@@ -15,7 +15,7 @@
 |#
 
 (in-package :cello)
-(export! control enabled ^enabled ct-action-lambda
+(export! control enabled ^enabled ct-action-lambda sound ^sound
   tool-tip tool-tip-show? click-evt ^click-evt ^mouse-over? mouse-over?)
 
 (defmd control ()
@@ -26,12 +26,11 @@
   (ct-action nil :cell nil)
   sound
   click-repeat-p
-  #+hunh? (click-repeat-event (c? (bwhen (c (^click-evt))
-                            (let ((age (f-sensitivity :age (0.1)
-                                         (click-age c ))))
-                              (when (> age 0.5) age)))))
+
   (mouse-up-handler nil :documentation "Menus use this")
   (click-evt (c-in nil))
+  (double-click-evt (c-in nil))
+  (double-click-action (c-in nil))
   (click-tolerance (mkv2 0 0) :cell nil)
   (key-evt nil :cell :ephemeral)
   (enabled t)
@@ -49,6 +48,17 @@
 
 (defmethod user-errors (other) (declare (ignore other)))
 
+(defmethod do-double-click ((self control) )
+  (b-when a (^double-click-action)
+    (trc "control sees defmethod" self a)
+    (funcall a self)
+    t)) ;; ie, handled
+
+(export! control-trigger)
+(defun control-trigger (self &key even-if-disabled)
+  (when (or even-if-disabled (^enabled))
+    (funcall (ct-action self) self nil)))
+
 (defmethod tool-tip-show? (other)
   (declare (ignore other))
   nil)
@@ -65,12 +75,6 @@
 
 (defmethod kb-selector (other) (declare (ignore other)) nil)
 
-(defobserver click-repeat-event ()
-  (with-integrity (:change :obs-click-repeat-event)
-    (when new-value
-      (bwhen (f (ct-action self))
-        (funcall f self (os-event (^click-evt))))))) ;; /// make fresh event with new time
-
 (defmethod enabled (other)(assert other) nil)
 
 (defmethod do-cello-keydown ((self control) k event)
--- /project/cello/cvsroot/cello/ctl-selectable.lisp	2008/04/11 09:22:47	1.5
+++ /project/cello/cvsroot/cello/ctl-selectable.lisp	2008/06/16 12:39:20	1.6
@@ -31,9 +31,10 @@
 
 (defmd ct-selector-ex (ct-selector) ;; mixin at any node containing ct.selectable.ex's
   (selected-key (c-in nil))
-  :selection (c? (let (sel)
+  :selection (c? (ekx new-seletcion!!!!!!
+                   let (sel)
                    (bwhen (skey (^selected-key))
-                     ;(trc "sel rule runs" self skey .cache)
+                     (trc "sel rule runs" self skey .cache)
                      (fm-traverse self
                        (lambda (node)
                          (when (typep node 'ct-selectable-ex)
@@ -113,7 +114,7 @@
 (defmd ct-selectable-ex (control)
   (selected-key (c-in nil))
   (selectedp (c? (bwhen (selector (ct-selector self))
-                   ;;(trc "selectable-ex selectedp sees"  (selection selector))
+                   (trc "selectable-ex selectedp sees" self (^value) selector (selected-key selector) (selection selector))
                    (bwhen (skey (selected-key selector))
                      (eql (^selected-key) skey)))))
   :ct-action 'ct-selectable-ex-act)
--- /project/cello/cvsroot/cello/ctl-toggle.lisp	2008/04/11 09:22:47	1.12
+++ /project/cello/cvsroot/cello/ctl-toggle.lisp	2008/06/16 12:39:20	1.13
@@ -93,7 +93,7 @@
     :transition-fn 'ctfsm-transition-fn
 
    :ct-action (ct-action-lambda
-               (trc "twister ct-action" self event)
+               ;(trc "twister ct-action" self event)
                (with-integrity (:change :ctfsm-action)
                  (let ((newv (funcall (transition-fn self) self (value self) (states self))))
                    (ct-fsm-assume-value self newv))))))
--- /project/cello/cvsroot/cello/focus-navigation.lisp	2008/04/11 09:22:47	1.3
+++ /project/cello/cvsroot/cello/focus-navigation.lisp	2008/06/16 12:39:20	1.4
@@ -19,7 +19,7 @@
 ;_____________________ N a v i g a t i o n  ____________________
 ;
 (defun focus-navigate (old new &optional leave-old)
-  #+xxx (trc "focus-navigate > old, new" old new)
+  #+x42 (trc "focus-navigate > old, new" old new)
   ;; (c-assert new) ;; 990810kt i don't remember if we navigate to nil (should tho) ///
 
   (when (eql old new)
--- /project/cello/cvsroot/cello/focus-utilities.lisp	2008/04/11 09:22:47	1.6
+++ /project/cello/cvsroot/cello/focus-utilities.lisp	2008/06/16 12:39:20	1.7
@@ -38,20 +38,26 @@
       (focus-find-first self)
       (focus-find-first self :tab-stop-only nil)))
 
+(export! focus-on)
+
 (defmethod focus-on (self &optional focuser)
   (c-assert (or self focuser))
   #+xxx (trc "focus.on self, focuser" self focuser .focuser (focus-state .focuser))
   ;; (break "focus.on self, focuser")
   (setf (focus (or focuser .focuser)) self))
 
-(defmethod focus-gain (self)
-   (declare (ignore self)))
-
-(defmethod focus-lose (self new-focus)
-  (if self
-      (focus-lose (fm-parent self) new-focus)
-    t) ;; means "yielded"
-  )
+(defgeneric focus-gain (self)
+  (:method (self) (declare (ignore self)))
+  (:method ((self focus)) (setf (^focused-on) t)))
+
+(defgeneric focus-lose (self new-focus)
+  (:method (self new-focus) (if self
+                      (focus-lose (fm-parent self) new-focus)
+                    t))
+  (:method :around ((self focus) new-focus)
+    (declare (ignore new-focus))
+    (when (call-next-method)
+      (setf (^focused-on) nil))))
 
 ;________________________________ I d l i n g _______________________
 ;
--- /project/cello/cvsroot/cello/focus.lisp	2008/04/11 09:22:47	1.7
+++ /project/cello/cvsroot/cello/focus.lisp	2008/06/16 12:39:20	1.8
@@ -22,10 +22,10 @@
 
 ;;; also got FFComposite rule deciding it was active if any kid was
 
-arrange for Focuser to process clicks and keys first, then mebbe dump into dvk, do-click/do-double-click
+arrange for Focuser to process clicks and keys first, then mebbe dump into dvk,
 bottom up from focus/imageunder
 
-arrange for Controller to process clicks first, then mebbe dump into do-click/do-double-click
+arrange for Controller to process clicks first, then mebbe dump into 
 bottom up from focus/imageunder
 
 add finalization for radio button (look at others, see if ICR can ne de-celled
@@ -68,6 +68,8 @@
       (focus-gain new-focus))
     (call-next-method)))
 
+(export! focused-on ^focused-on)
+
 (defmodel focus ()
   ((focus-thickness :cell nil :initarg :focus-thickness
                    :initform (u96ths 3)
@@ -111,7 +113,9 @@
 
 (defgeneric focus-handle-keysym (self keysym)
   (:method :around (self keysym)
-    (unless (call-next-method)
+    (progn ;; unless
+      (call-next-method)
+      ;; (trc "unhandled so parent?" .parent)
       (when .parent
         (focus-handle-keysym .parent keysym))))
   (:method (self keysym) (declare (ignore self keysym)) nil))
--- /project/cello/cvsroot/cello/image.lisp	2008/04/11 09:22:47	1.19
+++ /project/cello/cvsroot/cello/image.lisp	2008/06/16 12:39:20	1.20
@@ -44,7 +44,7 @@
   recording
   (snapshot-pathnamer nil :cell nil)
   (snapshot-release-id :initarg :snapshot-release-id
-      :initform (c-in nil) :accessor snapshot-release-id)
+      :initform nil #+please (c-in nil) :accessor snapshot-release-id)
   ps3 ; persistence
 
   ; cached calculations
@@ -180,6 +180,7 @@
      :fm-parent *parent*
      :kids (c? (the-kids , at dd-kids))))
 
+(export! ix-kid-sized)
 (defmodel ix-kid-sized (geo-kid-sized ix-family)())
 (defmodel ix-inline (geo-inline ix-view)())
 (defobserver .kids ((self ix-inline))
@@ -349,7 +350,7 @@
         (dbg-awake-num ap 'lb)
         )
    #+nope (unless (>= (lb ap) (lt ap)) ;; this happens normally as structures get "collapsed" etc
-            (inspect ap)
+            
             (error 'x-systemfatal :app-func 'dbg-awake :error-text "Bottom less than top: self, lT, height, lB"
               :other-data (list ap  (lt ap) (l-height ap) (lb ap))))
    (call-next-method))
--- /project/cello/cvsroot/cello/ix-styled.lisp	2008/04/11 09:22:48	1.8
+++ /project/cello/cvsroot/cello/ix-styled.lisp	2008/06/16 12:39:20	1.9
@@ -50,6 +50,7 @@
   `(call-with-styles (list , at custom-styles) (lambda () , at body)))
 
 (defun call-with-styles (styles styled-fn)
+  (setf *styles* styles) ;; need when showing off from repl
   (let ((*styles* styles))
     (funcall styled-fn)))
 
@@ -111,6 +112,7 @@
   ;; until 2008-03-30 this next was only done for extruded case above
   (ix-string-width self (display-text$ self))) ;; ugh. make better. subclass must have display-text$
 
+(export! ix-string-width)
 
 (defun ix-string-width (self string)
   (c-assert (s-canvas) () "~a not contained by any canvas" self)
--- /project/cello/cvsroot/cello/ix-text.lisp	2008/04/11 09:22:48	1.12
+++ /project/cello/cvsroot/cello/ix-text.lisp	2008/06/16 12:39:21	1.13
@@ -138,6 +138,18 @@
 (defun find-menu (id)
   (fm-find-one *menus* id :must-find t :skip-tree nil :global-search nil :test #'cells::true-that))
 
+(defun make-string-tool-tip (self s)
+  (make-kid 'ix-text
+    :inset 3
+    :style-id :label
+    :pre-layer (with-layers
+                   +yellow+
+                 :fill
+                 (:frame-3d :edge-raised
+                   :thickness 2)
+                 +black+)
+    :text$ s))
+
 (defmd tool-tip (ix-stack)
   :visible (c? (^kids))
   :kids (c? (the-kids
@@ -145,16 +157,10 @@
                (when (tool-tip-show? v)
                  (typecase (tool-tip v)
                    (null)
-                   (string (make-kid 'ix-text
-                             :inset 3
-                             :style-id :label
-                             :pre-layer (with-layers +yellow+ :fill
-                                          (:frame-3d :edge-raised
-                                            :thickness 2)
-                                          +black+)
-                             :text$ (tool-tip v)))
+                   (string
+                    (make-string-tool-tip self (tool-tip v)))
                    (t (funcall (tool-tip v) self v)))))))
-                   
+  
   ;
   ; tedious geometry stuff to keep tool tip
   ; visible yet not eclipsed by mouse pointer
@@ -165,9 +171,10 @@
                ((^visible)
                 .retog.
                 (or fixed (setf fixed
-                            (if (> (+ 16 (v2-h mp) (l-width self)) (lr .og.))
-                                (px-maintain-pr (- (v2-h mp) 16))
-                              (+ 16 (v2-h mp))))))
+                            (let ((pref (+ 6 (v2-h mp))))
+                              (if (> (+ pref (l-width self)) (lr .og.)) ;; don't sail off to right of togl
+                                  (px-maintain-pr (lr .og.) #+hunh? (- (v2-h mp) 16))
+                                pref)))))
                (t (setf fixed nil))))))
   :py (let (fixed)
         (c? (bwhen (mp (mouse-pos .og.))
@@ -176,5 +183,5 @@
                 .retog.
                 (or fixed (setf fixed
                             (min (- (lt .og.)(l-height self))
-                              (py-maintain-pb (v2-v mp))))))
+                              (+ 6 (py-maintain-pb (v2-v mp)))))))
                (t (setf fixed nil)))))))
--- /project/cello/cvsroot/cello/ix-togl.lisp	2008/04/11 09:22:49	1.18
+++ /project/cello/cvsroot/cello/ix-togl.lisp	2008/06/16 12:39:21	1.19
@@ -35,7 +35,7 @@
                         (without-c-dependency
                             (find-ix-under self pos)))))))
   (:documentation "Mixin to have mouse view tracked in a subtree of the window, mostly so other GUI layout can depend on
-the sub-tree layout without creating a cyclic dependency, as would happen if the whole window were watched."))
+the sub-tree layout without creating a cyclic dependency, as would happen iof the whole window were watched."))
 
 (defmd ix-togl (mouse-view-tracker #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view)
   (redisplayp nil :cell nil)
@@ -57,7 +57,7 @@
   
   (mouse-up-evt (c-in nil) :cell :ephemeral)
   (mouse-down-evt (c-in nil) :cell :ephemeral)
-  ;; FNYI (double-click? (c-in nil))
+  (double-click-evt (c-in nil) :cell :ephemeral)
   
   (tick-count (c-in nil))
   (tick-fine (c-in nil))
@@ -75,7 +75,14 @@
   :cb-destroy (lambda (self)
                 ;(trc "IX-TOGL being destoyed!!!!!!!!!!" self)
                 (setf (togl-ptr self) nil) ;; new 2007-04-13 to avoid togl.c line 1039 crash closing window
-                (setf cells::*c-debug* t)))
+                ;; bad idea to do it this way, gotta get *istack* bound first: (setf cells::*c-debug* t)
+                ))
+
+(defmethod ctk::do-on-double-click-1 :before ((self ix-togl) &rest args)
+  (trc "IX-togl do-on-double-click-1 before" self (mouse-control self))
+  (bif (mi (mouse-control self))
+    (do-double-click mi )
+    (do-double-click self )))
 
 ;;;(defobserver mouse-pos ((self ix-togl))
 ;;;  #+nah (when new-value
@@ -125,26 +132,29 @@
     (:KeyPress          )
     (:KeyRelease        )
     (:ButtonPress
-     (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe)
-                              (- (ctk::xbe-y xe)))) ; trigger mouseview recalc
-     (setf (mouse-down-evt self) (eko (nil "mousedown!!!" (ctk::xbe button xe))
-                                   (make-os-event
-                                    :modifiers (keyboard-modifiers .tkw)
-                                    :where (mouse-pos self)
-                                    :realtime (now)
-                                    :c-event xe)))
-     (when (eql 3 (ctk::xbe button xe))
-       (when (^mouse-view)
-         (inspect (^mouse-view)))))
+     (case (xbe-button xe)
+       (1 (setf (mouse-pos self) (mkv2 (xbe-x xe)
+                                   (- (xbe-y xe)))) ; trigger mouseview recalc
+        (setf (mouse-down-evt self) (eko (nil "mousedown!!!" (ctk::xbe button xe))
+                                      (make-os-event
+                                       :modifiers (keyboard-modifiers .tkw)
+                                       :where (mouse-pos self)
+                                       :realtime (now)
+                                       :c-event xe))))
+        (3 (when (^mouse-view)
+             (inspect (^mouse-view))))))
+
     (:ButtonRelease
-     (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe)
-                              (- (ctk::xbe-y xe)))) ; trigger mouseview recalc
-     (setf (mouse-up-evt self) (eko (nil "mouse up!!!")
-                                   (make-os-event
-                                    :modifiers (keyboard-modifiers .tkw)
-                                    :where (mouse-pos self)
-                                    :realtime (now)
-                                    :c-event xe))))
+     (case (xbe-button xe)
+       (1 (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe)
+                                   (- (ctk::xbe-y xe)))) ; trigger mouseview recalc
+        (with-metrics (nil nil "mouse up evt")
+          (setf (mouse-up-evt self) (eko (nil "mouse up!!!")
+                                      (make-os-event
+                                       :modifiers (keyboard-modifiers .tkw)
+                                       :where (mouse-pos self)
+                                       :realtime (now)
+                                       :c-event xe)))))))
     
     (:MotionNotify
      (trc nil "setting mouse pos!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe)))
@@ -186,7 +196,6 @@
   (dolist (light new-value)
     (md-awaken light)))
 
-
 (defmethod ogl-node-window ((self ix-togl))
   self)
 
@@ -248,7 +257,7 @@
 (defobserver mouse-down-evt (self m-down)
   .retog.
   (when m-down
-    #+xxx (trcx mousedown self m-down (mouse-control self))
+    #+x (trcx mousedown self m-down (mouse-control self))
     (bwhen (clickee (mouse-control self))
       (trc nil "mousedown clickee, clickw" clickee self)
       (mk-part :click (mouse-click) ;; wow, a free-floating part
--- /project/cello/cvsroot/cello/lighting.lisp	2008/04/11 09:22:50	1.9
+++ /project/cello/cvsroot/cello/lighting.lisp	2008/06/16 12:39:21	1.10
@@ -92,7 +92,7 @@
                           (ix-render-light self))))
     (loop for light in (fixed-lighting self)
           do (ix-render-light light))
-    (when (and (not lights) (emergency-lighting self))
+    (when (not lights)
       (dolist (e-light (emergency-lighting self))
         (ix-render-light e-light)))))
 
--- /project/cello/cvsroot/cello/mouse-click.lisp	2008/04/11 09:22:50	1.9
+++ /project/cello/cvsroot/cello/mouse-click.lisp	2008/06/16 12:39:24	1.10
@@ -48,7 +48,7 @@
                          (mouse-pos (click-window self)))))))
    
    (clicked :reader clicked
-     :initform (c? (trc nil "clicked?> typeof clickw" (click-window self) (type-of (click-window self)))
+     :initform (c? ;(trc "clicked?> typeof clickw" (click-window self) (type-of (click-window self)))
                  (when (typep (click-window self) 'model)
                    (trc nil "clicked?> asking clickcompleted")
                    (bwhen (up (^click-completed))
--- /project/cello/cvsroot/cello/window-utilities.lisp	2008/04/11 09:22:50	1.10
+++ /project/cello/cvsroot/cello/window-utilities.lisp	2008/06/16 12:39:24	1.11
@@ -18,12 +18,12 @@
 
 ;-------------------- double click -----------------------------------
 
-(defmethod do-double-click :around (self os-event &rest iargs &key  &allow-other-keys)
+(defmethod do-double-click :around (self)
   (when self
     (or (call-next-method)
-        (apply #'do-double-click (fm-parent self) os-event iargs))))
+        (do-double-click (fm-parent self)))))
 
-(defmethod do-double-click (self os-event &key)
+(defmethod do-double-click (self)
   (declare (ignorable self os-event))  
   ;;(trc "*** No special do-double-click for ix-view, event:" self osEvent)
   nil)
--- /project/cello/cvsroot/cello/wm-mouse.lisp	2006/11/04 20:56:30	1.6
+++ /project/cello/cvsroot/cello/wm-mouse.lisp	2008/06/16 12:39:24	1.7
@@ -16,21 +16,6 @@
 
 (in-package :cello)
 
-(defmethod do-click :around (self os-event)
-  (declare (ignorable os-event))
-  (when self
-    (or (call-next-method)
-        (do-click (fm-parent self) os-event))))
-
-(defmethod do-click (self os-event)
-  (declare (ignorable self os-event))
-  nil)
-
-;
-; ------------ double click ---------------------------------------
-;
-
-
 (defstruct (os-event 
            (:conc-name nil))
   modifiers



From ktilton at common-lisp.net  Mon Jun 16 12:39:26 2008
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 16 Jun 2008 08:39:26 -0400 (EDT)
Subject: [cello-cvs] CVS cello/cl-ftgl
Message-ID: <20080616123926.8125150AC@common-lisp.net>

Update of /project/cello/cvsroot/cello/cl-ftgl
In directory clnet:/tmp/cvs-serv9119/cl-ftgl

Modified Files:
	cl-ftgl.lisp 
Log Message:
nothing special

--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp	2008/04/11 09:22:58	1.18
+++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp	2008/06/16 12:39:26	1.19
@@ -20,7 +20,7 @@
 ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 
 ;;; IN THE SOFTWARE.
 
-;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.18 2008/04/11 09:22:58 ktilton Exp $
+;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.19 2008/06/16 12:39:26 ktilton Exp $
 
 (eval-when (:compile-toplevel :load-toplevel)
   (pushnew :cl-ftgl *features*))
@@ -83,32 +83,47 @@
 (defparameter *ftgl-ogl* nil)
 
 (defparameter *ftgl-font-dirs* nil)
+(defparameter *ftgl-application-font-paths* nil)
+
+(export! ftgl-application-font-paths)
+
+(defun ftgl-application-font-paths ()
+  (assert (loop for p in *ftgl-application-font-paths*
+                always (probe-file p)))
+  *ftgl-application-font-paths*)
+
+(defun (setf ftgl-application-font-paths) (paths)
+  (setf *ftgl-application-font-paths* paths))
 
 (defun ftgl-font-directories ()
   (or *ftgl-font-dirs*
     (setf *ftgl-font-dirs*
       #+cffi-features:windows
-      (list (font-path)
+      (append (ftgl-application-font-paths)
+        (list (make-pathname
+               :directory
+               '(:absolute "Windows" "fonts"))))
+      #+cffi-features:darwin
+      (append 
+       (ftgl-application-font-paths)
+       (list
         (make-pathname
          :directory
-         '(:absolute "Windows" "fonts")))
-      #+cffi-features:darwin
-      (list
-       (make-pathname
-        :directory
-        '(:absolute "System" "Library" "Fonts"))
-       (make-pathname
-        :directory
-        '(:absolute "Library" "Fonts"))
-       (make-pathname
-        :directory
-        '(:relative "~" "Library" "Fonts")))
+         '(:absolute "System" "Library" "Fonts"))
+        (make-pathname
+         :directory
+         '(:absolute "Library" "Fonts"))
+        (make-pathname
+         :directory
+         '(:relative "~" "Library" "Fonts"))))
             
       #+(and cffi-features:unix (not cffi-features:darwin))
-      (list
-       (make-pathname
-        :directory
-        '(:absolute "usr" "share" "truetype"))))))
+      (append 
+       (ftgl-application-font-paths)
+       (list
+        (make-pathname
+         :directory
+         '(:absolute "usr" "share" "truetype")))))))
 
 (defparameter *ftgl-font-types-list* ;; list of font types
   ;; (font filename endings)
@@ -213,14 +228,14 @@
 (defmacro dbgftgl (tag &body body)
   (declare (ignorable tag))
   `(progn
-     #+nahhh (unless (boundp '*gl-begun*)
+     #+nahhh (unless (boundp 'ogl::*gl-begun*)
        (assert (zerop (glgeterror))))
      (progn ;; cells:wtrc (0 100 "dbgftgl" ,tag)
        (ftgl-assert-opengl-context)
-       (unless (boundp '*gl-begun*) (glec :dbgftgl-entry))
+       (unless (boundp 'ogl::*gl-begun*) (glec :dbgftgl-entry))
        (prog1
            (progn , at body)
-         (unless (boundp '*gl-begun*)
+         (unless (boundp 'ogl::*gl-begun*)
            (progn
              (glec :dbgftgl-post-body)))))))
 
@@ -447,6 +462,10 @@
   (declare (ignorable s))
   (dbgfont font :ftgl-render-before)
   
+     (if (boundp 'ogl::*gl-begun*)
+       (break "gl begun OK?" font)
+       (trc nil "cool" s))
+
   (dbgftgl :ftgl-render
     (gl-enable gl_texture_2d)
     (gl-enable gl_blend)



From ktilton at common-lisp.net  Mon Jun 16 12:39:26 2008
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 16 Jun 2008 08:39:26 -0400 (EDT)
Subject: [cello-cvs] CVS cello/cl-magick
Message-ID: <20080616123926.E84937A014@common-lisp.net>

Update of /project/cello/cvsroot/cello/cl-magick
In directory clnet:/tmp/cvs-serv9119/cl-magick

Modified Files:
	wand-image.lisp 
Log Message:
nothing special

--- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp	2008/04/11 09:23:02	1.11
+++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp	2008/06/16 12:39:26	1.12
@@ -112,7 +112,7 @@
                       for pixel-offset fixnum = (the fixnum (+ 3 (*  pixel-col bytes-per-pixel)))
                       when (> 96 ;; rough guess at how to detect: can't always get perfect alpha w eraser: /= 255
                              (eltuc pixels (the fixnum pixel-offset)))
-                      do (cells:trc "image alpha already converted. I see non-255"
+                      do #+shhh (cells:trc "image alpha already converted. I see non-255"
                            (image-path self)
                            (eltuc pixels (the fixnum pixel-offset)) :at-col pixel-col)
                         (return-from detect-converted t)))



From ktilton at common-lisp.net  Mon Jun 16 12:39:27 2008
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 16 Jun 2008 08:39:27 -0400 (EDT)
Subject: [cello-cvs] CVS cello/kt-opengl
Message-ID: <20080616123927.43BB27A014@common-lisp.net>

Update of /project/cello/cvsroot/cello/kt-opengl
In directory clnet:/tmp/cvs-serv9119/kt-opengl

Modified Files:
	ogl-macros.lisp 
Log Message:
nothing special

--- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp	2008/04/11 09:23:07	1.12
+++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp	2008/06/16 12:39:26	1.13
@@ -115,13 +115,8 @@
       (gl-end))
     (glec :with-gl-begun-exit)))
 
-(defmacro with-gensyms ((&rest syms) &body body)
-  `(let ,(loop for sym in syms
-                       collecting `(,sym (gensym)))
-     , at body))
-
 (defmacro with-gl-translation ((dxf dyf &optional (dzf 0)) &body body)
-  (with-gensyms (dx dy dz)
+  (let ((dx (gensym))(dy (gensym))(dz (gensym)))
     `(let ((,dx ,dxf)(,dy ,dyf)(,dz ,dzf))
        (gl-translatef ,dx ,dy ,dz)
        (prog1