May 2005 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp
by drose＠common-lisp.net 29 May '05

29 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv303/beagle/input Modified Files: events.lisp Log Message: Nasty hacks to add support for backspace + delete keys. Date: Sun May 29 11:55:39 2005 Author: drose Index: mcclim/Backends/beagle/input/events.lisp diff -u mcclim/Backends/beagle/input/events.lisp:1.5 mcclim/Backends/beagle/input/events.lisp:1.6 --- mcclim/Backends/beagle/input/events.lisp:1.5 Sat May 28 21:56:05 2005 +++ mcclim/Backends/beagle/input/events.lisp Sun May 29 11:55:39 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.5 2005/05/28 19:56:05 drose Exp $ +$Id: events.lisp,v 1.6 2005/05/29 09:55:39 drose Exp $ Events in Cocoa --------------- @@ -201,7 +201,8 @@ ;; This falls over when the function keys, the arrow keys, the num-lock key (and others) ;; are pressed; I guess we don't want to be doing this! ;;; (key-name (ccl::lisp-string-from-nsstring (send event 'characters-ignoring-modifiers)))) - (let ((key-name (characters-to-key-name (send event 'characters-ignoring-modifiers)))) + (let* ((characters (send event 'characters-ignoring-modifiers)) + (key-name (characters-to-key-name characters))) key-name)) @@ -474,9 +475,13 @@ (make-instance (if (eq :key-down event-type) 'key-press-event 'key-release-event) + ;; McCLIM seems not to understand these, whatever we pass :-( :key-name keyname - ;; not needed by spec - should change implementation? - :key-character (and (characterp keyname) keyname) + ;; not needed by spec - should change implementation? And this is a + ;; REALLY bad place to deal with DELETE-CHAR -> #\Del. ::FIXME:: + :key-character (if (eq keyname :DELETE-CHAR) + #\Del + (and (characterp keyname) keyname)) :x 0 ; Not needed for key events? :y 0 ; Not needed for key events? :graft-x 0 ; Not needed for key events? @@ -818,7 +823,8 @@ (defun characters-to-key-name (ns-string-characters-in) ;;; (format *terminal-io* "Processing ~S~%" ns-string-characters-in) ;;; (format *terminal-io* "Got string with length ~A~%" (send ns-string-characters-in 'length)) -;;; (format *terminal-io* "character(0) = ~A~%" (send ns-string-characters-in :character-at-index 0)) +;;; (format *terminal-io* "character(0) = ~A~%" +;;; (char-code (send ns-string-characters-in :character-at-index 0))) (if (<= (send ns-string-characters-in :character-at-index 0) 255) (numeric-keysym-to-character (send ns-string-characters-in :character-at-index 0)) (progn @@ -838,6 +844,12 @@ (cond ((= #x1b keysym) (get-key-name-from-cocoa-constants keysym)) + ;; Manually massage this... messy. OS X generates 127 for |<-| key, + ;; map it onto #\Backspace (by default in OpenMCL it maps onto + ;; #\Del (delete forward)). OpenMCL treats #\Backspace and + ;; #\Delete as synonyms. + ((= #x7f keysym) + #\Backspace) ((and (<= 0 keysym 255)) (code-char keysym)) (t nil))) @@ -888,6 +900,8 @@ #$NSF34FunctionKey :F34 #$NSF35FunctionKey :F35 #$NSInsertFunctionKey :INSERT + ;; Neither of these appear to have the desired result. +;;; #$NSDeleteFunctionKey #\Del ; :DELETE-CHAR #$NSDeleteFunctionKey :DELETE-CHAR #$NSHomeFunctionKey :HOME #$NSBeginFunctionKey :BEGIN @@ -920,6 +934,9 @@ #$NSFindFunctionKey :FIND #$NSHelpFunctionKey :HELP #$NSModeSwitchFunctionKey :MODE-SWITCH + ;; #x7f = DEL in ASCII +;;; #x7f :BACKSPACE + ;; #x1b = ESC in ASCII #x1b :ESCAPE)) ;;;(defun get-key-name-from-cocoa-constants (ns-in)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/mirror.lisp
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv15409/mcclim/Backends/beagle/windowing Modified Files: mirror.lisp Log Message: Some tidying up of code. Rearranged EVENTS.LISP somewhat in preparation of better key event handling. Minor changes to rounding and coercing of coordinates in Beagle. Date: Sat May 28 21:56:09 2005 Author: drose Index: mcclim/Backends/beagle/windowing/mirror.lisp diff -u mcclim/Backends/beagle/windowing/mirror.lisp:1.3 mcclim/Backends/beagle/windowing/mirror.lisp:1.4 --- mcclim/Backends/beagle/windowing/mirror.lisp:1.3 Fri May 20 00:25:36 2005 +++ mcclim/Backends/beagle/windowing/mirror.lisp Sat May 28 21:56:09 2005 @@ -59,23 +59,22 @@ ;; coords outside the mirror's physical screen size to be used). ;; x,y = 0,0 unless there's a mirror-transformation in play (x (if (%sheet-mirror-transformation sheet) - (round-coordinate (nth-value 0 (transform-position - (%sheet-mirror-transformation sheet) 0 0))) + (nth-value 0 (transform-position (%sheet-mirror-transformation sheet) 0 0)) 0)) (y (if (%sheet-mirror-transformation sheet) - (round-coordinate (nth-value 1 (transform-position - (%sheet-mirror-transformation sheet) 0 0))) + (nth-value 1 (transform-position (%sheet-mirror-transformation sheet) 0 0)) 0)) (q (compose-space sheet)) ;; Take the width / height from the mirror-region if there's one set, otherwise from the ;; space requirement. (width (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet))) - (round-coordinate (space-requirement-width q)))) + (bounding-rectangle-width (%sheet-mirror-region sheet)) + (space-requirement-width q))) (height (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet))) - (round-coordinate (space-requirement-height q)))) - (rect (ccl::make-ns-rect x y width height)) + (bounding-rectangle-height (%sheet-mirror-region sheet)) + (space-requirement-height q))) + (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (mirror (make-instance view :with-frame rect))) (#_free rect) (send mirror 'retain) @@ -177,20 +176,19 @@ (frame (pane-frame sheet)) (q (compose-space sheet)) (x (if (%sheet-mirror-transformation sheet) - (round-coordinate (nth-value 0 (transform-position - (%sheet-mirror-transformation sheet) 0 0))) + (nth-value 0 (transform-position (%sheet-mirror-transformation sheet) 0 0)) 0)) (y (if (%sheet-mirror-transformation sheet) - (round-coordinate (nth-value 1 (transform-position - (%sheet-mirror-transformation sheet) 0 0))) + (nth-value 1 (transform-position (%sheet-mirror-transformation sheet) 0 0)) 0)) (width (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet))) - (round-coordinate (space-requirement-width q)))) + (bounding-rectangle-width (%sheet-mirror-region sheet)) + (space-requirement-width q))) (height (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet))) - (round-coordinate (space-requirement-height q)))) - (rect (ccl::make-ns-rect x y width height)) + (bounding-rectangle-height (%sheet-mirror-region sheet)) + (space-requirement-height q))) + (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (style-mask (logior #$NSTitledWindowMask #$NSClosableWindowMask #$NSMiniaturizableWindowMask @@ -245,20 +243,19 @@ ;;; (frame (pane-frame sheet)) (q (compose-space sheet)) (x (if (%sheet-mirror-transformation sheet) - (round-coordinate (nth-value 0 (transform-position - (%sheet-mirror-transformation sheet) 0 0))) + (nth-value 0 (transform-position (%sheet-mirror-transformation sheet) 0 0)) 0)) (y (if (%sheet-mirror-transformation sheet) - (round-coordinate (nth-value 1 (transform-position - (%sheet-mirror-transformation sheet) 0 0))) + (nth-value 1 (transform-position (%sheet-mirror-transformation sheet) 0 0)) 0)) (width (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet))) - (round-coordinate (space-requirement-width q)))) + (bounding-rectangle-width (%sheet-mirror-region sheet)) + (space-requirement-width q))) (height (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet))) - (round-coordinate (space-requirement-height q)))) - (rect (ccl::make-ns-rect x y width height)) + (bounding-rectangle-height (%sheet-mirror-region sheet)) + (space-requirement-height q))) + (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) ;;; For a "popup" menu, we get rid of all decoration - allow the windowing system ;;; (McCLIM) get rid of the menu when it's no longer needed. (style-mask #$NSBorderlessWindowMask))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/output/medium.lisp
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv15409/mcclim/Backends/beagle/output Modified Files: medium.lisp Log Message: Some tidying up of code. Rearranged EVENTS.LISP somewhat in preparation of better key event handling. Minor changes to rounding and coercing of coordinates in Beagle. Date: Sat May 28 21:56:08 2005 Author: drose Index: mcclim/Backends/beagle/output/medium.lisp diff -u mcclim/Backends/beagle/output/medium.lisp:1.3 mcclim/Backends/beagle/output/medium.lisp:1.4 --- mcclim/Backends/beagle/output/medium.lisp:1.3 Fri May 20 00:25:35 2005 +++ mcclim/Backends/beagle/output/medium.lisp Sat May 28 21:56:07 2005 @@ -477,10 +477,12 @@ (defun medium-copy-area-aux (from from-x from-y width height to to-x to-y) "Helper method for copying areas. 'from' and 'to' must both be 'mirror' objects. From and To coordinates must already be transformed as appropriate." - (let* ((source-region (ccl::make-ns-rect (+ from-x 0.5) (+ from-y 0.5) - width height)) - (target-point (ccl::make-ns-point (+ to-x 0.5) - (+ to-y 0.5))) + (let* ((source-region (ccl::make-ns-rect (coerce from-x 'short-float) + (coerce from-y 'short-float) + (coerce width 'short-float) + (coerce height 'short-float))) + (target-point (ccl::make-ns-point (coerce to-x 'short-float) + (coerce to-y 'short-float))) (bitmap-image (send from :copy-bitmap-from-region source-region))) (when (eql bitmap-image (%null-ptr)) (warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%") @@ -489,7 +491,7 @@ (#_free source-region) (#_free target-point) (send bitmap-image 'release))) - + (defmethod medium-copy-area ((from-drawable beagle-medium) from-x from-y width height (to-drawable beagle-medium) to-x to-y) @@ -595,16 +597,15 @@ prevents Cocoa from 'antialiasing' lines, making them thicker and a shade of grey. Ensures the return value is a short-float, as required by the Cocoa methods." -;; Interesting... I thought 'center of pixel' was 0.5, 1.5, ... n.5 -;; but this works much better with 0.0, 1.0, 2.0... -;; (coerce (+ (round-coordinate pt) 0.5) 'short-float)) - (coerce (round-coordinate pt) 'short-float)) + (coerce (+ (round-coordinate pt) 0.5) 'short-float)) + (defun pixel-count (sz) "Ensures any value provided is rounded to the nearest unit, and returned as a short-float as required by the Cocoa methods." (coerce (round-coordinate sz) 'short-float)) + ;;; Nabbed from CLX backend medium.lisp (declaim (inline round-coordinate)) (defun round-coordinate (x) @@ -618,6 +619,7 @@ Using CL:ROUND gives \"random\" results. Using \"mercantile rounding\" gives consistent results." (floor (+ x .5))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/cocoa-util.lisp
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv15409/mcclim/Backends/beagle Modified Files: cocoa-util.lisp Log Message: Some tidying up of code. Rearranged EVENTS.LISP somewhat in preparation of better key event handling. Minor changes to rounding and coercing of coordinates in Beagle. Date: Sat May 28 21:56:05 2005 Author: drose Index: mcclim/Backends/beagle/cocoa-util.lisp diff -u mcclim/Backends/beagle/cocoa-util.lisp:1.2 mcclim/Backends/beagle/cocoa-util.lisp:1.3 --- mcclim/Backends/beagle/cocoa-util.lisp:1.2 Tue Jul 13 19:37:56 2004 +++ mcclim/Backends/beagle/cocoa-util.lisp Sat May 28 21:56:04 2005 @@ -23,57 +23,24 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;(in-package :clim-cocoa) - (in-package :ccl) -;(require "OBJC-SUPPORT") - -;; Should be using "with-autorelease-pool" somewhere... but for now, take it out because -;; something isn't working... - -;; Make an NSColor object that is the desired colour provided as a parameter, and with -;; the opacity provided in the key argument (defaults to 1.0 (opaque)). -;;;(defun make-ns-color (desired-color &key (alpha 1.0)) -;;; (cl-user::debug-log 1 "cocoa-util.lisp: -> MAKE-NS-COLOR() - TYPE-OF (desired-color): ~A~%" -;;; (type-of desired-color)) -;;; (cl-user::debug-log 1 "cocoa-util: Entered MAKE-NS-COLOR, desired colour = ~S~%" desired-color) -;;; (multiple-value-bind (r g b) -;;; (clim:color-rgb desired-color) -;;; (send (@class ns-color) :color-with-calibrated-red r -;;; :green g -;;; :blue b -;;; :alpha alpha))) - - -;; Given a CLIM event-mask, generate a Cocoa event-mask -;;;(defun clim-event-mask->cocoa-event-mask (event-mask) -;;; (cl-user::debug-log 1 "cocoa-util: Entered CLIM-EVENT-MASK->COCOA-EVENT-MASK (stubbed)~%") -;;; event-mask) - -;; Tell an NSWindow what events to respond to -;;;(defun set-ns-window-event-mask (window event-mask) -;;; (cl-user::debug-log 1 "cocoa-util: Entered SET-NS-WINDOW-EVENT-MASK~%") -;;; (send window :next-event-matching-mask event-mask)) ;; Make an NSRect structure with the origin at (x, y) and with the width and height ;; specified. (defun make-ns-rect (x y width height) - (make-record :<NSR>ect :origin.x (+ (coerce x 'short-float) 0.5) - :origin.y (+ (coerce y 'short-float) 0.5) - :size.width (coerce width 'short-float) - :size.height (coerce height 'short-float))) + "Make a Cocoa NSRect structure with the origin at (x, y) and with the +width and height specified. The memory for any structure created with +this method must be released by the user (using (#_free))." + (make-record :<NSR>ect :origin.x x + :origin.y y + :size.width width + :size.height height)) (defun make-ns-point (x y) - (make-record :<NSP>oint :x (+ (coerce x 'short-float) 0.5) - :y (+ (coerce y 'short-float) 0.5))) - -;; Get the *NSApp* reference -;;;(defun get-ns-app () -;;; *NSApp*) - -;; Send the NSWindow provided a setFrame: message -;;;(defun window-set-frame (window rect &key (display t)) -;;; (send window :set-frame rect :display display)) + "Make a Cocoa NSPoint structure populated with x and y provided. +The memory for any structure created with this method must be released +by the user (using (#_free))." + (make-record :<NSP>oint :x x :y y)) ;; Stolen from Bosco "main.lisp" (defun description (c)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv23015/windowing Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:33 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/tests/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/tests In directory common-lisp.net:/tmp/cvs-serv23015/tests Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:32 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/profile/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/profile In directory common-lisp.net:/tmp/cvs-serv23015/profile Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:31 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/output/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv23015/output Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:29 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/glimpse/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/glimpse In directory common-lisp.net:/tmp/cvs-serv23015/glimpse Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:27 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/native/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory common-lisp.net:/tmp/cvs-serv23015/native Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:28 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/.cvsignore
by drose＠common-lisp.net 28 May '05

28 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv23015/input Added Files: .cvsignore Log Message: Add .cvsignore entries to quiet group cvs commands Date: Sat May 28 14:58:28 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by ahefner＠common-lisp.net 23 May '05

23 May '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10672 Modified Files: gadgets.lisp Log Message: Added rpgoldman's docstring for box-adjuster gadget. Date: Mon May 23 14:43:34 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.89 mcclim/gadgets.lisp:1.90 --- mcclim/gadgets.lisp:1.89 Sun Apr 17 19:30:26 2005 +++ mcclim/gadgets.lisp Mon May 23 14:43:34 2005 @@ -2815,7 +2815,14 @@ (left-peer) (right-sr) (right-peer)) - (:default-initargs :background *3d-inner-color*)) + (:default-initargs :background *3d-inner-color*) + (:documentation "The box-adjuster-gadget allows users to resize the panes +in a layout by dragging the boundary between the panes. To use it, insert +it in a layout between two panes that are to be resizeable. E.g.: + (vertically () + top-pane + (make-pane 'clim-extensions:box-adjuster-gadget) + bottom-pane)")) (defmethod compose-space ((gadget clim-extensions:box-adjuster-gadget) &key width height)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/frame-manager.lisp mcclim/Backends/beagle/windowing/mirror.lisp
by drose＠common-lisp.net 19 May '05

19 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv24047/beagle/windowing Modified Files: frame-manager.lisp mirror.lisp Log Message: Some refactoring of events.lisp; made an effort to trawl for memory allocations and ensure they're freed appropriately. Estimate this to be around 70-80% done. Seems to give performance and stability benefits. Date: Fri May 20 00:25:37 2005 Author: drose Index: mcclim/Backends/beagle/windowing/frame-manager.lisp diff -u mcclim/Backends/beagle/windowing/frame-manager.lisp:1.1 mcclim/Backends/beagle/windowing/frame-manager.lisp:1.2 --- mcclim/Backends/beagle/windowing/frame-manager.lisp:1.1 Tue May 17 00:13:21 2005 +++ mcclim/Backends/beagle/windowing/frame-manager.lisp Fri May 20 00:25:36 2005 @@ -140,8 +140,9 @@ (multiple-value-bind (w h x y) (climi::frame-geometry* frame) (declare (ignore w h)) (when (and x y) - (send (send mirror 'window) :set-frame-top-left-point - (ccl::make-ns-point (coerce x 'short-float) (coerce y 'short-float))))) + (let ((point (ccl::make-ns-point (coerce x 'short-float) (coerce y 'short-float)))) + (send (send mirror 'window) :set-frame-top-left-point point) + (#_free point)))) (when (sheet-enabled-p sheet) (send (send mirror 'window) :make-key-and-order-front nil))))) @@ -161,9 +162,9 @@ (multiple-value-bind (w h x y) (climi::frame-geometry* frame) (declare (ignore w h)) (when (and x y) + (let ((point (ccl::make-ns-point (coerce x 'short-float) (coerce y 'short-float)))) ;; (format *debug-io* "Setting frame top left point to (~a, ~a)~%" x y) - (send (send mirror 'window) :set-frame-top-left-point - (ccl::make-ns-point (coerce x 'short-float) (coerce y 'short-float))))) + (send (send mirror 'window) :set-frame-top-left-point point)))) (when (sheet-enabled-p sheet) (send (send mirror 'window) :make-key-and-order-front nil))))) Index: mcclim/Backends/beagle/windowing/mirror.lisp diff -u mcclim/Backends/beagle/windowing/mirror.lisp:1.2 mcclim/Backends/beagle/windowing/mirror.lisp:1.3 --- mcclim/Backends/beagle/windowing/mirror.lisp:1.2 Wed May 18 22:21:58 2005 +++ mcclim/Backends/beagle/windowing/mirror.lisp Fri May 20 00:25:36 2005 @@ -77,6 +77,7 @@ (round-coordinate (space-requirement-height q)))) (rect (ccl::make-ns-rect x y width height)) (mirror (make-instance view :with-frame rect))) + (#_free rect) (send mirror 'retain) (send mirror 'establish-tracking-rect) (setf (view-background-colour mirror) (%beagle-pixel port desired-color)) @@ -217,7 +218,8 @@ (let ((vtable (slot-value port 'view-table))) (setf (gethash clim-mirror vtable) sheet)) ;; Things don't work if we don't do this... hopefully it will help. Maybe it won't. - (send top-level-frame :make-key-and-order-front nil))))) + (send top-level-frame :make-key-and-order-front nil) + (#_free rect))))) ;;; The parent of this sheet is the NSScreen... how'd that happen? Very strange. Well, that ;;; means we can't add this sheet to its parent; so what's this sheet used for, and how @@ -288,6 +290,7 @@ (let ((vtable (slot-value port 'view-table))) (setf (gethash clim-mirror vtable) sheet)) ;;; (send menu-frame :set-level (ccl::%get-ptr (ccl::foreign-symbol-address "_NSPopUpMenuWindowLevel"))) + (#_free rect) ;; Things don't work if we don't do this... hopefully it will help. Maybe it won't. (send menu-frame :make-key-and-order-front nil)))))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/output/medium.lisp
by drose＠common-lisp.net 19 May '05

19 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv24047/beagle/output Modified Files: medium.lisp Log Message: Some refactoring of events.lisp; made an effort to trawl for memory allocations and ensure they're freed appropriately. Estimate this to be around 70-80% done. Seems to give performance and stability benefits. Date: Fri May 20 00:25:35 2005 Author: drose Index: mcclim/Backends/beagle/output/medium.lisp diff -u mcclim/Backends/beagle/output/medium.lisp:1.2 mcclim/Backends/beagle/output/medium.lisp:1.3 --- mcclim/Backends/beagle/output/medium.lisp:1.2 Wed May 18 22:21:57 2005 +++ mcclim/Backends/beagle/output/medium.lisp Fri May 20 00:25:35 2005 @@ -486,6 +486,8 @@ (warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%") (return-from medium-copy-area-aux nil)) (send to :paste-bitmap bitmap-image :to-point target-point) + (#_free source-region) + (#_free target-point) (send bitmap-image 'release))) @@ -581,7 +583,8 @@ (pixel-center bottom) (pixel-count (- right left)) (pixel-count (- top bottom))))) - (send path :append-bezier-path-with-rect rect))) + (send path :append-bezier-path-with-rect rect) + (#_free rect))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) @@ -651,11 +654,13 @@ (origin-x (- center-x radius-dx)) (origin-y (- center-y radius-dy)) (width (* 2 radius-dx)) - (height (* 2 radius-dy))) - (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect (pixel-center origin-x) - (pixel-center origin-y) - (pixel-count width) - (pixel-count height))) + (height (* 2 radius-dy)) + (rect (ccl::make-ns-rect (pixel-center origin-x) + (pixel-center origin-y) + (pixel-count width) + (pixel-count height)))) + (send path :append-bezier-path-with-oval-in-rect rect) + (#_free rect) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) @@ -768,13 +773,15 @@ (send mirror :draw-image colour :at-point (ns-make-point (pixel-center left) (pixel-center top))) (return-from medium-draw-rectangle* (values))) - (send path :append-bezier-path-with-rect (ccl::make-ns-rect (pixel-center left) - (pixel-center bottom) - (pixel-count (- right left)) - (pixel-count (- top bottom)))) - (if filled - (send mirror :fill-path path :in-colour colour) - (send mirror :stroke-path path :in-colour colour))))))) + (let ((rect (ccl::make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) + (send path :append-bezier-path-with-rect rect) + (#_free rect) + (if filled + (send mirror :fill-path path :in-colour colour) + (send mirror :stroke-path path :in-colour colour)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp
by drose＠common-lisp.net 19 May '05

19 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv24047/beagle/input Modified Files: events.lisp Log Message: Some refactoring of events.lisp; made an effort to trawl for memory allocations and ensure they're freed appropriately. Estimate this to be around 70-80% done. Seems to give performance and stability benefits. Date: Fri May 20 00:25:34 2005 Author: drose Index: mcclim/Backends/beagle/input/events.lisp diff -u mcclim/Backends/beagle/input/events.lisp:1.3 mcclim/Backends/beagle/input/events.lisp:1.4 --- mcclim/Backends/beagle/input/events.lisp:1.3 Tue May 17 22:12:37 2005 +++ mcclim/Backends/beagle/input/events.lisp Fri May 20 00:25:34 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.3 2005/05/17 20:12:37 drose Exp $ +$Id: events.lisp,v 1.4 2005/05/19 22:25:34 drose Exp $ All these are copied pretty much from CLX/port.lisp @@ -56,19 +56,19 @@ ;;; The following parameters are *all* added for 'synthesize-pointer-motion-event' only. (defparameter *-current-event-modifier-state-* 0 - "Contains the most recent modifier state for any ``real'' event. Reset whenever any + "Contains the most recent modifier state for any 'real' event. Reset whenever any event (but not notification) is handled.") (defparameter *-current-pointer-button-state-* 0 - "Contains the most recent pointer button state for any ``real'' event. Reset whenever + "Contains the most recent pointer button state for any 'real' event. Reset whenever any pointer or button-press event is handled.") (defparameter *-current-pointer-graft-xy-* nil "Contains the (Cocoa) NSPoint foreign object (structure) representing the position of -the mouse pointer in screen coordinates. Reset whenever a ``real'' pointer event +the mouse pointer in screen coordinates. Reset whenever a 'real' pointer event (mouse-move, mouse-drag, enter / exit or button press / release) is handled.") (defparameter *-current-pointer-view-xy-* nil "Contains the (Cocoa) NSPoint foreign object (structure) representing the position of the mouse pointer in the coordinate system of the NSView it is currently over. Reset -whenever a ``real'' pointer event (mouse-move, mouse-drag, enter / exit or button +whenever a 'real' pointer event (mouse-move, mouse-drag, enter / exit or button press / release) is handled.") (defvar *keysym-hash-table* @@ -104,17 +104,6 @@ ;;; in cocoa (grab events and window hints), hopefully that won't matter to ;;; us (apart from the menus use grabbing I think) -;;; All these parameters must be what CLX provides for the :handler argument -;;; to the xlib:process-event method. - -;;; We don't actually need all this gubbins for Cocoa events. We just need a -;;; method to convert from a Cocoa event to a CLIM event. As specified, this -;;; would be quite a good fit. Unfortunately, McCLIM seems to have a whole -;;; bunch of non-standard slots in the event objects (root-x, root-y etc.) -;;; and the override-redirect-p, send-event-p, hint-p stuff in this method. - -;;; So we actually want to do this slightly differently. - ;; From CLX/port.lisp ;; NOTE: Although it might be tempting to compress (consolidate) @@ -136,31 +125,6 @@ ;; ;;--GB -;; XXX :button code -> :button (decode-x-button-code code) -;; (declare (ignorable event-slots)) -;; (declare (special *cocoa-port*)) -;; (let ((sheet (and window -;; (port-lookup-sheet port window)))) -;; (when sheet -;; (:enter-notify -;; (make-instance 'pointer-enter-event -;; :pointer 0 -;; :button code :x x :y y -;; :graft-x root-x -;; :graft-y root-y -;; :sheet sheet -;; :modifier-state (cocoa-event-state-modifiers *cocoa-port* state) -;; :timestamp time)) -;; (:leave-notify -;; (make-instance 'pointer-exit-event ; No grab events in cocoa - may cause problems? -;; :pointer 0 -;; :button code -;; :x x :y y -;; :graft-x root-x -;; :graft-y root-y -;; :sheet sheet -;; :modifier-state (cocoa-event-state-modifiers *cocoa-port* state) -;; :timestamp time)) (defparameter *mcclim-event-queue* nil) @@ -176,7 +140,8 @@ (setf *mcclim-event-queue* (nconc *mcclim-event-queue* (list clim-event))) (ccl:signal-semaphore (beagle-port-event-semaphore *beagle-port*))))) -(defmethod add-notification-to-queue (window notification &optional origin-x origin-y width height) +(defmethod add-notification-to-queue (window notification + &optional origin-x origin-y width height) "Adds an event to the dynamically scoped *mcclim-event-queue* queue, after conversion from a Cocoa notification MACPTR to a CLIM event. This method signals the port event semaphore when a notification is added to the queue." @@ -224,14 +189,16 @@ ;; Can we make use of the other modifier states set by cocoa? Some of ;; them might be useful... -;;; Every key on the keyboard has a physical "key-code". a and A share the same key code, since the -;;; same key is pressed (0 in this case). We can't make use of the key-code with any confidence since -;;; they're at a very low-level. We have to use the 'characters method (or 'characters-ignoring-modifiers) -;;; to pull the actual keys out of the event. Then we need to map these to McCLIM key names. *sigh* - -;;; We could use 'characters if we were going through the full Cocoa key-handling path; and we might -;;; be able to make use of this anyway, but for now just use 'characters-ignoring-modifiers and compare -;;; what we get with those values known from Cocoa for function keys etc. +;;; Every key on the keyboard has a physical "key-code". a and A share the same key +;;; code, since the same key is pressed (0 in this case). We can't make use of the +;;; key-code with any confidence since they're at a very low-level. We have to use +;;; the 'characters method (or 'characters-ignoring-modifiers) to pull the actual +;;; keys out of the event. Then we need to map these to McCLIM key names. *sigh* + +;;; We could use 'characters if we were going through the full Cocoa key-handling +;;; path; and we might be able to make use of this anyway, but for now just use +;;; 'characters-ignoring-modifiers and compare what we get with those values known +;;; from Cocoa for function keys etc. (defun beagle-key-event-to-key-name (event) ;; This falls over when the function keys, the arrow keys, the num-lock key (and others) ;; are pressed; I guess we don't want to be doing this! @@ -240,6 +207,7 @@ ;;; (format *terminal-io* "returning key-name: ~A~%" key-name) key-name)) +;;; ::TODO:: - make these masks parameters so the user can configure them? (defun beagle-modifier-to-modifier-state (flags) (declare (special *-current-event-modifier-state-*)) (let ((mods 0)) @@ -262,6 +230,9 @@ ;;; NSHelpKeyMask ;;; NSNumericKeyPadKeyMask (key on numeric pad was pressed) ;;; NSFunctionKeyMask (function key was pressed) + + ;; ::TODO:: return from setf is the value set, so don't need + ;; the final line below. (setf *-current-event-modifier-state-* mods) mods)) @@ -295,14 +266,104 @@ ;; I'm not sure this is the best way with dealing with the timestamp... +(defun notification-type (notification) +"Enumerates all the Cocoa notifications Beagle takes an interest in. These +are all NSWindow delegate notifications." + (let ((name (send notification 'name))) + (cond ((send name :is-equal-to-string #@"NSWindowDidBecomeKeyNotification") + :became-key) + ((send name :is-equal-to-string #@"NSWindowDidExposeNotification") + :did-expose) + ((send name :is-equal-to-string #@"NSWindowDidResizeNotification") + :did-resize) + ((send name :is-equal-to-string #@"NSWindowWillCloseNotification") + :will-close) + (t :unknown)))) + +(defun event-type (event) +"Enumerates all the Cocoa events Beagle takes an interest in. Returns two +values; the first is the TYPE of event (mouse-up, mouse-move) and the +second is the button pressed at the time of the event. The latter value +will be NIL if no button was involved in the event (or if the event is +not a mouse event)." + (let ((event-type (send event 'type))) + (cond ((equal #$NSLeftMouseUp event-type) + (values :mouse-up :left)) + ((equal #$NSRightMouseUp event-type) + (values :mouse-up :right)) + ((equal #$NSOtherMouseUp event-type) + (values :mouse-up :other)) + ((equal #$NSLeftMouseDown event-type) + (values :mouse-down :left)) + ((equal #$NSRightMouseDown event-type) + (values :mouse-down :right)) + ((equal #$NSOtherMouseDown event-type) + (values :mouse-down :other)) + ((equal #$NSScrollWheel event-type) + (values :scroll-wheel nil)) + ((equal #$NSKeyDown event-type) + (values :key-down nil)) + ((equal #$NSKeyUp event-type) + (values :key-up nil)) + ((equal #$NSMouseMoved event-type) + (values :mouse-moved nil)) + ((equal #$NSLeftMouseDragged event-type) + (values :mouse-moved :left)) + ((equal #$NSRightMouseDragged event-type) + (values :mouse-moved :right)) + ((equal #$NSOtherMouseDragged event-type) + (values :mouse-moved :other)) + ((equal #$NSMouseEntered event-type) + ;; Not really a mouse event... + (values :mouse-enter nil)) + ((equal #$NSMouseExited event-type) + ;; Not really a mouse event... + (values :mouse-exit nil)) + ((equal #$NSFlagsChanged event-type) + (values :flags-changed nil)) + (t (values :unknown nil))))) + + +;;; Record current pointer position + button state so we can 'synthesize' a motion +;;; event at will... this feels like a hack. Is it really necessary? +(defun set-hacky-graft/view-xy (graft-xy view-xy) + (declare (special *-current-pointer-graft-xy-* + *-current-pointer-view-xy-*)) + + ;; Need to free memory assigned via 'make-record'. There's no nice way to do + ;; this :-( + + (unless (or (null *-current-pointer-graft-xy-*) + (eql (%null-ptr) *-current-pointer-graft-xy-*)) + (#_free *-current-pointer-graft-xy-*)) + + (unless (or (null *-current-pointer-view-xy-*) + (eql (%null-ptr) *-current-pointer-view-xy-*)) + (#_free *-current-pointer-view-xy-*)) + + (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint + :x (pref graft-xy :<NSP>oint.x) + :y (pref graft-xy :<NSP>oint.y))) + (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint + :x (pref view-xy :<NSP>oint.x) + :y (pref view-xy :<NSP>oint.y)))) + + +(defun set-hacky-button-state (state) + (declare (special *-current-pointer-button-state*-)) + (setf *-current-pointer-button-state*- state)) + + (let ((timestamp 0)) (defun beagle-notification-to-clim-event (window notification &optional origin-x origin-y width height) (declare (special *beagle-port*)) (let ((return-event nil) - (sheet (%beagle-port-lookup-sheet-for-view *beagle-port* (send window 'content-view)))) + (sheet (%beagle-port-lookup-sheet-for-view *beagle-port* (send window 'content-view))) + (n-type (notification-type notification))) ;; We don't get exposure notifications when the window has a (Cocoa) backing store. + ;; Use 'ecase' for this, like in medium-draw-text? (cond - ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidBecomeKeyNotification") + ((eq :became-key n-type) (setf return-event nil) (when (send window 'is-visible) ; only do if window is on-screen... (let* ((content-view (send window 'content-view)) @@ -313,7 +374,7 @@ (focus (climi::keyboard-input-focus frame))) (unless (null target-sheet) (setf (port-keyboard-input-focus *beagle-port*) focus))))) - ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidExposeNotification") + ((eq :did-expose n-type) (setf return-event (make-instance 'window-repaint-event :timestamp (incf timestamp) :sheet sheet @@ -321,273 +382,255 @@ ;; seem to be a way to specify a region... coord ;; system? :region (make-rectangle* origin-x origin-y width height)))) - ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidResizeNotification") + ((eq :did-resize n-type) (setf return-event (make-instance 'window-configuration-event :sheet sheet :x origin-x ; coord system? :y origin-y :width width :height height))) - ((send (send notification 'name) :is-equal-to-string #@"NSWindowWillCloseNotification") + ((eq :will-close n-type) (setf return-event (make-instance 'window-destroy-event :sheet sheet))) - ;; TODO: this logic is the same as the previous version, but - ;; is it correct? it means that if we get a - ;; notification that we don't recognize, we ignore it + ;; Ignore notifications in which we're uninterested. (t nil)) return-event)) (defun beagle-event-to-clim-event (mirror event) - (declare (special *-current-pointer-button-state-* - *-current-pointer-view-xy-* - *-current-pointer-graft-xy-*)) + (declare (special *-current-pointer-button-state-*)) + (let ((window (send event 'window)) - (return-event event) - ;; Can't do this here any more - it breaks NSFlagsChanged event handling :-( -;;; (modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags))) - (event-type (send event 'type))) - (when (or (equal #$NSLeftMouseUp event-type) - (equal #$NSLeftMouseDown event-type) - (equal #$NSRightMouseUp event-type) - (equal #$NSRightMouseDown event-type) - (equal #$NSOtherMouseUp event-type) - (equal #$NSOtherMouseDown event-type)) - (slet ((location-in-window-point (send event 'location-in-window)) - (window-bounds (send (send window 'content-view) 'bounds))) - (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) - (pref location-in-window-point :<NSP>oint.y))) - - ;;; *SUSPECT* this will leak; gc won't collect heap-allocated store from make-record will it? - (slet ((location-in-view-point (send mirror :convert-point location-in-window-point - :from-view (send window 'content-view))) - (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) - - (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-screen-point :<NSP>oint.x) - :y (pref location-in-screen-point :<NSP>oint.y))) - (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y))) - (setf return-event - (make-instance (if (or (equal #$NSLeftMouseUp event-type) - (equal #$NSRightMouseUp event-type) - (equal #$NSOtherMouseUp event-type)) - 'pointer-button-release-event - 'pointer-button-press-event) - :pointer 0 - :button (cond ((or (equal event-type #$NSLeftMouseUp) - (equal event-type #$NSLeftMouseDown)) - (setf *-current-pointer-button-state-* +pointer-left-button+) - +pointer-left-button+) - ((or (equal event-type #$NSRightMouseUp) - (equal event-type #$NSRightMouseDown)) - (setf *-current-pointer-button-state-* +pointer-right-button+) - +pointer-right-button+) - (t - (setf *-current-pointer-button-state-* +pointer-middle-button+) - +pointer-middle-button+)) - ;; x and y are in window coordinates. They need converting to screen - ;; coordinates. Can do this with - ;; [window convertBaseToScreen:location-in-window].x or .y. - ;; They probably need coercing too :-( - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y) - :graft-x (pref location-in-screen-point :<NSP>oint.x) - :graft-y (pref location-in-screen-point :<NSP>oint.y) - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer no - ;; bigger than a fixnum, so it gets a fixnum. Hope Cocoa doesn't - ;; send non-unique timestamps. - ;; NSTimeInterval is a double typedef - :timestamp (incf timestamp)))))) - ;; (coerce (* 10 (pref timestamp :<NST>ime<I>nterval)) 'fixnum)))))) - - (when (equal #$NSScrollWheel event-type) - (setf return-event (make-instance 'pointer-button-press-event - :pointer 0 - ;; The 'amount' of scroll can be specified in Cocoa by a - ;; larger or smaller delta in either X, Y or Z directions. - ;; We ignore this, and always pass up or down and let - ;; CLIM set the amount. Could do better with scroll wheel - ;; events, CLIM also ignores X and Z deltas... - :button (if (plusp (send event 'delta-y)) + (return-event event)) + (multiple-value-bind (event-type button) + (event-type event) + (when (or (eq :mouse-up event-type) + (eq :mouse-down event-type)) + (slet ((location-in-window-point (send event 'location-in-window)) + (window-bounds (send (send window 'content-view) 'bounds))) + (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) + (pref location-in-window-point :<NSP>oint.y))) + + (slet ((location-in-view-point (send mirror :convert-point location-in-window-point + :from-view (send window 'content-view))) + (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) + + ;; Only want this for 'synthesize-point-motion-event' + (set-hacky-graft/view-xy location-in-screen-point + location-in-view-point) + + (setf return-event + (make-instance (if (eq :mouse-up event-type) + 'pointer-button-release-event + 'pointer-button-press-event) + :pointer 0 + :button (cond ((eq :left button) + (set-hacky-button-state +pointer-left-button+) + +pointer-left-button+) + ((eq :right button) + (set-hacky-button-state +pointer-right-button+) + +pointer-right-button+) + (t + (set-hacky-button-state +pointer-middle-button+) + +pointer-middle-button+)) + ;; x and y are in window coordinates. They need converting to screen + ;; coordinates. Can do this with + ;; [window convertBaseToScreen:location-in-window].x or .y. + ;; They probably need coercing too :-( + :x (pref location-in-view-point :<NSP>oint.x) + :y (pref location-in-view-point :<NSP>oint.y) + :graft-x (pref location-in-screen-point :<NSP>oint.x) + :graft-y (pref location-in-screen-point :<NSP>oint.y) + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer no + ;; bigger than a fixnum, so it gets a fixnum. Hope Cocoa doesn't + ;; send non-unique timestamps. + ;; NSTimeInterval is a double typedef + :timestamp (incf timestamp)))))) + + (when (eq :scroll-wheel event-type) + (setf return-event (make-instance 'pointer-button-press-event + :pointer 0 + ;; The 'amount' of scroll can be specified in Cocoa by a + ;; larger or smaller delta in either X, Y or Z directions. + ;; We ignore this, and always pass up or down and let + ;; CLIM set the amount. Could do better with scroll wheel + ;; events, CLIM also ignores X and Z deltas... + :button (if (plusp (send event 'delta-y)) + (progn + (set-hacky-button-state +pointer-wheel-up+) + +pointer-wheel-up+) (progn - (setf *-current-pointer-button-state-* +pointer-wheel-up+) - +pointer-wheel-up+) - (progn - (setf *-current-pointer-button-state-* +pointer-wheel-down+) - +pointer-wheel-down+)) - ;; Surely scroll-wheel events do not need x, y coords? input.lisp - ;; does a 'call-next-method' after handling the scroll but won't - ;; that then get passed as a 'proper' button press? Best pass these - ;; as values we're unlikely to ever get clicked. - :x 0 - :y 0 - :graft-x 0 - :graft-y 0 - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer no - ;; bigger than a fixnum, so it gets a fixnum. Hope Cocoa doesn't - ;; send non-unique timestamps. - ;; NSTimeInterval is a double typedef - :timestamp (incf timestamp)))) + (set-hacky-button-state +pointer-wheel-down+) + +pointer-wheel-down+)) + ;; Surely scroll-wheel events do not need x, y coords? input.lisp + ;; does a 'call-next-method' after handling the scroll but won't + ;; that then get passed as a 'proper' button press? Best pass these + ;; as values we're unlikely to ever get clicked. + :x 0 + :y 0 + :graft-x 0 + :graft-y 0 + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer at least + ;; as big as a fixnum, so it gets a fixnum. Hope Cocoa doesn't + ;; send non-unique timestamps. + ;; NSTimeInterval is a double typedef + :timestamp (incf timestamp)))) - ;; Keyname should probably be the #$NSF1FunctionKey, #$NSUpArrowFunctionKey etc as defined in the docs - ;; for NSEvent (these are permitted to be implementation defined - not sure if that's the back end - ;; implementation or the McCLIM implementation!), apart from the "standard" keys which should be symbols - ;; in the keyword package (presumably :a :b :c etc.?) + ;; Keyname should probably be the #$NSF1FunctionKey, #$NSUpArrowFunctionKey etc as defined in the docs + ;; for NSEvent (these are permitted to be implementation defined - not sure if that's the back end + ;; implementation or the McCLIM implementation!), apart from the "standard" keys which should be symbols + ;; in the keyword package (presumably :a :b :c etc.?) - ;; ::FIXME:: WILL ONLY WORK FOR "STANDARD" KEYS!!! + ;; ::FIXME:: WILL ONLY WORK FOR "STANDARD" KEYS!!! - (when (or (equal #$NSKeyDown event-type) - (equal #$NSKeyUp event-type)) - (let ((keyname (beagle-key-event-to-key-name event))) -;;; (format *terminal-io* "In event-build with keyname: ~A (characterp = ~A)~%" keyname (characterp keyname)) - (setf return-event (make-instance (if (equal #$NSKeyDown event-type) - 'key-press-event - 'key-release-event) - :key-name keyname - ;; not needed by spec - should change implementation? - :key-character (and (characterp keyname) keyname) - :x 0 ; Not needed for key events? - :y 0 ; Not needed for key events? - :graft-x 0 ; Not needed for key events? - :graft-y 0 ; Not needed for key events? - ;; Irrespective of where the key event happened, send it - ;; to the sheet that has key-focus for the port. - :sheet (beagle-port-key-focus *beagle-port*) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp))))) - (when (or (equal #$NSMouseMoved event-type) - (equal #$NSLeftMouseDragged event-type) - (equal #$NSRightMouseDragged event-type) - (equal #$NSOtherMouseDragged event-type)) - (slet ((location-in-window-point (send event 'location-in-window)) - (window-bounds (send (send window 'content-view) 'bounds))) - ;; Because the location in window is *not* flipped, we need to flip it... (note: we flip by the size - ;; of the window's content view, otherwise we end up out by the size of the window title bar). - ;; *SUSPECT* this will leak; gc won't collect heap-allocated store from make-record will it? - (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) - (pref location-in-window-point :<NSP>oint.y))) - (slet ((location-in-view-point (send mirror :convert-point location-in-window-point - :from-view (send window 'content-view))) - (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) - - (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-screen-point :<NSP>oint.x) - :y (pref location-in-screen-point :<NSP>oint.y))) - (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y))) - (setf return-event - (make-instance 'pointer-motion-event - :pointer 0 - :button (cond ((equal event-type #$NSMouseMoved) - (setf *-current-pointer-button-state-* 0) - 0) - ((equal event-type #$NSLeftMouseDragged) - (setf *-current-pointer-button-state-* +pointer-left-button+) - +pointer-left-button+) - ((equal event-type #$NSRightMouseDragged) - (setf *-current-pointer-button-state-* +pointer-right-button+) - +pointer-right-button+) - (t - (setf *-current-pointer-button-state-* +pointer-middle-button+) - +pointer-middle-button+)) - ;; It looks like McCLIM diverges from the spec again in relation - ;; to events (I wonder who is responsible? 8-) and expects :x and - ;; :y to be relative to the MIRROR in which the events occur. - ;; :x (pref location-in-screen-point :<NSP>oint.x) - ;; :y (pref location-in-screen-point :<NSP>oint.y) - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y) - ;; Even though graft-x, graft-y is *not in the spec* we need to populate - ;; them because there's code in McCLIM/gadgets.lisp that makes direct - ;; use of the graft-x/y slot values. Naughty. So how does this differ - ;; from :x and :y which are supposedly in native coordinates? Methinks - ;; that the event hierarchy and associated code in McCLIM should perhaps - ;; be revisited... currently it appears that these are *only* used to support - ;; pointer-motion-events. Strange. It doesn't seem to make any difference what - ;; gets set here! Suspect we're not invoking the callback because we're not - ;; passing the correct sheet...? + (when (or (eq :key-down event-type) + (eq :key-up event-type)) + (let ((keyname (beagle-key-event-to-key-name event))) + (setf return-event (make-instance (if (eq :key-down event-type) + 'key-press-event + 'key-release-event) + :key-name keyname + ;; not needed by spec - should change implementation? + :key-character (and (characterp keyname) keyname) + :x 0 ; Not needed for key events? + :y 0 ; Not needed for key events? + :graft-x 0 ; Not needed for key events? + :graft-y 0 ; Not needed for key events? + ;; Irrespective of where the key event happened, send it + ;; to the sheet that has key-focus for the port. + :sheet (beagle-port-key-focus *beagle-port*) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp))))) + + (when (eq :mouse-moved event-type) + (slet ((location-in-window-point (send event 'location-in-window)) + (window-bounds (send (send window 'content-view) 'bounds))) + ;; Because the location in window is *not* flipped, we need to flip it... (note: we flip by the size + ;; of the window's content view, otherwise we end up out by the size of the window title bar). + (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) + (pref location-in-window-point :<NSP>oint.y))) + (slet ((location-in-view-point (send mirror :convert-point location-in-window-point + :from-view (send window 'content-view))) + (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) + + (set-hacky-graft/view-xy location-in-screen-point + location-in-view-point) + + (setf return-event + (make-instance 'pointer-motion-event + :pointer 0 + :button (cond ((null button) + (set-hacky-button-state 0) + 0) + ((eq :left button) + (set-hacky-button-state +pointer-left-button+) + +pointer-left-button+) + ((eq :right button) + (set-hacky-button-state +pointer-right-button+) + +pointer-right-button+) + (t + (set-hacky-button-state +pointer-middle-button+) + +pointer-middle-button+)) + ;; It looks like McCLIM diverges from the spec again in relation + ;; to events (I wonder who is responsible? 8-) and expects :x and + ;; :y to be relative to the MIRROR in which the events occur. + ;; :x (pref location-in-screen-point :<NSP>oint.x) + ;; :y (pref location-in-screen-point :<NSP>oint.y) + :x (pref location-in-view-point :<NSP>oint.x) + :y (pref location-in-view-point :<NSP>oint.y) + ;; Even though graft-x, graft-y is *not in the spec* we need to populate + ;; them because there's code in McCLIM/gadgets.lisp that makes direct + ;; use of the graft-x/y slot values. Naughty. So how does this differ + ;; from :x and :y which are supposedly in native coordinates? Methinks + ;; that the event hierarchy and associated code in McCLIM should perhaps + ;; be revisited... currently it appears that these are *only* used to support + ;; pointer-motion-events. Strange. It doesn't seem to make any difference what + ;; gets set here! Suspect we're not invoking the callback because we're not + ;; passing the correct sheet...? ;;; :graft-x (pref location-in-view-point :<NSP>oint.x) ;0 ;;; :graft-y (pref location-in-view-point :<NSP>oint.y) ;0 - :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 - :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 - ;; This is probably wrong too; the NSWindow receives and propogates mouse - ;; moved events, but we need to translate them into an appropriate view. - ;; Not sure quite how we do that, but I think we need to... we're ok for - ;; key down / up, we keep track of the "key view". Do we also need to keep - ;; track of what interactors we have? I suspect not. We just need to traverse - ;; the NSView hierarchy (or sheet hierarchy, whichever is easiest) until we - ;; find the "youngest" view (or sheet) over which the event occurred; this - ;; is the sheet that should handle the event. - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 + :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 + ;; This is probably wrong too; the NSWindow receives and propogates mouse + ;; moved events, but we need to translate them into an appropriate view. + ;; Not sure quite how we do that, but I think we need to... we're ok for + ;; key down / up, we keep track of the "key view". Do we also need to keep + ;; track of what interactors we have? I suspect not. We just need to traverse + ;; the NSView hierarchy (or sheet hierarchy, whichever is easiest) until we + ;; find the "youngest" view (or sheet) over which the event occurred; this + ;; is the sheet that should handle the event. + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp)))))) + + (when (or (eq :mouse-enter event-type) + (eq :mouse-exit event-type)) + #+nil + (let ((view-sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror))) + (when (typep view-sheet 'clim:push-button-pane) + (format *debug-io* "Got ~a event on sheet ~a~%" + event-type view-sheet))) + (slet ((location-in-window-point (send event 'location-in-window)) + (window-bounds (send (send window 'content-view) 'bounds))) + ;; Because the location in window is *not* flipped, we need to flip it... + ;; (note: we flip by the size of the window's content view, otherwise we + ;; end up out by the size of the window title bar). + + ;; Is this where things are going wrong with PUSH-BUTTON-PANE buttons? + ;; Could be... whatever, I think this is a little dodgy... + (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) + (pref location-in-window-point :<NSP>oint.y))) + (slet ((location-in-view-point (send mirror :convert-point location-in-window-point + :from-view (send window 'content-view))) + (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) + + (set-hacky-graft/view-xy location-in-screen-point + location-in-view-point) + + ;; This event does not provide button state, but we can use *-current-pointer-button-state-* + ;; to populate button state in the CLIM event. Obviously, we do not need to update this value + ;; (*-current-pointer-button-state-*) for enter / exit events... + (setf return-event + (make-instance (if (eq :mouse-enter event-type) + 'pointer-enter-event + 'pointer-exit-event) + :pointer 0 + :button *-current-pointer-button-state-* + :x (pref location-in-view-point :<NSP>oint.x) + :y (pref location-in-view-point :<NSP>oint.y) + :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 + :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp)))))) + + ;; We need to maintain the modifier flags state constantly to be able to + ;; implement this; suggest a slot in beagle-port? + (when (eq :flags-changed event-type) + ;; Use the 'old' 'modifiers' in conjunction with the new 'modifier-state' + ;; to work out if this is a key up or a key down... + (setf return-event + (destructuring-bind (event-class key) + (current-mods-map-to-key (send event 'modifier-flags)) + (make-instance event-class + :key-name key + :key-character nil + :x 0 + :y 0 + :graft-x 0 + :graft-y 0 + ;; Irrespective of where the key event happened, send it + ;; to the sheet that has key-focus for the port. + :sheet (beagle-port-key-focus *beagle-port*) :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp)))))) - (when (or (equal #$NSMouseEntered event-type) - (equal #$NSMouseExited event-type)) -;;; (format *debug-io* "Got mouse entered / exited event for mirror ~S~%" mirror) - (slet ((location-in-window-point (send event 'location-in-window)) - (window-bounds (send (send window 'content-view) 'bounds))) - ;; Because the location in window is *not* flipped, we need to flip it... (note: we flip by the size - ;; of the window's content view, otherwise we end up out by the size of the window title bar). - (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) - (pref location-in-window-point :<NSP>oint.y))) - (slet ((location-in-view-point (send mirror :convert-point location-in-window-point - :from-view (send window 'content-view))) - (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) - - (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-screen-point :<NSP>oint.x) - :y (pref location-in-screen-point :<NSP>oint.y))) - (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y))) - ;; This event does not provide button state, but we can use *-current-pointer-button-state-* - ;; to populate button state in the CLIM event. Obviously, we do not need to update this value - ;; (*-current-pointer-button-state-*) for enter / exit events... - (setf return-event - (make-instance (if (equal #$NSMouseEntered event-type) - 'pointer-enter-event - 'pointer-exit-event) - :pointer 0 - :button *-current-pointer-button-state-* - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y) - :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 - :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp)))))) - - ;; We need to maintain the modifier flags state constantly to be able to - ;; implement this; suggest a slot in beagle-port? - (when (equal #$NSFlagsChanged event-type) -;;; (format *debug-io* "In event-build (flags changed)~%") - ;; Use the 'old' 'modifiers' in conjunction with the new 'modifier-state' - ;; to work out if this is a key up or a key down... - (setf return-event - (destructuring-bind (event-class key) - (current-mods-map-to-key (send event 'modifier-flags)) - (make-instance event-class - :key-name key - :key-character nil - :x 0 - :y 0 - :graft-x 0 - :graft-y 0 - ;; Irrespective of where the key event happened, send it - ;; to the sheet that has key-focus for the port. - :sheet (beagle-port-key-focus *beagle-port*) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp))))) + :timestamp (incf timestamp))))) - ;; #$NSHelpRequested- wonder if we can convert this into "user pressed help key" key event? - ;; Then could pull up docs (or could do if there were any!) - ;; #$NSCursorUpdate + ;; #$NSHelpRequested- wonder if we can convert this into "user pressed help key" key event? + ;; Then could pull up docs (or could do if there were any!) + ;; #$NSCursorUpdate - return-event)) + return-event))) ;;; This has been added to McCLIM and the CLX back end; I'm not sure what it's supposed ;;; to be for. Never mind, add it anyway. defgeneric is in stream-input.lisp

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/README.txt
by drose＠common-lisp.net 19 May '05

19 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv24047/beagle Modified Files: README.txt Log Message: Some refactoring of events.lisp; made an effort to trawl for memory allocations and ensure they're freed appropriately. Estimate this to be around 70-80% done. Seems to give performance and stability benefits. Date: Fri May 20 00:25:33 2005 Author: drose Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.11 mcclim/Backends/beagle/README.txt:1.12 --- mcclim/Backends/beagle/README.txt:1.11 Wed May 18 22:21:56 2005 +++ mcclim/Backends/beagle/README.txt Fri May 20 00:25:33 2005 @@ -114,9 +114,9 @@ 4. -> (load "home:load-clim") 5. -> (load "home:load-clx") 6. -> (load "home:load-beagle") -7. -> (setf climi::*default-server-path* :clx) +7. -> (setf climi:*default-server-path* :clx) 8. -> (clim-listener:run-listener) -9. CL-USER> (setf climi::*default-server-path* :beagle) +9. CL-USER> (setf climi:*default-server-path* :beagle) 10. CL-USER> (clim-listener:run-listener-process) I can get both a CLX and a Beagle Listener running simultaneously. @@ -181,7 +181,8 @@ Actually, this ^^^ seems to work fine, but the highlighting for button gadgets looks screwy under OS X. (Think there is a problem with tracking rectangles not being set for - panes. Investigation needed.) + panes. Another alternative relates to the calculation of pointer position + in the MOUSE-ENTER/EXIT event generator.) 7. Keyboard events are not handled "properly" as far as any OS X user will @@ -201,13 +202,6 @@ like to avoid having pixmap caches for mirrors though. -9. Foreign memory management is non-existent. This is fine whilst running - in the same thread as the OpenMCL Listener (since we use its autorelease - pool) but when running in a separate thread lots of warning messages - are generated. You might find it necessary to force-quit OpenMCL after - you've finished. - - 12. There's some debug output remaining in some corner cases. @@ -284,6 +278,13 @@ It's still present in the output history, and mousing over it makes it reappear, but still... not sure why this happens. + +29. Event signal-semaphore and consume-semaphore code isn't quite right; + if the user generates events whilst Beagle is in the middle of a + long-lived operation (generating a big graph, for example), some of + those events are 'trapped' in the queue until other events take place. + Looking at the code, I don't think this should happen... (but it does). + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% FIXED STUFF PREVIOUSLY ON THE KNOWN LIMITATIONS / TODO LIST @@ -317,6 +318,20 @@ FIXED 17.MAY.2005 DAR - the problem was we never invoked 'setf (port-keyboard-input-focus' in handling the 'did become key' notification. + +-9.- Foreign memory management is non-existent. This is fine whilst running + in the same thread as the OpenMCL Listener (since we use its autorelease + pool) but when running in a separate thread lots of warning messages + are generated. You might find it necessary to force-quit OpenMCL after + you've finished. + + UPDATE: have made one pass ensuring heap allocated memory (with + MAKE-RECORD) is free'd, and that retained objects are released. Things + seem much better now but I'm sure I overlooked a few. + Moving this to 'resolved' (but keep eyes open for more occurrences ;-) + + Note: this also seems to have given a bit of a speed-boost; perhaps we + avoid swapping, or have cut down on GC overhead. -10.- Text sizes aren't calculated correctly; when multiple lines are output together, the bottom of one line can be overwritten by the top of the

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/mirror.lisp
by drose＠common-lisp.net 18 May '05

18 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv24418/beagle/windowing Modified Files: mirror.lisp Log Message: Rewrote font metrics code; bounding rectangles around text now look much better. Unfortunately there doesn't seem to be a way not to include Cocoa's own 'leading' in the font metrics, which means the linegap is larger than it needs to be. This can be resolved with a move to 10.4 (new constants in NSStringAdditions to control this). Rejigged the drawing methods somewhat so the 'thinnest visible line' gets displayed which makes bounding rects look better. Artefacts less obvious (but still present )-:) now. Date: Wed May 18 22:21:58 2005 Author: drose Index: mcclim/Backends/beagle/windowing/mirror.lisp diff -u mcclim/Backends/beagle/windowing/mirror.lisp:1.1 mcclim/Backends/beagle/windowing/mirror.lisp:1.2 --- mcclim/Backends/beagle/windowing/mirror.lisp:1.1 Tue May 17 00:13:21 2005 +++ mcclim/Backends/beagle/windowing/mirror.lisp Wed May 18 22:21:58 2005 @@ -590,20 +590,6 @@ (defmethod port-disable-sheet ((port beagle-port) (mirror mirrored-sheet-mixin)) (error "port-disable-sheet: implement me")) -;;; Nabbed from CLX backend medium.lisp -(declaim (inline round-coordinate)) -(defun round-coordinate (x) - "Function used for rounding coordinates: - -We use \"mercantile rounding\", instead of the CL round to nearest -even number, when in doubt. - -Reason: As the CLIM drawing model is specified, you quite often -want to operate with coordinates, which are multiples of 1/2. -Using CL:ROUND gives \"random\" results. Using \"mercantile -rounding\" gives consistent results." - (floor (+ x .5))) - ;;; From CLX/port.lisp - hrm. What the heck is this doing exactly? ;;; I suspect (though can't be sure) that a proper implementation of grafts might ;;; make all this much, much easier.

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/README.txt
by drose＠common-lisp.net 18 May '05

18 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv24418/beagle Modified Files: README.txt Log Message: Rewrote font metrics code; bounding rectangles around text now look much better. Unfortunately there doesn't seem to be a way not to include Cocoa's own 'leading' in the font metrics, which means the linegap is larger than it needs to be. This can be resolved with a move to 10.4 (new constants in NSStringAdditions to control this). Rejigged the drawing methods somewhat so the 'thinnest visible line' gets displayed which makes bounding rects look better. Artefacts less obvious (but still present )-:) now. Date: Wed May 18 22:21:56 2005 Author: drose Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.10 mcclim/Backends/beagle/README.txt:1.11 --- mcclim/Backends/beagle/README.txt:1.10 Tue May 17 22:26:37 2005 +++ mcclim/Backends/beagle/README.txt Wed May 18 22:21:56 2005 @@ -235,16 +235,10 @@ than the NSView 'isFlipped' method? -20. Bounding rectangles are slightly off (this can be seen in CLIM-FIG again). - It's only a matter of a pixel, maybe 2 in the worst case I've seen. - Probably caused by rounding errors in Beagle (we do quite a lot of - int -> float conversion and ordinate manipulation (in cocoa 0.0, 0.0 falls - 'between pixels' - 0.5, 0.5 is 'center of pixel'). - - 21. Highlighting on mouse overs isn't quite right; artefacts are left on the display after the mouse has moved out of the target object bounding - rectangle (most easily visible in CLIM-FIG again). + rectangle (most easily visible in CLIM-FIG again, and also in the + directory view of the Listener (look at the highlighting of the images). 22. Sending key-down / key-up events for modifiers-changed events doesn't @@ -270,16 +264,26 @@ 24. Testing + further work on patterns and stencils. -25. Bounding rects for commands entered in interactor panes are way out; - looks like the baseline of the text is being used as the bottom of - the bounding rect! - - 26. Minimising frames and then restoring them leads to the frame not being drawn properly; it looks like 'drawRect' is invoked (as expected), but nothing to tell McCLIM to redraw the whole frame. Suspect a notification is sent... needs investigation. + +27. Since key focus handling was implemented, closing apps often lands + you in the kernel debugger. As an example, running glimpse, then + the Listener, type something in Listener, give glimpse focus, exit + glimpse, type on Listener -> *boom*. Suspect some reference to + glimpse objects are being kept around when they shouldn't be. + + +28. If a command is entered in the Listener which generates a presentation + immediately underneath ('show class subclasses' is good, the top + node is immediately under the command), and this presentation is + highlighted, when it is unhighlighted the command is cleared also. + It's still present in the output history, and mousing over it makes + it reappear, but still... not sure why this happens. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% FIXED STUFF PREVIOUSLY ON THE KNOWN LIMITATIONS / TODO LIST @@ -360,6 +364,17 @@ it's still there but it can be ignored to all intents and purposes). -18.- Note about force-quit; appended to (5). + +-20.- Bounding rectangles are slightly off (this can be seen in CLIM-FIG again). + It's only a matter of a pixel, maybe 2 in the worst case I've seen. + Probably caused by rounding errors in Beagle (we do quite a lot of + int -> float conversion and ordinate manipulation (in cocoa 0.0, 0.0 falls + 'between pixels' - 0.5, 0.5 is 'center of pixel'). + +-25.- Bounding rects for commands entered in interactor panes are way out; + looks like the baseline of the text is being used as the bottom of + the bounding rect! + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/output/fonts.lisp mcclim/Backends/beagle/output/medium.lisp
by drose＠common-lisp.net 18 May '05

18 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv24418/beagle/output Modified Files: fonts.lisp medium.lisp Log Message: Rewrote font metrics code; bounding rectangles around text now look much better. Unfortunately there doesn't seem to be a way not to include Cocoa's own 'leading' in the font metrics, which means the linegap is larger than it needs to be. This can be resolved with a move to 10.4 (new constants in NSStringAdditions to control this). Rejigged the drawing methods somewhat so the 'thinnest visible line' gets displayed which makes bounding rects look better. Artefacts less obvious (but still present )-:) now. Date: Wed May 18 22:21:57 2005 Author: drose Index: mcclim/Backends/beagle/output/fonts.lisp diff -u mcclim/Backends/beagle/output/fonts.lisp:1.1 mcclim/Backends/beagle/output/fonts.lisp:1.2 --- mcclim/Backends/beagle/output/fonts.lisp:1.1 Tue May 17 00:13:19 2005 +++ mcclim/Backends/beagle/output/fonts.lisp Wed May 18 22:21:57 2005 @@ -122,26 +122,43 @@ ;;; performance. It's possible that the caching can be improved. Caching doesn't adversly ;;; affect performance though so it's staying in. +#|| +origin 0.0 + 0.0+------------------------+ + | ^ ^ | + | |height |ascent | + | | | width | + |<|-------|------------->| + | | v | + 12.0 +-|----------------------+ + | | ^descent | + | v v | + 15.0 +------------------------+ + +Baseline = 12.0 +Height = 15.0 == height +Ascent = 12.0 == (height - (height - baseline)) == baseline +Descent = 3.0 == (height - ascent) == (height - baseline) +Width = width +||# + (defun beagle-font-metrics (metric text-style medium &optional (char nil)) "Metric is one of :ascent :descent :width :height" - (declare (ignore medium)) ; for now... - (when char - (setf char (format nil "~a" char))) - (let* ((key (if char (cons text-style char) text-style)) + (declare (special *beagle-font-metrics*)) + (let* ((string (if char + (string char) + "m")) + (key (cons text-style string)) ; possible to avoid consing? (metrics (gethash key *beagle-font-metrics*))) (when (null metrics) - ;; No metrics found in the hashtable; lookup the font and representative character, - ;; and populate the hashtable. - (let ((nsfont (%text-style->beagle-font (or text-style *default-text-style*))) - (representative (if char (%make-nsstring char) #@"m"))) - ;; populate metrics, and the hashtable, accordingly with width, - ;; height, ascent, descent of text-style. - ;; Should the height actually be ascent + descent? Probably want to (abs) the descender too... - (setf metrics (list `(:ascent . ,(send nsfont 'ascender)) - `(:descent . ,(abs (send nsfont 'descender))) - `(:width . ,(send nsfont :width-of-string representative)) - `(:height . ,(send nsfont 'default-line-height-for-font)))) - (setf (gethash key *beagle-font-metrics*) metrics))) + (multiple-value-bind (width height x y baseline) + (text-size medium string :text-style text-style) + (declare (ignore x y)) + (setf metrics (list `(:ascent . ,baseline) + `(:descent . ,(- height baseline)) + `(:width . ,width) + `(:height . ,height)))) + (setf (gethash key *beagle-font-metrics*) metrics)) (cdr (assoc metric metrics)))) @@ -183,45 +200,76 @@ ;;; All mediums and output sheets must implement a method for this generic function. -;;; This is the primary method McCLIM uses to lay out text, so we have to get it right... -;;; Spec says for STREAMS (and the text WILL be output in a "stream") the origin is in the TOP LEFT -;;; corner (graft :default orientation). Cocoa assumes everything uses an orign in the BOTTOM LEFT -;;; corner (graft :graphics orientation). We calculate the size the way CLIM wants it calculated, -;;; and hope this means CLIM can lay everything out properly. - -;;; TODO: what is the meaning of START and END? Not the boundaries of a -;;; substring whose size is to be determined; the logic below -;;; ignores such possibilities - (defmethod text-size ((medium beagle-medium) string &key text-style (start 0) end) + (declare (special *default-text-style*)) + + ;; Method can be passed either a string or a char; make sure for the latter + ;; that we see only strings. (when (characterp string) (setf string (string string))) - (unless end (setf end (length string))) - (unless text-style (setf text-style (medium-text-style medium))) - (if (= start end) + + ;; Make sure there's an 'end' specified + (unless end + (setf end (length string))) + + ;; Make sure there's a text-style + (unless text-style + (setf text-style (medium-text-style medium))) + + ;; Check for 'empty string' case + (if (>= start end) (values 0 0 0 0 0) - (let (;(position-newline (position #\newline string :start start)) - (objc-string (%make-nsstring (subseq string start end))) - (beagle-font (%text-style->beagle-font (or text-style *default-text-style*)))) - ;; Now we actually need to take the font into account! - (slet ((bsize (send objc-string :size-with-attributes (reuse-attribute-dictionary medium beagle-font)))) - (values (pref bsize :<NSS>ize.width) ; width - (pref bsize :<NSS>ize.height) ; height - (pref bsize :<NSS>ize.width) ; new x - ;; new y - (- (pref bsize :<NSS>ize.height) (send beagle-font 'default-line-height-for-font)) - ;; baseline - assume linegap is equal above + below the font... - ;; baseline is at (- height (1/2 linegap) descender) - (- (pref bsize :<NSS>ize.height) (/ (- (send beagle-font 'default-line-height-for-font) - (send beagle-font 'ascender) - (abs (send beagle-font 'descender))) - 2) - (abs (send beagle-font 'descender)))))))) - - -;;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want to draw them in a specific -;;; colour (unless McCLIM sets the medium foreground colour in order to achieve drawing elements in specific -;;; colours). + (let ((position-newline (position #\newline string :start start)) + ;; See if there's a better way to do this; is this stack + ;; allocation? + (objc-str (%make-nsstring (subseq string start end))) + (font (%text-style->beagle-font (or text-style + *default-text-style*)))) + (slet ((bsize (send objc-str :size-with-attributes + (reuse-attribute-dictionary medium font)))) + ;; Don't use 'text-style-descent' in the following, since that + ;; method is defined in terms of this one :-) + (let* ((descender (abs (send font 'descender))) + (fragment-width (pref bsize :<NSS>ize.width)) + (fragment-height (pref bsize :<NSS>ize.height)) + (fragment-x (pref bsize :<NSS>ize.width)) + ;; subtract line height from this later... + (fragment-y (pref bsize :<NSS>ize.height)) + ;; baseline = height - descender + (fragment-baseline (- fragment-height descender))) + (send objc-str 'release) + (if (null position-newline) + (values fragment-width + fragment-height + fragment-x + (- fragment-y fragment-height) + fragment-baseline) + (progn + (multiple-value-bind (w h x y b) + (text-size medium string :text-style text-style + :start position-newline + :end end) + ;; Current width, or width of sub-fragment, whichever + ;; is larger + (let ((largest-width (max fragment-width w)) + ;; current height + height of sub-fragment + (current+fragment-height (+ fragment-height h)) + ;; new y position; one line height smaller than the + ;; total height + (y-position (- (+ fragment-y y) fragment-height)) + ;; baseline of string; total height - baseline size, where + ;; baseline 'size' is (line-height - baseline). + (baseline (- (+ fragment-height h) (- h b)))) + (values largest-width + current+fragment-height + x ; always use last x calculated... + y-position + baseline)))))))))) + + +;;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want +;;; to draw them in a specific colour (unless McCLIM sets the medium foreground colour +;;; in order to achieve drawing elements in specific colours). (let ((reusable-dict nil)) ;; create a mutable dictionary on-demand and reuse it Index: mcclim/Backends/beagle/output/medium.lisp diff -u mcclim/Backends/beagle/output/medium.lisp:1.1 mcclim/Backends/beagle/output/medium.lisp:1.2 --- mcclim/Backends/beagle/output/medium.lisp:1.1 Tue May 17 00:13:19 2005 +++ mcclim/Backends/beagle/output/medium.lisp Wed May 18 22:21:57 2005 @@ -577,12 +577,44 @@ (do-sequence ((left top right bottom) coord-seq) (when (< right left) (rotatef left right)) (when (< top bottom) (rotatef top bottom)) - (let ((rect (ccl::make-ns-rect left bottom (- right left) (- top bottom)))) + (let ((rect (ccl::make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) (send path :append-bezier-path-with-rect rect))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) +;; ::FIXME:: Move these from here! +(defun pixel-center (pt) +"Ensure any ordinate provided sits on the center of a pixel. This +prevents Cocoa from 'antialiasing' lines, making them thicker and +a shade of grey. Ensures the return value is a short-float, as +required by the Cocoa methods." +;; Interesting... I thought 'center of pixel' was 0.5, 1.5, ... n.5 +;; but this works much better with 0.0, 1.0, 2.0... +;; (coerce (+ (round-coordinate pt) 0.5) 'short-float)) + (coerce (round-coordinate pt) 'short-float)) + +(defun pixel-count (sz) +"Ensures any value provided is rounded to the nearest unit, and +returned as a short-float as required by the Cocoa methods." + (coerce (round-coordinate sz) 'short-float)) + +;;; Nabbed from CLX backend medium.lisp +(declaim (inline round-coordinate)) +(defun round-coordinate (x) + "Function used for rounding coordinates: + +We use \"mercantile rounding\", instead of the CL round to nearest +even number, when in doubt. + +Reason: As the CLIM drawing model is specified, you quite often +want to operate with coordinates, which are multiples of 1/2. +Using CL:ROUND gives \"random\" results. Using \"mercantile +rounding\" gives consistent results." + (floor (+ x .5))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -620,8 +652,10 @@ (origin-y (- center-y radius-dy)) (width (* 2 radius-dx)) (height (* 2 radius-dy))) - (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect origin-x origin-y - width height)) + (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect (pixel-center origin-x) + (pixel-center origin-y) + (pixel-count width) + (pixel-count height))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) @@ -632,10 +666,10 @@ (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-beagle-graphics (medium) (with-transformed-position (tr center-x center-y) - (slet ((point (ns-make-point (coerce center-x 'short-float) - (coerce center-y 'short-float)))) + (slet ((point (ns-make-point (pixel-center center-x) + (pixel-center center-y)))) (send path :append-bezier-path-with-arc-with-center point - :radius (coerce radius 'short-float) + :radius (pixel-count radius) :start-angle (coerce (/ start-angle (/ pi 180)) 'short-float) :end-angle (coerce (/ end-angle (/ pi 180)) 'short-float) :clockwise NIL))) @@ -683,10 +717,10 @@ (with-beagle-graphics (medium) (with-transformed-position (tr x1 y1) (with-transformed-position (tr x2 y2) - (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) - (+ (coerce y1 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) - (+ (coerce y2 'short-float) 0.5)))) + (slet ((p1 (ns-make-point (pixel-center x1) + (pixel-center y1))) + (p2 (ns-make-point (pixel-center x2) + (pixel-center y2)))) (send path :move-to-point p1) (send path :line-to-point p2) (send mirror :stroke-path path :in-colour colour))))))) @@ -706,10 +740,10 @@ (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-beagle-graphics (medium) (do-sequence ((x1 y1 x2 y2) coord-seq) - (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) - (+ (coerce y1 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) - (+ (coerce y2 'short-float) 0.5)))) + (slet ((p1 (ns-make-point (pixel-center x1) + (pixel-center y1))) + (p2 (ns-make-point (pixel-center x2) + (pixel-center y2)))) (send path :move-to-point p1) (send path :line-to-point p2))) (send mirror :stroke-path path :in-colour colour)))) @@ -731,13 +765,13 @@ (when (< top bottom) (rotatef top bottom)) (when (and filled (or (typep ink 'climi::transformed-design) (typep ink 'climi::indexed-pattern))) - (send mirror :draw-image colour :at-point (ns-make-point (coerce left 'short-float) - (coerce top 'short-float))) + (send mirror :draw-image colour :at-point (ns-make-point (pixel-center left) + (pixel-center top))) (return-from medium-draw-rectangle* (values))) - (send path :append-bezier-path-with-rect (ccl::make-ns-rect (coerce left 'short-float) - (coerce bottom 'short-float) - (coerce (- right left) 'short-float) - (coerce (- top bottom) 'short-float))) + (send path :append-bezier-path-with-rect (ccl::make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom)))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour))))))) @@ -757,12 +791,12 @@ (assert (evenp (length coord-seq))) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-beagle-graphics (medium) - (send path :move-to-point (ns-make-point (coerce (elt coord-seq 0) 'short-float) - (coerce (elt coord-seq 1) 'short-float))) + (send path :move-to-point (ns-make-point (pixel-center (elt coord-seq 0)) + (pixel-center (elt coord-seq 1)))) (do ((count 2 (+ count 2))) ((> count (1- (length coord-seq)))) - (slet ((pt (ns-make-point (coerce (elt coord-seq count) 'short-float) - (coerce (elt coord-seq (1+ count)) 'short-float)))) + (slet ((pt (ns-make-point (pixel-center (elt coord-seq count)) + (pixel-center (elt coord-seq (1+ count)))))) (send path :line-to-point pt))) ;; ensure polyline joins up if appropriate. This needs to be done after ;; all points have been set in the bezier path. @@ -799,18 +833,22 @@ (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) (text-size medium string :start start :end end) (declare (ignore x-cursor y-cursor)) - (setf x (+ (- x (ecase align-x - (:left 0) - (:center (round text-width 2)) - (:right text-width)) 0.5))) - (setf y (+ (ecase align-y - (:top (- y text-height)) - (:center (- y (floor text-height 2))) - (:baseline (- y baseline)) - (:bottom y)) 0.5)) + (setf x (- x (ecase align-x + (:left 0) + (:center (round text-width 2)) + (:right text-width)))) + (setf y (ecase align-y +;;; (:top (- y text-height)) + (:top y) + (:center (- y (floor text-height 2))) + (:baseline (- y baseline)) +;;; (:bottom y))) + (:bottom (- y text-height)))) (slet ((point (ns-make-point (coerce x 'short-float) (coerce y 'short-float)))) (let ((objc-string (%make-nsstring (subseq string start end)))) + ;; NB: draw-string-at-point uses upper-left as origin in a flipped + ;; view. (send mirror :draw-string objc-string :at-point point :with-attributes (reuse-attribute-dictionary medium font :colour colour)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/port.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv28707/beagle/windowing Modified Files: port.lisp Log Message: Removed *DEFAULT-BEAGLE-FRAME-MANAGER*. Use *DEFAULT-FRAME-MANAGER* instead. Updated README accordingly. Date: Tue May 17 22:26:38 2005 Author: drose Index: mcclim/Backends/beagle/windowing/port.lisp diff -u mcclim/Backends/beagle/windowing/port.lisp:1.3 mcclim/Backends/beagle/windowing/port.lisp:1.4 --- mcclim/Backends/beagle/windowing/port.lisp:1.3 Tue May 17 19:56:20 2005 +++ mcclim/Backends/beagle/windowing/port.lisp Tue May 17 22:26:38 2005 @@ -28,7 +28,7 @@ (defparameter *beagle-port* nil) -(defparameter *default-beagle-frame-manager* 'beagle::beagle-aqua-frame-manager +(defparameter *default-beagle-frame-manager* 'beagle:beagle-aqua-frame-manager "Specifies the frame manager that should be used by default when the port creates its frame manager. Permissable values are 'beagle::beagle-standard-frame-manager and 'beagle::beagle-aqua-frame-manager (the default).") @@ -111,8 +111,11 @@ "Initialises an instance of a BEAGLE-PORT. This makes an instance of the default FRAME-MANAGER and standard-pointer for this port type." (declare (ignore args) - (special *beagle-port* *default-beagle-frame-manager*)) - (push (make-instance *default-beagle-frame-manager* :port port) (slot-value port 'frame-managers)) + (special *beagle-port* *default-frame-manager* *default-beagle-frame-manager*)) + (if (null *default-frame-manager*) + (push (make-instance *default-beagle-frame-manager* :port port) + (slot-value port 'frame-managers)) + (push (make-instance *default-frame-manager* :port port) (slot-value port 'frame-managers))) (setf (slot-value port 'pointer) (make-instance 'standard-pointer :port port)) (setf *beagle-port* port)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/README.txt mcclim/Backends/beagle/load-beagle.lisp mcclim/Backends/beagle/package.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv28707/beagle Modified Files: README.txt load-beagle.lisp package.lisp Log Message: Removed *DEFAULT-BEAGLE-FRAME-MANAGER*. Use *DEFAULT-FRAME-MANAGER* instead. Updated README accordingly. Date: Tue May 17 22:26:37 2005 Author: drose Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.9 mcclim/Backends/beagle/README.txt:1.10 --- mcclim/Backends/beagle/README.txt:1.9 Tue May 17 22:12:36 2005 +++ mcclim/Backends/beagle/README.txt Tue May 17 22:26:37 2005 @@ -5,7 +5,7 @@ . README . INSTALLATION . CONFIGURATION - . default frame manager + . frame manager . multiple ports . KNOWN LIMITATIONS / TODO LIST . FIXED STUFF PREVIOUSLY ON THE KNOWN LIMITATIONS / TODO LIST @@ -85,18 +85,17 @@ CONFIGURATION -default frame manager: ----------------------- +frame manager: +-------------- The Beagle back end defines two frame manager objects; one is the aqua look and feel, the other is the 'standard' McCLIM look and feel. If you want to configure a specific frame manager to be used, set the following parameter:- -BEAGLE::*DEFAULT-BEAGLE-FRAME-MANAGER* <defined in 'port.lisp'> - -> 'beagle::beagle-aqua-frame-manager [default] - -> 'beagle::beagle-standard-frame-manager +CLIM:*DEFAULT-FRAME-MANAGER* + -> 'beagle:beagle-aqua-frame-manager [default] + -> 'beagle:beagle-standard-frame-manager -Should use CLIM:*DEFAULT-FRAME-MANAGER* for this! Note that as yet, no native (aqua) look and feel panes have been defined, so it doesn't matter which frame manager you use. @@ -227,10 +226,6 @@ things got before blowing up) but now it just looks messy. -17. *BEAGLE-DEFAULT-FRAME-MANAGER* should be replaced with the standard - *DEFAULT-FRAME-MANAGER* instead. - - 19. Menus don't work in CLIM-FIG (or anywhere else!). No idea why not... This is because (I think) the menu popups don't operate in a flipped coord system (unlike NSViews). [Command menu that is drawn across @@ -358,6 +353,11 @@ allocated. Some are stack-allocated and cause errors about 'bogus' objects once they go out of scope. At least, I think (and hope) that's the reason 'cause that's easy to fix. RESOLVED 17.JUL.04 + +-17.- *BEAGLE-DEFAULT-FRAME-MANAGER* should be replaced with the standard + *DEFAULT-FRAME-MANAGER* instead. + FIXED 17.MAY.2005 - *beagle-default-frame-manager* is no more (well... + it's still there but it can be ignored to all intents and purposes). -18.- Note about force-quit; appended to (5). Index: mcclim/Backends/beagle/load-beagle.lisp diff -u mcclim/Backends/beagle/load-beagle.lisp:1.2 mcclim/Backends/beagle/load-beagle.lisp:1.3 --- mcclim/Backends/beagle/load-beagle.lisp:1.2 Tue May 17 00:13:08 2005 +++ mcclim/Backends/beagle/load-beagle.lisp Tue May 17 22:26:37 2005 @@ -7,5 +7,6 @@ ;;; want 'beagle::beagle-aqua-frame-manager, you don't need to set this since that ;;; is the default). ;;;(setf beagle::*default-beagle-frame-manager* 'beagle::beagle-standard-frame-manager) -(setf beagle::*default-beagle-frame-manager* 'beagle::beagle-aqua-frame-manager) +;;;(setf beagle::*default-beagle-frame-manager* 'beagle::beagle-aqua-frame-manager) +(setf clim:*default-frame-manager* 'beagle:beagle-aqua-frame-manager) (format t "~%Done.~%") Index: mcclim/Backends/beagle/package.lisp diff -u mcclim/Backends/beagle/package.lisp:1.3 mcclim/Backends/beagle/package.lisp:1.4 --- mcclim/Backends/beagle/package.lisp:1.3 Tue May 17 00:13:09 2005 +++ mcclim/Backends/beagle/package.lisp Tue May 17 22:26:37 2005 @@ -112,5 +112,7 @@ #:send-super #:slet #:with-cstrs - #:with-nsstr)) + #:with-nsstr) + (:export #:beagle-standard-frame-manager + #:beagle-aqua-frame-manager))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/native/lisp-window-delegate.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory common-lisp.net:/tmp/cvs-serv27747/beagle/native Modified Files: lisp-window-delegate.lisp Log Message: Fixed annoying (and long term) issue with key focus. Focus is now (or at least, appears to now be) set correctly. Updated README.txt accordingly. Date: Tue May 17 22:12:38 2005 Author: drose Index: mcclim/Backends/beagle/native/lisp-window-delegate.lisp diff -u mcclim/Backends/beagle/native/lisp-window-delegate.lisp:1.1 mcclim/Backends/beagle/native/lisp-window-delegate.lisp:1.2 --- mcclim/Backends/beagle/native/lisp-window-delegate.lisp:1.1 Tue May 17 00:13:17 2005 +++ mcclim/Backends/beagle/native/lisp-window-delegate.lisp Tue May 17 22:12:37 2005 @@ -47,20 +47,6 @@ ;;; in the events.lisp file. ;;; -#|| - -(define-objc-method ((:void :window-did-expose notification) lisp-window-delegate) - (nslog (format nil "LISP-WINDOW-DELEGATE: received windowDidExpose event")) - (nslog (format nil "Notification name is: ~A" (description (send notification 'name)))) - ;; Window extents should be non-nil in this case... We can get an NSExposedRect out of the userInfo - ;; dictionary in the notification and pass this back to CLIM. Should speed things up a little... - #+nyi (slet ((rect (send (send notification 'object) 'frame))) - (add-notification-to-queue (send notification 'object) notification - (pref rect :<NSR>ect.origin.x) - (pref rect :<NSR>ect.origin.y) - (pref rect :<NSR>ect.size.width) - (pref rect :<NSR>ect.size.height)))) -||# (define-objc-method ((:void :window-did-resize notification) lisp-window-delegate) ;;; (nslog (format nil "LISP-WINDOW-DELEGATE: received windowDidResize event")) @@ -73,7 +59,14 @@ (pref rect :<NSR>ect.size.width) (pref rect :<NSR>ect.size.height)))) +(define-objc-method ((:void :window-did-become-key notification) lisp-window-delegate) + (add-notification-to-queue (send notification 'object) notification)) + +;;; No notifications below this point that we're interested in. #|| + +;;; ... although this one might be useful. Especially wrt native cut&paste. + (define-objc-method ((:void :window-will-close notification) lisp-window-delegate) (nslog (format nil "LISP-WINDOW-DELEGATE: received windowWillClose event")) (nslog (format nil "Notification name is: ~A" (description (send notification 'name)))) @@ -86,9 +79,6 @@ ||# -(define-objc-method ((:void :window-did-become-key notification) lisp-window-delegate) - (nslog (format nil "LISP-WINDOW-DELEGATE: received windowDidBecomeKey event")) - (add-notification-to-queue (send notification 'object) notification)) #|| (define-objc-method ((:void :window-did-change-screen notification) lisp-window-delegate) @@ -148,6 +138,20 @@ ;;; (nslog (format nil "LISP-WINDOW-DELEGATE: received windowDidWillResize event")) ;;; size) ;;; (send-super :window-will-resize ns-window :to-size size)) + + + +;;;(define-objc-method ((:void :window-did-expose notification) lisp-window-delegate) +;;; (nslog (format nil "LISP-WINDOW-DELEGATE: received windowDidExpose event")) +;;; (nslog (format nil "Notification name is: ~A" (description (send notification 'name)))) +;;; ;; Window extents should be non-nil in this case... We can get an NSExposedRect out of the userInfo +;;; ;; dictionary in the notification and pass this back to CLIM. Should speed things up a little... +;;; #+nyi (slet ((rect (send (send notification 'object) 'frame))) +;;; (add-notification-to-queue (send notification 'object) notification +;;; (pref rect :<NSR>ect.origin.x) +;;; (pref rect :<NSR>ect.origin.y) +;;; (pref rect :<NSR>ect.size.width) +;;; (pref rect :<NSR>ect.size.height))))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv27747/beagle/input Modified Files: events.lisp Log Message: Fixed annoying (and long term) issue with key focus. Focus is now (or at least, appears to now be) set correctly. Updated README.txt accordingly. Date: Tue May 17 22:12:37 2005 Author: drose Index: mcclim/Backends/beagle/input/events.lisp diff -u mcclim/Backends/beagle/input/events.lisp:1.2 mcclim/Backends/beagle/input/events.lisp:1.3 --- mcclim/Backends/beagle/input/events.lisp:1.2 Tue May 17 19:51:14 2005 +++ mcclim/Backends/beagle/input/events.lisp Tue May 17 22:12:37 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.2 2005/05/17 17:51:14 drose Exp $ +$Id: events.lisp,v 1.3 2005/05/17 20:12:37 drose Exp $ All these are copied pretty much from CLX/port.lisp @@ -302,24 +302,17 @@ (sheet (%beagle-port-lookup-sheet-for-view *beagle-port* (send window 'content-view)))) ;; We don't get exposure notifications when the window has a (Cocoa) backing store. (cond - ;; I'm not sure this is right; we need to find the sheet in the hierarchy of this window - ;; that can accept key events. Can there be multiple sheets this counts for? I'd guess - ;; so, in which case how do we know which one to set as port key focus? Suspect we can - ;; only know this by tracking the last view that can be key that received a mouse down? - ;; *Should* be able to do this by doing a :hit-test on the content view of the receiving - ;; window after manually grabbing the pointer coordinates. ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidBecomeKeyNotification") (setf return-event nil) (when (send window 'is-visible) ; only do if window is on-screen... - ;; NB: this isn't in the right coordinate system! Convert screen -> content view coords. - (slet ((pointer-loc (send (@class ns-event) 'mouse-location)) - (loc-in-window (send window :convert-screen-to-base pointer-loc))) - (let* ((content-view (send window 'content-view)) - (target-view (send content-view :hit-test loc-in-window)) - (target-sheet (%beagle-port-lookup-sheet-for-view *beagle-port* target-view))) - (unless (null target-sheet) - (format *debug-io* "Setting focus in *beagle-port* onto (hopefully correct) sheet: ~S~%" target-sheet) - (%set-port-keyboard-focus target-sheet *beagle-port*)))))) + (let* ((content-view (send window 'content-view)) + (target-sheet (%beagle-port-lookup-sheet-for-view *beagle-port* content-view)) + (frame (pane-frame target-sheet)) + ;; Works out which sheet *should* be the focus, not which is currently... + ;; or at least, so I think. + (focus (climi::keyboard-input-focus frame))) + (unless (null target-sheet) + (setf (port-keyboard-input-focus *beagle-port*) focus))))) ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidExposeNotification") (setf return-event (make-instance 'window-repaint-event :timestamp (incf timestamp) @@ -703,19 +696,28 @@ ;;; (oops, we lose the timestamp here.) ;;; Cocoa note: the Frame (NSWindow) must be made key for us to receive events; but they -;;; must then be sent to the Sheet that has focus. +;;; must then be sent to the Sheet that has focus. Whilst there are Cocoa mechanisms to +;;; do this, it's probably best to let CLIM decide on the appropriate sheet and we just +;;; send all key events to it. -;;; NB. when the method was renamed it appears that the argument order was also changed. (defmethod %set-port-keyboard-focus ((port beagle-port) focus &key timestamp) (declare (ignore timestamp)) - (let ((mirror (sheet-mirror focus))) - (when mirror - (let ((window (send mirror 'window))) - (when window - (setf (beagle-port-key-focus port) focus) - (if (send window 'is-key-window) - (send window :order-front nil) - (send window :make-key-and-order-front nil))))))) + (if (eq (beagle-port-key-focus port) focus) + (format *trace-output* "Attempt to set keyboard focus on sheet ~a which already has focus.~%" + focus) + (let ((mirror (sheet-mirror focus))) + (if (null mirror) + (format *trace-output* "Attempt to set keyboard focus on sheet ~a which has no mirror!~%" + focus) + (let ((window (send mirror 'window))) + (if (eql window (%null-ptr)) + (format *trace-output* "Attempt to set keyboard focus on sheet ~a with no NSWindow!~%" + focus) + (progn + (setf (beagle-port-key-focus port) focus) + (unless (send window 'is-key-window) + (send window 'make-key-window))))))))) + ;;; Not sure we need to do this... apparently we do. I have stopped flushing ;;; the window after every drawing op, and now things don't get output

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/README.txt
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv27747/beagle Modified Files: README.txt Log Message: Fixed annoying (and long term) issue with key focus. Focus is now (or at least, appears to now be) set correctly. Updated README.txt accordingly. Date: Tue May 17 22:12:36 2005 Author: drose Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.8 mcclim/Backends/beagle/README.txt:1.9 --- mcclim/Backends/beagle/README.txt:1.8 Tue May 17 00:13:08 2005 +++ mcclim/Backends/beagle/README.txt Tue May 17 22:12:36 2005 @@ -5,10 +5,10 @@ . README . INSTALLATION . CONFIGURATION - . debug . default frame manager - . listener + . multiple ports . KNOWN LIMITATIONS / TODO LIST + . FIXED STUFF PREVIOUSLY ON THE KNOWN LIMITATIONS / TODO LIST . WISH LIST . APPLICATIONS @@ -76,7 +76,7 @@ loop. Note #3: If you'd rather run with the CLX back end, load CLX - instead here. It is possible to with multiple ports simultaneously + instead here. It is possible to run multiple ports simultaneously so that both a CLX and a Beagle Listener can be run side by side for comparative purposes (or just because the Listener is actually usable for something useful when running under CLX). @@ -137,11 +137,18 @@ large output history. Paolo's stress test takes 26 seconds and conses 16MB on my (admittedly slow) iMac compared to 1.5 seconds on a 2.4GHz Pentium IV and unknown (to me) consing. - Should be able to speed things up by performing fewer focus lock / unlocks, - and by not setting drawing options unless necessary. I don't know how - far this will get us though... - UPDATE - 21.AUG.2004 - performing fewer NSWindow flushes makes no difference - to speed. + + NB: the number of subclasses of T when running Beagle is about twice the + number when running CLX (because the Cocoa bridge introduces every + Cocoa object into the Lisp image, and even just the core + appkit + frameworks are large). Additionally, I think allocated Cocoa objects + are included in the cons measurement of the Lisp image which accounts + for a chunk of the memory usage. + + Should be able to speed things up by not setting drawing options unless + necessary. A hammer-like approach to do this has been implemented but could + do with a little finessing. + UPDATE - 25.APR.2005 - When the mirror transformation is set (sheet is scrolling) we dispatch a repaint on the 'untransformed mirror region' (using the mirror transformation as the 'untransformation') @@ -153,33 +160,30 @@ no redraw happens from CLIM generally. Also, Cocoa appears to get really slow at rendering text when the output history gets too large (maybe this is CLIM again, it's hard to know). Need to profile. - TODO: cache lisp-bezier-path instances and reuse them. Use approximation for - text sizing (there's as much overhead working out how big rendered text - would be as there is to rendering the text itself, or almost). -2. When running the Listener (and probably other applications), the resize + TODO: Use approximation for text sizing (there's as much overhead working out + how big rendered text would be as there is to rendering the text itself, + or almost). + + TODO: Use pixmap for mirror contents and use blitting to copy areas? + + +2. When running the Listener (and other applications), the resize handle is not visible; it's there, but you can't see it. Grab and drag with faith and it should work anyway. + 3. There are not yet any aqua look and feel panes. Sorry, I'm trying to get everything else working first! + 5. Mouse down / up on buttons appears not to work very well unless the frame containing the buttons is the only active frame. Actually, this ^^^ seems to work fine, but the highlighting for button gadgets looks screwy under OS X. + (Think there is a problem with tracking rectangles not being set for + panes. Investigation needed.) -6. Swapping between key windows (the window accepting the keyboard input) - is a little flakey; as an example, if a second Listener is started from - the first, clicking between the windows transfers key focus (as - expected). However, if the first is then 'Exit'ed, the second will not - get the key focus until some other (non-McCLIM) window has been given - the keyboard focus first (i.e. click on the OpenMCL Listener window, - then back on the McCLIM Listener window). - Additionally, clicking on a scroll-bar (for example) makes the window - key, so clicking on a view that accepts keyboard input (interactor) - within this window won't then allow keyboard input. - We should stop scroll-bars being able to get keyboard input... 7. Keyboard events are not handled "properly" as far as any OS X user will be concerned; only the ASCII characters are recognised, along with @@ -187,16 +191,26 @@ Emacs-like CTRL-B (backward char), CTRL-F (forward char), CTRL-A (start of line), CTRL-E (end of line), CTRL-D (delete char). + 8. There is no +flipping-ink+ implementation. Anything drawn in flipping ink shows up bright red with about 50% transparency (which is why the cursor looks so strange). + NB: moving to 10.4 (Tiger) would fix this since there's an XOR mode + on NSBezierPath in that OS version. So too would implementing pixmaps + for mirrors, since we can do XOR image compositing. My gut feel is I'd + like to avoid having pixmap caches for mirrors though. + + 9. Foreign memory management is non-existent. This is fine whilst running in the same thread as the OpenMCL Listener (since we use its autorelease pool) but when running in a separate thread lots of warning messages - are generated. + are generated. You might find it necessary to force-quit OpenMCL after + you've finished. + + +12. There's some debug output remaining in some corner cases. -12. There's probably some debug output remaining in some corner cases. 15. Popup menus don't work quite the same way as they do in the CLX back end. Cocoa doesn't support pointer grabbing so disposing of menus when @@ -204,23 +218,27 @@ a command, or mouse-click on a different window to get rid of them). Additionally, highlighting the menu item the mouse is currently over is rather intermittent, although the correct menu item appears to always - be chosen on mouse-click. + be chosen on mouse-click (related to the same tracking rectangle issue + mentioned in (5)?). + 16. Windows are put on screen very early in the realization process which wasn't a bad thing during early development (could see how far through things got before blowing up) but now it just looks messy. + 17. *BEAGLE-DEFAULT-FRAME-MANAGER* should be replaced with the standard *DEFAULT-FRAME-MANAGER* instead. -18. The back end doesn't clear up after itself very well. You might find it - necessary to force-quit OpenMCL after you've finished. 19. Menus don't work in CLIM-FIG (or anywhere else!). No idea why not... This is because (I think) the menu popups don't operate in a flipped - coord system (unlike NSViews). + coord system (unlike NSViews). [Command menu that is drawn across + top of window has 'child menus' drawn in bottom-left corner of screen) + TODO: make use of graft native transformation to flip coords rather - than the NSView 'isFlipped' method. + than the NSView 'isFlipped' method? + 20. Bounding rectangles are slightly off (this can be seen in CLIM-FIG again). It's only a matter of a pixel, maybe 2 in the worst case I've seen. @@ -228,10 +246,12 @@ int -> float conversion and ordinate manipulation (in cocoa 0.0, 0.0 falls 'between pixels' - 0.5, 0.5 is 'center of pixel'). + 21. Highlighting on mouse overs isn't quite right; artefacts are left on the display after the mouse has moved out of the target object bounding rectangle (most easily visible in CLIM-FIG again). + 22. Sending key-down / key-up events for modifiers-changed events doesn't look to help get the pointer documentation pane to show the correct prompt. For example, in the Listener, issue a 'help commands' and @@ -242,6 +262,7 @@ Presentation'. Need to check CLX implementation to see if this is the same... + 23. Large output histories: the transformations and geometry calculations go wrong when the output takes up more than 2^16 pixels; the medium should be used to account for this (it does in CLX) but for some @@ -250,6 +271,25 @@ but this will fail eventually (i.e. with a large enough output history), so it needs sorting properly. + +24. Testing + further work on patterns and stencils. + + +25. Bounding rects for commands entered in interactor panes are way out; + looks like the baseline of the text is being used as the bottom of + the bounding rect! + + +26. Minimising frames and then restoring them leads to the frame not + being drawn properly; it looks like 'drawRect' is invoked (as + expected), but nothing to tell McCLIM to redraw the whole frame. + Suspect a notification is sent... needs investigation. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +FIXED STUFF PREVIOUSLY ON THE KNOWN LIMITATIONS / TODO LIST + + -4.- Pixmap support is not implemented; this means clim-fig drawing doesn't work. This is getting there, although not very efficiently; we are missing a @@ -264,6 +304,20 @@ hacked for non-tiled patterns, not looked at for stencils). +-6.- Swapping between key windows (the window accepting the keyboard input) + is a little flakey; as an example, if a second Listener is started from + the first, clicking between the windows transfers key focus (as + expected). However, if the first is then 'Exit'ed, the second will not + get the key focus until some other (non-McCLIM) window has been given + the keyboard focus first (i.e. click on the OpenMCL Listener window, + then back on the McCLIM Listener window). + Additionally, clicking on a scroll-bar (for example) makes the window + key, so clicking on a view that accepts keyboard input (interactor) + within this window won't then allow keyboard input. + We should stop scroll-bars being able to get keyboard input... + FIXED 17.MAY.2005 DAR - the problem was we never invoked + 'setf (port-keyboard-input-focus' in handling + the 'did become key' notification. -10.- Text sizes aren't calculated correctly; when multiple lines are output together, the bottom of one line can be overwritten by the top of the @@ -277,12 +331,17 @@ Perhaps Cocoa thinks the dirty region includes that text or something. It's annoying whatever. Still, I'm going to mark this as fixed for now and maybe will come back to it later. + TODO: I think this is to do with the way width and height (rather than text-size) is used to calculate bounding rectangles might be wrong (i.e. getting the wrong information from Beagle). --11.- Line dash patterns haven't been implemented. + TODO: Also note that when a graph is output, there's no (significant) + problem with bounding rects etc. I suspect Beagle may be drawing + with y-align :bottom when CLIM is expecting :baseline, or + something. +-11.- Line dash patterns haven't been implemented. -13.- Some Apropos cases fail; for example 'Apropos graft' fails (although '(apropos 'graft)' does not). The same problem prevents the address @@ -291,13 +350,16 @@ this is happening, but it should be possible to track it down]. RESOLVED 21.AUG.2004 - it appears MACPTRs are output using the family (for a text style) of :fixed - which didn't exist (only :fix). Not - sure if this is a specification violation or not... + sure if this is a specification violation or not... both are bound + in McCLIM, so suspect :fixed is added for compatability with one of + the vendor CLIMs? -14.- Not all foreign objects we keep hold of in the back end are heap- allocated. Some are stack-allocated and cause errors about 'bogus' objects once they go out of scope. At least, I think (and hope) that's the reason 'cause that's easy to fix. RESOLVED 17.JUL.04 +-18.- Note about force-quit; appended to (5). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -315,16 +377,19 @@ 4. Look again at the build process and reintegrate with Bosco. -5. Possibly migrate to being a Carbon, rather then a Cocoa, application to - remove OpenMCL version dependencies. +-5.- Possibly migrate to being a Carbon, rather then a Cocoa, application to + remove OpenMCL version dependencies. *Don't bother doing this. Note that + in 10.4, Cocoa apps take advantage of GPU caching (performed by the OS), + but Carbon apps do not. It's possible in some future OS version that + Cocoa drawing will actually be faster than Carbon drawing.* -6. Reduce focus locking in NSViews (I think this will give a not +-6.- Reduce focus locking in NSViews (I think this will give a not insignificant speed increase). 7. Documentation 8. Code tidying, and lots of it! Refactoring. Need to implement many - abstractions (which should also help in the Cocoa -> Carbon move, + abstractions. (which should also help in the Cocoa -> Carbon move, when it happens). 9. Release resources on exit. @@ -335,7 +400,10 @@ particular. 12. Look again at sheet hierarchy stuff; I'm pretty sure this only works - when the graft is in the default orientation. + when the graft is in the default orientation. (There's lots of + problems in this area, most of which are in Beagle, some of which + are in McCLIM (by design? But not sure which are by design), e.g. + sheets being mirrored but with no medium attached). 13. I'd like to see the silica functionality in a separate package; I think (need to check!) that silica + back-end implementation should

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/port.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv19755/beagle/windowing Modified Files: port.lisp Log Message: Add auto release pool to function that creates the event loop to stop OS X barking all the time. Date: Tue May 17 19:56:20 2005 Author: drose Index: mcclim/Backends/beagle/windowing/port.lisp diff -u mcclim/Backends/beagle/windowing/port.lisp:1.2 mcclim/Backends/beagle/windowing/port.lisp:1.3 --- mcclim/Backends/beagle/windowing/port.lisp:1.2 Tue May 17 19:51:15 2005 +++ mcclim/Backends/beagle/windowing/port.lisp Tue May 17 19:56:20 2005 @@ -159,6 +159,7 @@ (setf (port-event-process port) (clim-sys:make-process (lambda () + (ccl::create-autorelease-pool) (loop (with-simple-restart (restart-event-loop "Restart CLIM's event loop.")

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/port.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv19635/beagle/windowing Modified Files: port.lisp Log Message: Apply Cyrus Harmon's changes to Beagle key handling posted on 08-MAR-2005. Not sure if these were never applied or if they have been clobbered since. Date: Tue May 17 19:51:15 2005 Author: drose Index: mcclim/Backends/beagle/windowing/port.lisp diff -u mcclim/Backends/beagle/windowing/port.lisp:1.1 mcclim/Backends/beagle/windowing/port.lisp:1.2 --- mcclim/Backends/beagle/windowing/port.lisp:1.1 Tue May 17 00:13:21 2005 +++ mcclim/Backends/beagle/windowing/port.lisp Tue May 17 19:51:15 2005 @@ -135,6 +135,8 @@ ;;; the port-server-path? Not sure...) to permit the user to make use of screens other ;;; than the main screen. (defmethod initialize-beagle ((port beagle-port)) + + (ccl::create-autorelease-pool) ;; CLX port gets some options here and uses those to set stuff up. We should probably do ;; this too, in the future ::FIXME::

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp
by drose＠common-lisp.net 17 May '05

17 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv19635/beagle/input Modified Files: events.lisp Log Message: Apply Cyrus Harmon's changes to Beagle key handling posted on 08-MAR-2005. Not sure if these were never applied or if they have been clobbered since. Date: Tue May 17 19:51:15 2005 Author: drose Index: mcclim/Backends/beagle/input/events.lisp diff -u mcclim/Backends/beagle/input/events.lisp:1.1 mcclim/Backends/beagle/input/events.lisp:1.2 --- mcclim/Backends/beagle/input/events.lisp:1.1 Tue May 17 00:13:16 2005 +++ mcclim/Backends/beagle/input/events.lisp Tue May 17 19:51:14 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.1 2005/05/16 22:13:16 drose Exp $ +$Id: events.lisp,v 1.2 2005/05/17 17:51:14 drose Exp $ All these are copied pretty much from CLX/port.lisp @@ -571,23 +571,24 @@ ;; We need to maintain the modifier flags state constantly to be able to ;; implement this; suggest a slot in beagle-port? (when (equal #$NSFlagsChanged event-type) - (format *debug-io* "In event-build (flags changed)~%") +;;; (format *debug-io* "In event-build (flags changed)~%") ;; Use the 'old' 'modifiers' in conjunction with the new 'modifier-state' ;; to work out if this is a key up or a key down... - (setf return-event (make-instance (if (current-mods-map-to-key-down (send event 'modifier-flags)) - 'key-press-event - 'key-release-event) - :key-name nil - :key-character nil - :x 0 - :y 0 - :graft-x 0 - :graft-y 0 - ;; Irrespective of where the key event happened, send it - ;; to the sheet that has key-focus for the port. - :sheet (beagle-port-key-focus *beagle-port*) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp)))) + (setf return-event + (destructuring-bind (event-class key) + (current-mods-map-to-key (send event 'modifier-flags)) + (make-instance event-class + :key-name key + :key-character nil + :x 0 + :y 0 + :graft-x 0 + :graft-y 0 + ;; Irrespective of where the key event happened, send it + ;; to the sheet that has key-focus for the port. + :sheet (beagle-port-key-focus *beagle-port*) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp))))) ;; #$NSHelpRequested- wonder if we can convert this into "user pressed help key" key event? ;; Then could pull up docs (or could do if there were any!) @@ -630,7 +631,7 @@ ;;; This is really, really horribly written. Hopefully it will just be ;;; temporary until everything is 'band-aided' (!?) at which point we'll ;;; look to migrate to Carbon and reimplement a lot of this stuff. -(defun current-mods-map-to-key-down (current-modifier-state) +(defun current-mods-map-to-key (current-modifier-state) (declare (special *-current-event-modifier-state-*)) ;; Are there modifiers in 'current-modifier-state' that don't exist in ;; *-current-event-modifier-state-* (key down) or vice versa (key up)? @@ -643,38 +644,38 @@ ;;#$NSAlternateKeyMask +super-key+ ;;#$NSAlphaShiftKeyMask +hyper-key+ (cond ((null *-current-event-modifier-state-*) - t) + '(key-release-event nil)) ((and (> (logand *-current-event-modifier-state-* +shift-key+) 0) (= (logand current-modifier-state #$NSShiftKeyMask) 0)) - nil) + '(key-release-event :shift)) ((and (= (logand *-current-event-modifier-state-* +shift-key+) 0) (> (logand current-modifier-state #$NSShiftKeyMask) 0)) - t) + '(key-press-event :shift)) ((and (> (logand *-current-event-modifier-state-* +control-key+) 0) (= (logand current-modifier-state #$NSControlKeyMask) 0)) - nil) + '(key-release-event :control)) ((and (= (logand *-current-event-modifier-state-* +control-key+) 0) (> (logand current-modifier-state #$NSControlKeyMask) 0)) - t) + '(key-press-event :control)) ((and (> (logand *-current-event-modifier-state-* +meta-key+) 0) (= (logand current-modifier-state #$NSCommandKeyMask) 0)) - nil) + '(key-release-event :meta)) ((and (= (logand *-current-event-modifier-state-* +meta-key+) 0) (> (logand current-modifier-state #$NSCommandKeyMask) 0)) - t) + '(key-press-event :meta)) ((and (> (logand *-current-event-modifier-state-* +super-key+) 0) (= (logand current-modifier-state #$NSAlternateKeyMask) 0)) - nil) + '(key-release-event :super)) ((and (= (logand *-current-event-modifier-state-* +super-key+) 0) (> (logand current-modifier-state #$NSAlternateKeyMask) 0)) - t) + '(key-press-event :super)) ((and (> (logand *-current-event-modifier-state-* +hyper-key+) 0) (= (logand current-modifier-state #$NSAlphaShiftKeyMask) 0)) - nil) + '(key-release-event :hyper)) ((and (= (logand *-current-event-modifier-state-* +hyper-key+) 0) (> (logand current-modifier-state #$NSAlphaShiftKeyMask) 0)) - t) - (t nil))) + '(key-press-event :hyper)) + (t '(key-release-event)))) ;; Need to make use of the Cocoa method for getting modifier state - this is independent of events @@ -764,21 +765,29 @@ (let ((key-name (lookup-keysym (send ns-string-characters-in :character-at-index 0)))) ;; If key-name is nil after all that, see if we can look up a mapping from those supported in ;; Cocoa... -;;; (when (null key-name) -;;; (setf key-name (get-key-name-from-cocoa-constants ns-string-characters-in))) -;;; (format *terminal-io* "Got key-name of: ~A~%" key-name) - key-name)))) + (cond + ((null key-name) + (let ((clim-key + (get-key-name-from-cocoa-constants + (send ns-string-characters-in :character-at-index 0)))) + clim-key)) + (t key-name)))))) ;;; From CLX/keysyms.lisp (defun numeric-keysym-to-character (keysym) - (and (<= 0 keysym 255) - (code-char keysym))) + (cond + ((= #x1b keysym) + (get-key-name-from-cocoa-constants keysym)) + ((and (<= 0 keysym 255)) + (code-char keysym)) + (t nil))) (defun keysym-to-character (keysym) (numeric-keysym-to-character (reverse-lookup-keysym keysym))) -(defconstant *beagle-key-constants* '(#$NSUpArrowFunctionKey :UP +(defconstant *beagle-key-constants* (list + #$NSUpArrowFunctionKey :UP #$NSDownArrowFunctionKey :DOWN #$NSLeftArrowFunctionKey :LEFT #$NSRightArrowFunctionKey :RIGHT @@ -849,10 +858,33 @@ #$NSRedoFunctionKey :REDO #$NSFindFunctionKey :FIND #$NSHelpFunctionKey :HELP - #$NSModeSwitchFunctionKey :MODE-SWITCH)) + #$NSModeSwitchFunctionKey :MODE-SWITCH + #x1b :ESCAPE)) ;;;(defun get-key-name-from-cocoa-constants (ns-in) ;;; (loop for target, key in *cocoa-key-constants* ;;; (do ;;; (when (send target :is-equal-to-string ns-in) ;;; key)))) + +(defvar *beagle-key-hash-table* + (make-hash-table :test #'eql)) + +(defvar *reverse-beagle-key-hash-table* + (make-hash-table :test #'eq)) + +(defun define-beagle-key (ns-key clim-key) + (pushnew clim-key (gethash ns-key *beagle-key-hash-table*)) + (setf (gethash clim-key *reverse-beagle-key-hash-table*) ns-key)) + +(defun lookup-beagle-key (ns-key) + (car (last (gethash ns-key *beagle-key-hash-table*)))) + +(defun reverse-lookup-beagle-key (clim-key) + (gethash clim-key *reverse-beagle-key-hash-table*)) + +(loop for key-binding on *beagle-key-constants* by #'cddr + do (define-beagle-key (car key-binding) (cadr key-binding))) + +(defun get-key-name-from-cocoa-constants (ns-in) + (lookup-beagle-key ns-in))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/frame-manager.lisp mcclim/Backends/beagle/windowing/graft.lisp mcclim/Backends/beagle/windowing/mirror.lisp mcclim/Backends/beagle/windowing/port.lisp
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv13235/beagle/windowing Added Files: frame-manager.lisp graft.lisp mirror.lisp port.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:21 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/tests/drawing-tests.lisp mcclim/Backends/beagle/tests/graft-tests.lisp mcclim/Backends/beagle/tests/hello.lisp
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/tests In directory common-lisp.net:/tmp/cvs-serv13235/beagle/tests Added Files: drawing-tests.lisp graft-tests.lisp hello.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:20 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/profile/README mcclim/Backends/beagle/profile/profile.lisp
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/profile In directory common-lisp.net:/tmp/cvs-serv13235/beagle/profile Added Files: README profile.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:20 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/output/fonts.lisp mcclim/Backends/beagle/output/medium.lisp
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv13235/beagle/output Added Files: fonts.lisp medium.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:19 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/native/lisp-bezier-path.lisp mcclim/Backends/beagle/native/lisp-image.lisp mcclim/Backends/beagle/native/lisp-unmanaged-view.lisp mcclim/Backends/beagle/native/lisp-view-additional.lisp mcclim/Backends/beagle/native/lisp-view.lisp mcclim/Backends/beagle/native/lisp-window-delegate.lisp mcclim/Backends/beagle/native/lisp-window.lisp
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory common-lisp.net:/tmp/cvs-serv13235/beagle/native Added Files: lisp-bezier-path.lisp lisp-image.lisp lisp-unmanaged-view.lisp lisp-view-additional.lisp lisp-view.lisp lisp-window-delegate.lisp lisp-window.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:17 2005 Author: drose

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp mcclim/Backends/beagle/input/keysymdef.lisp
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv13235/beagle/input Added Files: events.lisp keysymdef.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:16 2005 Author: drose

1 0

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/glimpse In directory common-lisp.net:/tmp/cvs-serv13235/beagle/glimpse Added Files: README glimpse-command-tables.lisp glimpse-modeless-commands.lisp glimpse-present-process.lisp glimpse-present-window.lisp glimpse-process-commands.lisp glimpse-support.lisp glimpse-window-commands.lisp glimpse.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:14 2005 Author: drose

1 0

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv13235/beagle Modified Files: README.txt beagle-backend.asd load-beagle.lisp load-clim.lisp package.lisp Removed Files: events.lisp fonts.lisp frame-manager.lisp graft.lisp image.lisp keysymdef.lisp lisp-image.lisp lisp-unmanaged-view.lisp lisp-view-additional.lisp lisp-view.lisp lisp-window-delegate.lisp lisp-window.lisp medium.lisp mirror.lisp port.lisp Log Message: Restructured beagle code. Added support for patterns (tiled works, untiled is a hack, stencils untested (probably don't work)), some speedups (each medium caches an NSBezierPath now with which to draw), scrolling largish output histories is improved (only redraw mirror region rather than whole sheet). Tried to squash a few bugs, largely without success but one or two have succumbed. Added Glimpse, which is a weak window inspector and even weaker Peek application but it's largely unfinished at the moment. Date: Tue May 17 00:13:09 2005 Author: drose Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.7 mcclim/Backends/beagle/README.txt:1.8 --- mcclim/Backends/beagle/README.txt:1.7 Sun Mar 6 19:57:20 2005 +++ mcclim/Backends/beagle/README.txt Tue May 17 00:13:08 2005 @@ -48,13 +48,12 @@ 1. Install McCLIM according to INSTALL.ASDF in the McCLIM root directory. 2. Start OpenMCL -3. Evaluate '(require "COCOA")' +3. Evaluate '(require :cocoa)' The following are evaluated from the 'OpenMCL Listener' that opens: -4. Evaluate '(require "ASDF")' -5. Evaluate '(asdf:oos 'asdf:load-op :clim-beagle)' -6. Evaluate '(asdf:oos 'asdf:load-op :mcclim)' [See note #3] +4. Evaluate '(asdf:oos 'asdf:load-op :clim-beagle)' +5. Evaluate '(asdf:oos 'asdf:load-op :mcclim)' [See note #3] The McCLIM Listener should now be able to be started from the OpenMCL Listener by evaluating '(clim-listener:run-listener)'. See the McCLIM @@ -77,30 +76,15 @@ loop. Note #3: If you'd rather run with the CLX back end, load CLX - instead here. Hopefully it will (soon?) be possible to run - with multiple ports simultaneously so that both a CLX and a - Beagle Listener can be run side by side for comparative - purposes. + instead here. It is possible to with multiple ports simultaneously + so that both a CLX and a Beagle Listener can be run side by side + for comparative purposes (or just because the Listener is actually + usable for something useful when running under CLX). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% CONFIGURATION -debug: ------- -Most debug output within the Beagle back end uses a specialized debug -logging method so it can be dynamically turned on and off. If for any -reason you want to observe log messages, set the following parameter to a -non-zero integer (the higher the integer, the more detail there is to the -logging. No logging is higher than 4 at the moment though I don't think). - -CL-USER:*DEBUG-LOG-LEVEL* <defined in 'package.lisp'> - -> numeric [0 by default] - -See also TODO item 12. In general I need to go through all the debug -messages and sort them out. - - default frame manager: ---------------------- The Beagle back end defines two frame manager objects; one is the aqua @@ -114,7 +98,7 @@ Should use CLIM:*DEFAULT-FRAME-MANAGER* for this! Note that as yet, no native (aqua) look and feel panes have been defined, -so it doesn't matter which one you use. +so it doesn't matter which frame manager you use. multiple ports: --------------- @@ -141,31 +125,16 @@ then run the other listener from the OpenMCL Listener. Other variations probably work too, but I haven't experimented too much. -(7) isn't necessary, since the CLX port appears in the server-path -search order before the Beagle port does. - - -listener: ---------- -If you want to run the Listener in this back end as it currently stands, you -need to make the following modifications to -'Apps/Listener/dev-commands.lisp' (or put up with broken directory display):- - -1. Modify 'pretty-pretty-pathname', removing: - - (let ((icon (icon-of pathname))) - (when icon (draw-icon stream icon :extra-spacing 3))) -2. Modify 'com-show-directory', removing: - - (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) +(7) isn't actually necessary, since the CLX port appears in the server- +path search order before the Beagle port does. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% KNOWN LIMITATIONS / TODO LIST 1. Speed! The current implementation is __slow__, especially when there is a - large output history. Paolo's speed test takes 26 seconds and conses + large output history. Paolo's stress test takes 26 seconds and conses 16MB on my (admittedly slow) iMac compared to 1.5 seconds on a 2.4GHz Pentium IV and unknown (to me) consing. Should be able to speed things up by performing fewer focus lock / unlocks, @@ -173,6 +142,20 @@ far this will get us though... UPDATE - 21.AUG.2004 - performing fewer NSWindow flushes makes no difference to speed. + UPDATE - 25.APR.2005 - When the mirror transformation is set (sheet is + scrolling) we dispatch a repaint on the 'untransformed + mirror region' (using the mirror transformation as the 'untransformation') + instead of on the whole sheet. Things seem to behave better (i.e. quicker) now. + This HASN'T made '(time (clim-listener::com-show-class-subclasses t))' execute + any faster though (or cons less). We're doing way too much work drawing stuff + I think, and because we get CLIM to redraw the regions (linear search through + output history?) it's not too fast. Suspect in CLX when the sheet is scrolled, + no redraw happens from CLIM generally. Also, Cocoa appears to get really slow + at rendering text when the output history gets too large (maybe this is CLIM + again, it's hard to know). Need to profile. + TODO: cache lisp-bezier-path instances and reuse them. Use approximation for + text sizing (there's as much overhead working out how big rendered text + would be as there is to rendering the text itself, or almost). 2. When running the Listener (and probably other applications), the resize handle is not visible; it's there, but you can't see it. Grab and drag @@ -181,9 +164,6 @@ 3. There are not yet any aqua look and feel panes. Sorry, I'm trying to get everything else working first! -4.5. Designs (other than colours) aren't implemented - THIS means there are - no icons in the Listener. - 5. Mouse down / up on buttons appears not to work very well unless the frame containing the buttons is the only active frame. Actually, this ^^^ seems to work fine, but the highlighting for button @@ -198,7 +178,7 @@ then back on the McCLIM Listener window). Additionally, clicking on a scroll-bar (for example) makes the window key, so clicking on a view that accepts keyboard input (interactor) - won't then allow keyboard input. + within this window won't then allow keyboard input. We should stop scroll-bars being able to get keyboard input... 7. Keyboard events are not handled "properly" as far as any OS X user will @@ -216,8 +196,6 @@ pool) but when running in a separate thread lots of warning messages are generated. -11. Line dash patterns haven't been implemented. - 12. There's probably some debug output remaining in some corner cases. 15. Popup menus don't work quite the same way as they do in the CLX back @@ -238,9 +216,11 @@ 18. The back end doesn't clear up after itself very well. You might find it necessary to force-quit OpenMCL after you've finished. -19. Menus don't work in CLIM-FIG (or any else!). No idea why not... - This is because the way pointer tracking is done in clim-internals has - been changed, so another work-around needs to be implemented. +19. Menus don't work in CLIM-FIG (or anywhere else!). No idea why not... + This is because (I think) the menu popups don't operate in a flipped + coord system (unlike NSViews). + TODO: make use of graft native transformation to flip coords rather + than the NSView 'isFlipped' method. 20. Bounding rectangles are slightly off (this can be seen in CLIM-FIG again). It's only a matter of a pixel, maybe 2 in the worst case I've seen. @@ -262,6 +242,14 @@ Presentation'. Need to check CLX implementation to see if this is the same... +23. Large output histories: the transformations and geometry calculations + go wrong when the output takes up more than 2^16 pixels; the medium + should be used to account for this (it does in CLX) but for some + reason it isn't. Can work around by changing every #x8000 in + UPDATE-MIRROR-GEOMETRY (see sheets.lisp in core) to #x800000 (or larger) + but this will fail eventually (i.e. with a large enough output + history), so it needs sorting properly. + -4.- Pixmap support is not implemented; this means clim-fig drawing doesn't work. This is getting there, although not very efficiently; we are missing a @@ -270,6 +258,13 @@ RESOLVED 08.AUG.04 [NB. this functionality is not too efficient I think and needs revisiting (like everything else does)] +-4.5.- Designs (other than colours) aren't implemented - THIS means there are + no icons in the Listener. + UPDATE 25.APR.2005 - This is done now, more or less (done for tiled patterns, + hacked for non-tiled patterns, not looked at for + stencils). + + -10.- Text sizes aren't calculated correctly; when multiple lines are output together, the bottom of one line can be overwritten by the top of the next line. @@ -282,6 +277,12 @@ Perhaps Cocoa thinks the dirty region includes that text or something. It's annoying whatever. Still, I'm going to mark this as fixed for now and maybe will come back to it later. + TODO: I think this is to do with the way width and height (rather than + text-size) is used to calculate bounding rectangles might be + wrong (i.e. getting the wrong information from Beagle). + +-11.- Line dash patterns haven't been implemented. + -13.- Some Apropos cases fail; for example 'Apropos graft' fails (although '(apropos 'graft)' does not). The same problem prevents the address @@ -303,8 +304,8 @@ WISH LIST 1. Bring Beagle back end into line with CLX back end in terms of supported - McCLIM functionality (basically - -pixmap-support-,- flipping ink and line - dashes) + McCLIM functionality (basically - -pixmap-support-, flipping ink and -line + dashes-) 2. Implement native look and feel Index: mcclim/Backends/beagle/beagle-backend.asd diff -u mcclim/Backends/beagle/beagle-backend.asd:1.1 mcclim/Backends/beagle/beagle-backend.asd:1.2 --- mcclim/Backends/beagle/beagle-backend.asd:1.1 Sun Aug 8 18:20:44 2004 +++ mcclim/Backends/beagle/beagle-backend.asd Tue May 17 00:13:08 2005 @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; -*- -;; $Id: beagle-backend.asd,v 1.1 2004/08/08 16:20:44 duncan Exp $ +;; $Id: beagle-backend.asd,v 1.2 2005/05/16 22:13:08 drose Exp $ (defpackage "BEAGLE" (:use "CLIM" "CLIM-LISP") @@ -24,7 +24,7 @@ #:port-disable-sheet #:port-motion-hints #:port-force-output - #:set-port-keyboard-focus + #:%set-port-keyboard-focus #:set-sheet-pointer-cursor ;; #:port-set-mirror-region @@ -89,22 +89,56 @@ :version "0.1" :serial t :components ((:file "package") - (:file "lisp-window") - (:file "lisp-window-delegate") - (:file "lisp-view") - (:file "lisp-view-additional") - (:file "lisp-image") - (:file "lisp-unmanaged-view") + (:module "Native" + :pathname #.(make-pathname :directory '(:relative "native")) + :components + ((:file "lisp-bezier-path") + (:file "lisp-window") + (:file "lisp-window-delegate") + (:file "lisp-view" :depends-on ("lisp-bezier-path")) + (:file "lisp-view-additional" :depends-on ("lisp-view")) + (:file "lisp-image") + (:file "lisp-unmanaged-view"))) (:file "cocoa-util") - (:file "port") - (:file "frame-manager") - (:file "medium") - (:file "mirror") - (:file "events") - (:file "graft") - (:file "fonts") - (:file "image") -;;; (:file "clim-extensions") - (:file "keysymdef") + (:module "Windowing" + :depends-on ("Native") + :pathname #.(make-pathname :directory '(:relative "windowing")) + :components + ((:file "port") + (:file "frame-manager") + (:file "mirror") + (:file "graft"))) + (:module "Output" + :depends-on ("Windowing") + :pathname #.(make-pathname :directory '(:relative "output")) + :components + ((:file "medium") + (:file "fonts"))) + (:module "Input" + :depends-on ("Windowing") + :pathname #.(make-pathname :directory '(:relative "input")) + :components + ((:file "events") + (:file "keysymdef"))) + (:module "Glimpse" + :pathname #.(make-pathname :directory '(:relative "glimpse")) + :components + ((:file "glimpse") + (:file "glimpse-support") + (:file "glimpse-command-tables") + (:file "glimpse-present-process" :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-present-window" :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-modeless-commands" :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-process-commands" :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-window-commands" :depends-on ("glimpse" "glimpse-support")))) + (:module "Profile" + :pathname #.(make-pathname :directory '(:relative "profile")) + :components + ((:file "profile"))) + (:module "Tests" + :pathname #.(make-pathname :directory '(:relative "tests")) + :components + ((:file "drawing-tests") + (:file "graft-tests"))) )) Index: mcclim/Backends/beagle/load-beagle.lisp diff -u mcclim/Backends/beagle/load-beagle.lisp:1.1 mcclim/Backends/beagle/load-beagle.lisp:1.2 --- mcclim/Backends/beagle/load-beagle.lisp:1.1 Sat Aug 21 17:02:36 2004 +++ mcclim/Backends/beagle/load-beagle.lisp Tue May 17 00:13:08 2005 @@ -1,7 +1,7 @@ (format t "Ensure you have issued the commands: (require \"cocoa\") and (require \"asdf\")...~%") (format t "~%Loading Beagle~%") ;;;(load "/Users/duncan/sandbox/evins/McCLIM/Backends/Cocoa/src/cocoa-backend.asd") -(load "/Users/duncan/sandbox/mikemac/McCLIM/Backends/beagle/beagle-backend.asd") +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/Backends/beagle/beagle-backend.asd") (asdf:operate 'asdf:load-op 'beagle) ;;; Use this to specify the frame manager you want to use by default (note: if you ;;; want 'beagle::beagle-aqua-frame-manager, you don't need to set this since that Index: mcclim/Backends/beagle/load-clim.lisp diff -u mcclim/Backends/beagle/load-clim.lisp:1.2 mcclim/Backends/beagle/load-clim.lisp:1.3 --- mcclim/Backends/beagle/load-clim.lisp:1.2 Sat Aug 21 17:02:36 2004 +++ mcclim/Backends/beagle/load-clim.lisp Tue May 17 00:13:08 2005 @@ -1,10 +1,10 @@ (format t "Ensure you have issued the command: (require \"asdf\")...~%") (format t "~%Loading McCLIM~%") ;;;(load "/Users/duncan/sandbox/evins/McCLIM/system") -(load "/Users/duncan/sandbox/mikemac/McCLIM/system") +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/system") (asdf:operate 'asdf:load-op 'clim) (asdf:operate 'asdf:load-op 'clim-examples) -;;;(load "/Users/duncan/sandbox/evins/McCLIM/Apps/Listener/clim-listener.asd") -(load "/Users/duncan/sandbox/mikemac/McCLIM/Apps/Listener/clim-listener.asd") (asdf:operate 'asdf:load-op 'clim-listener) +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/Apps/Inspector/clouseau.asd") +(asdf:operate 'asdf:load-op 'clouseau) (format t "~%Done.~%") Index: mcclim/Backends/beagle/package.lisp diff -u mcclim/Backends/beagle/package.lisp:1.2 mcclim/Backends/beagle/package.lisp:1.3 --- mcclim/Backends/beagle/package.lisp:1.2 Fri Mar 4 08:54:42 2005 +++ mcclim/Backends/beagle/package.lisp Tue May 17 00:13:09 2005 @@ -11,19 +11,10 @@ (#_NSLog #@"Logging: %@" :address nsstr))))) ;;; END -;;; START - Cribbed from lib/utils.lisp -(in-package :cl-user) -(defparameter *debug-log-level* 0) -(defun debug-log (level control-string &rest args) - (declare (special *debug-log-level*)) - (when (>= *debug-log-level* level) - (apply #'format *debug-io* control-string args))) -;;; END - (in-package :common-lisp-user) (defpackage :beagle - (:use :clim :clim-lisp) + (:use :clim :clim-lisp :clim-backend) (:import-from :climi #:+alt-key+ ;; @@ -102,9 +93,9 @@ ;; #:synthesize-pointer-motion-event ;; + #:vrack-pane + #:hrack-pane ) - (:import-from :cl-user - #:debug-log) (:import-from :ccl #:@class #:define-objc-method

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/profile
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/profile In directory common-lisp.net:/tmp/cvs-serv12002/profile Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/profile added to the repository Date: Mon May 16 23:58:30 2005 Author: drose New directory mcclim/Backends/beagle/profile added

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/windowing
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv11983/windowing Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing added to the repository Date: Mon May 16 23:57:38 2005 Author: drose New directory mcclim/Backends/beagle/windowing added

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/tests
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/tests In directory common-lisp.net:/tmp/cvs-serv11963/tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/tests added to the repository Date: Mon May 16 23:56:17 2005 Author: drose New directory mcclim/Backends/beagle/tests added

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/output
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory common-lisp.net:/tmp/cvs-serv11945/output Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/output added to the repository Date: Mon May 16 23:55:24 2005 Author: drose New directory mcclim/Backends/beagle/output added

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/native
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory common-lisp.net:/tmp/cvs-serv11922/native Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/native added to the repository Date: Mon May 16 23:54:31 2005 Author: drose New directory mcclim/Backends/beagle/native added

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/input
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv11898/input Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/input added to the repository Date: Mon May 16 23:53:00 2005 Author: drose New directory mcclim/Backends/beagle/input added

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Backends/beagle/glimpse
by drose＠common-lisp.net 16 May '05

16 May '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/glimpse In directory common-lisp.net:/tmp/cvs-serv11855/glimpse Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/beagle/glimpse added to the repository Date: Mon May 16 23:51:19 2005 Author: drose New directory mcclim/Backends/beagle/glimpse added

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by ahefner＠common-lisp.net 13 May '05

13 May '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv5889 Modified Files: graph-formatting.lisp Log Message: Applied Robert P. Goldman's graph formatting patch. Date: Fri May 13 05:00:25 2005 Author: ahefner Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.14 mcclim/graph-formatting.lisp:1.15 --- mcclim/graph-formatting.lisp:1.14 Sat Apr 23 22:02:01 2005 +++ mcclim/graph-formatting.lisp Fri May 13 05:00:25 2005 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.14 2005/04/23 20:02:01 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.15 2005/05/13 03:00:25 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -312,7 +312,7 @@ (walk (node depth) (unless (graph-node-minor-size node) (when (>= depth (length generation-sizes)) - (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2))))) + (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) :initial-element 0))) (setf (aref generation-sizes depth) (max (aref generation-sizes depth) (node-major-dimension node))) (setf (graph-node-minor-size node) 0)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/TODO mcclim/Apps/Listener/README
by ahefner＠common-lisp.net 12 May '05

12 May '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv25966 Modified Files: TODO README Log Message: Update README with correct installation instructions (system definition is now defined elsewhere). Random changes to README and TODO. Date: Thu May 12 03:37:21 2005 Author: ahefner Index: mcclim/Apps/Listener/TODO diff -u mcclim/Apps/Listener/TODO:1.1 mcclim/Apps/Listener/TODO:1.2 --- mcclim/Apps/Listener/TODO:1.1 Tue Nov 11 07:18:50 2003 +++ mcclim/Apps/Listener/TODO Thu May 12 03:37:20 2005 @@ -3,7 +3,6 @@ for its intended purpose: McCLIM TODO: - - Editor history - Implement more of the emacs editing keys - Completion of pathnames and symbols - Subform accepting in places other than OpenMCL Index: mcclim/Apps/Listener/README diff -u mcclim/Apps/Listener/README:1.4 mcclim/Apps/Listener/README:1.5 --- mcclim/Apps/Listener/README:1.4 Mon Oct 18 08:30:37 2004 +++ mcclim/Apps/Listener/README Thu May 12 03:37:20 2005 @@ -5,7 +5,7 @@ -------- The McCLIM Listener provides an interactive toplevel with full access to the -graphical capabilities of CLIM, and a set of built-in commands intended to be +graphical capabilities of CLIM and a set of built-in commands intended to be useful for lisp development and experimentation. Present features include: - Reading/evaluation of lisp expressions @@ -19,17 +19,15 @@ Installation ------------ -The Listener uses ASDF for system definition. You must have ASDF loaded to build -the listener (or else compile the files manually), but need not have compiled -McCLIM using it. See http://www.cliki.net/asdf for information on ASDF. +The clim-listener system is defined both by McCLIM's central system.lisp and +the ASDF-ized version in mcclim.asd. It can be loaded in the same manner as +the rest of McCLIM. -Provided you have McCLIM and ASDF loaded into your lisp, compiling the listener -is straightforward. Assuming you are in the McCLIM directory: +For ASDF users, the following should work: - * (load "Apps/Listener/clim-listener.asd") * (asdf:operate 'asdf:load-op :clim-listener) -To run the listener: +Once loaded, you can run the listener using: * (clim-listener:run-listener) If you have a multithreaded lisp, you can start the listener in a separate @@ -40,20 +38,18 @@ Compatibility ------------- -The Listener is developed primarily on CMUCL 18e, and tested periodically on SBCL -and possibly OpenMCL. On SBCL, the SB-POSIX package is used for filesystem -access, so you will need a fairly recent version of SBCL (minimum 0.8.2.44). - -Due to variation in how implementations treat pathnames as well as nonstandard -things like access to the MOP and the need to run programs, examine environment -variables, etc, a little work is required to get everything running smoothly on -a new CL. Most of this should be done for LispWorks. Allegro CL is untested and -will need some hacking. +The Listener is developed using CMUCL 18e and recent versions of SBCL. It is +known to work well on these platforms. It has also been reported to work on +OpenMCL, Lispworks, and clisp. It has not been tested on ACL and will +require a small amount of work due to the number of implementation-specific +features used (MOP, pathnames, run-program, environment variables, etc). + + Usage ----- -After starting the listener, a fairly normal lisp prompt will be displayed, with +After starting the listener, a typical lisp prompt will be displayed, with the package name preceding the prompt. You may type lisp forms or commands to this prompt. The listener will treat alphabetical characters as beginning a command name, and most other characters as the beginning of a lisp form. If for @@ -132,13 +128,14 @@ the DIRECTORY function of various CL environments) My apologies to anyone doing something more useful with this macro character -which I have stepped on. +if I have clobbered your readtable. + Calling Commands from Lisp -------------------------- -Calling CLIM commands from lisp is straightforward. By convention, the "pretty" +Calling CLIM commands from lisp is straightforward. By convention, the pretty names used at the interactor map to a function name which implements the command body by upcasing the name, replacing spaces with hyphens, and prepending "COM-" (e.g., Show Directory becomes COM-SHOW-DIRECTORY).

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/clim-listener.asd
by ahefner＠common-lisp.net 12 May '05

12 May '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv25036 Removed Files: clim-listener.asd Log Message: Removing deprecated file. Date: Thu May 12 03:19:36 2005 Author: ahefner

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by gbaumann＠common-lisp.net 08 May '05

08 May '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv11427 Modified Files: incremental-redisplay.lisp Log Message: incremental redisplay changes, part ii: If in UPDATING-OUTPUT the cache test passes but the y cursor coordinate changed, instead of calling the display function again we just move the record on our own. Date: Sun May 8 20:15:44 2005 Author: gbaumann Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.47 mcclim/incremental-redisplay.lisp:1.48 --- mcclim/incremental-redisplay.lisp:1.47 Sun May 8 20:09:11 2005 +++ mcclim/incremental-redisplay.lisp Sun May 8 20:15:44 2005 @@ -349,10 +349,10 @@ ;;;programmer forcing all new output. (defun state-matches-stream-p (state stream) - (multiple-value-bind (cx cy) - (stream-cursor-position stream) + (multiple-value-bind (cx cy) (stream-cursor-position stream) (with-sheet-medium (medium stream) - (match-output-records state :cursor-x cx :cursor-y cy)))) + ;; Note: We don't match the y coordinate. + (match-output-records state :cursor-x cx)))) (define-protocol-class updating-output-record (output-record)) @@ -825,6 +825,17 @@ (defvar *no-unique-id* (cons nil nil)) +(defun move-output-record (record dx dy) + (multiple-value-bind (sx sy) (output-record-start-cursor-position record) + (multiple-value-bind (ex ey) (output-record-end-cursor-position record) + (setf (output-record-position record) + (values (+ (nth-value 0 (output-record-position record)) dx) + (+ (nth-value 1 (output-record-position record)) dy))) + (setf (output-record-start-cursor-position record) + (values (+ sx dx) (+ sy dy))) + (setf (output-record-end-cursor-position record) + (values (+ ex dx) (+ ey dy)))))) + (defmethod invoke-updating-output ((stream updating-output-stream-mixin) continuation record-type @@ -864,16 +875,10 @@ (setf (end-graphics-state record) (medium-graphics-state stream)) (add-to-map parent-cache record unique-id id-test all-new))) - ((or (setq state-mismatch - (not (state-matches-stream-p (start-graphics-state - record) - stream))) - (not (funcall cache-test - cache-value - (output-record-cache-value record)))) + ((or (setq state-mismatch (not (state-matches-stream-p (start-graphics-state record) stream))) + (not (funcall cache-test cache-value (output-record-cache-value record)))) (when *trace-updating-output* - (format *trace-output* "~:[cache test~;stream state~] ~S~%" - state-mismatch record)) + (format *trace-output* "~:[cache test~;stream state~] ~S~%" state-mismatch record)) (let ((*current-updating-output* record)) (setf (start-graphics-state record) (medium-graphics-state stream)) @@ -887,16 +892,29 @@ ;; parent's sequence of records (when *trace-updating-output* (format *trace-output* "clean ~S~%" record)) - (setf (output-record-dirty record) :clean) - (setf (output-record-parent record) nil) - (map-over-updating-output #'(lambda (r) - (setf (output-record-dirty r) - :clean)) - record - nil) - (add-output-record record (stream-current-output-record stream)) - (set-medium-graphics-state (end-graphics-state record) stream) - (setf (parent-cache record) parent-cache))) + ;; + (multiple-value-bind (cx cy) (stream-cursor-position stream) + (multiple-value-bind (sx sy) (output-record-start-cursor-position record) + (let ((dx (- cx sx)) + (dy (- cy sy))) + (unless (zerop dy) + (move-output-record record dx dy) ) + (let ((tag (cond ((= dx dy 0) :clean) + (t :moved)))) + (setf (output-record-dirty record) tag) + (setf (output-record-parent record) nil) + (map-over-updating-output #'(lambda (r) + (unless (eq r record) + (incf (slot-value (start-graphics-state r) 'cursor-x) dx) + (incf (slot-value (start-graphics-state r) 'cursor-y) dy) + (incf (slot-value (end-graphics-state r) 'cursor-x) dx) + (incf (slot-value (end-graphics-state r) 'cursor-y) dy)) + (setf (output-record-dirty r) tag)) + record + nil) + (add-output-record record (stream-current-output-record stream)) + (set-medium-graphics-state (end-graphics-state record) stream) + (setf (parent-cache record) parent-cache) )) )))) record))) ;;; The Franz user guide says that updating-output does

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by gbaumann＠common-lisp.net 08 May '05

08 May '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10559 Modified Files: incremental-redisplay.lisp Log Message: Incremental redisplay changes, part i: checking for overlap. Date: Sun May 8 20:09:11 2005 Author: gbaumann Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.46 mcclim/incremental-redisplay.lisp:1.47 --- mcclim/incremental-redisplay.lisp:1.46 Tue Mar 8 11:46:16 2005 +++ mcclim/incremental-redisplay.lisp Sun May 8 20:09:11 2005 @@ -280,36 +280,33 @@ (defgeneric incremental-redisplay (stream position erases moves draws erase-overlapping move-overlapping)) -(defmethod incremental-redisplay - ((stream updating-output-stream-mixin) position - erases moves draws erase-overlapping move-overlapping) +(defmethod incremental-redisplay ((stream updating-output-stream-mixin) position + erases moves draws erase-overlapping move-overlapping) (declare (ignore position)) (let ((history (stream-output-history stream))) (with-output-recording-options (stream :record nil :draw t) (loop - for (nil br) in erases - do (erase-rectangle stream br)) + for (nil br) in erases + do (erase-rectangle stream br)) (loop - for (nil old-bounding) in moves - do (erase-rectangle stream old-bounding)) + for (nil old-bounding) in moves + do (erase-rectangle stream old-bounding)) (loop - for (nil br) in erase-overlapping - do (erase-rectangle stream br)) + for (nil br) in erase-overlapping + do (erase-rectangle stream br)) (loop - for (nil old-bounding) in move-overlapping - do (erase-rectangle stream old-bounding))) + for (nil old-bounding) in move-overlapping + do (erase-rectangle stream old-bounding))) (loop - for (r) in moves - do (replay r stream)) + for (r) in moves + do (replay r stream)) (loop - for (r) in draws - do (replay r stream)) - (loop - for (r) in erase-overlapping - do (replay history stream r)) - (loop - for (r) in move-overlapping - do (replay history stream r) ))) + for (r) in draws + do (replay r stream)) + (let ((res +nowhere+)) + (loop for (r) in erase-overlapping do (setf res (region-union res r))) + (loop for (r) in move-overlapping do (setf res (region-union res r))) + (replay history stream res)) )) (defclass updating-stream-state (complete-medium-state) ((cursor-x :accessor cursor-x :initarg :cursor-x :initform 0) @@ -713,141 +710,113 @@ ;;; work in progress (defvar *existing-output-records* nil) -;;; Helper functions for managing a hash table of records +;;; -(defun get-record-hash (record hash) - (let ((bucket (gethash (slot-value record 'coordinates) hash))) - (if (null bucket) - (values nil nil) - (let ((rec (find record bucket :test #'output-record-equal))) - (if rec - (values rec t) - (values nil nil)))))) - -(defun add-record-hash (record hash) - (push record (gethash (slot-value record 'coordinates) hash nil))) - -(defun delete-record-hash (record hash) - (let ((bucket (gethash (slot-value record 'coordinates) hash))) - (if bucket - (multiple-value-bind (new-bucket deleted) - (delete-1 record bucket :test #'output-record-equal) - (if deleted - (progn - (setf (gethash (slot-value record 'coordinates) hash) - new-bucket) - t) - nil)) - nil))) +(defmethod output-record-hash (record) + (slot-value record 'coordinates)) (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) - offset-x offset-y - old-offset-x old-offset-y) + offset-x offset-y + old-offset-x old-offset-y) (declare (ignore offset-x offset-y old-offset-x old-offset-y)) - (when (eq (output-record-dirty record) :clean) - (return-from compute-difference-set (values nil nil nil nil nil))) - (let* ((draws nil) - (moves (explicit-moves record)) - (erases nil) - (erase-overlapping nil) - (move-overlapping nil) - (stream (updating-output-stream record)) - (visible-region (pane-viewport-region stream)) - (old-children (if (slot-boundp record 'old-children) - (old-children record) - nil)) - (old-bounds (old-bounds record))) - (unless (or (null visible-region) - (region-intersects-region-p visible-region record) - (and old-children - (region-intersects-region-p visible-region old-bounds))) - (return-from compute-difference-set (values nil nil nil nil nil))) - ;; XXX This means that compute-difference-set can't be called repeatedly on - ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves, - ;; they can hang around in the tree for later passes and cause trouble. - (setf (explicit-moves record) nil) - (let ((existing-output-records (make-hash-table :test 'equalp))) - ;; Find output records in the new tree that match a record in the old - ;; tree i.e., already have a valid display on the screen. - (map-over-child-display - (if old-children - #'(lambda (r) - (add-record-hash r existing-output-records)) - #'(lambda (r) (push (list r r) draws))) - (sub-record record) - visible-region) - (when old-children - (map-over-child-display - #'(lambda (r) - (unless (delete-record-hash r existing-output-records) - (push (list r (copy-bounding-rectange r)) erases))) - old-children - visible-region) - ;; Any records left in the hash table do not have a counterpart - ;; visible on the screen and need to be drawn. - (loop - for bucket being the hash-values of existing-output-records - do (loop - for r in bucket - do (push (list r r) draws))))) - (when check-overlapping - (setf erase-overlapping (nconc erases draws)) - (setf move-overlapping moves) - (setf erases nil) - (setf moves nil) - (setf draws nil)) - ;; Visit this record's updating-output children and merge in the - ;; difference set. We need to visit all updating-output records, not just - ;; ones in the visible region, because they might have old records that - ;; lie in the visible region and that need to be erased. - (map-over-child-updating-output - #'(lambda (r) - (multiple-value-bind (e m d e-o m-o) - (compute-difference-set r check-overlapping) - (setf erases (nconc e erases)) - (setf moves (nconc m moves)) - (setf draws (nconc d draws)) - (setf erase-overlapping (nconc e-o erase-overlapping)) - (setf move-overlapping (nconc m-o move-overlapping)))) - (sub-record record) - nil) - ;; Look for updating-output children that were not visited. Their - ;; display records need to be erased. - (when old-children - (flet ((erase-obsolete (dr) ;All of them - (let ((erase-chunk (list dr (copy-bounding-rectange dr)))) - (if check-overlapping - (push erase-chunk erase-overlapping) - (push erase-chunk erases))))) - (declare (dynamic-extent #'erase-obsolete)) - (map-over-child-updating-output - #'(lambda (r) - (when (eq (output-record-dirty r) :updating) - (map-over-obsolete-display #'erase-obsolete - (sub-record r) - visible-region))) - old-children - visible-region))) - ;; Traverse all the display records for this updating output node and do - ;; the notes... - (flet ((note-got (r) - (note-output-record-got-sheet r stream)) - (note-lost (r) - (note-output-record-lost-sheet r stream))) - (declare (dynamic-extent #'note-got #'note-lost)) - (map-over-child-display #'note-got (sub-record record) nil) - (when old-children - (map-over-child-display #'note-lost old-children nil) - (map-over-child-updating-output - #'(lambda (r) - (when (eq (output-record-dirty r) :updating) - (map-over-obsolete-display #'note-lost - (sub-record r) - nil))) - old-children - nil))) - (values erases moves draws erase-overlapping move-overlapping))) + ;; (declare (values erases moves draws erase-overlapping move-overlapping)) + (let (was + is + (everywhere (or +everywhere+ + (pane-viewport-region (updating-output-stream record))))) + ;; Collect what was there + (labels ((gather-was (record) + (cond ((displayed-output-record-p record) + (push record was)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (push record was)) + ((eq :moved (output-record-dirty record)) + (push (slot-value record 'old-bounds) was)) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere)) ))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (push record is)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (push record is)) + ((eq :moved (output-record-dirty record)) + (push record is)) + (t + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record)) + ;; + (let ((was-table (make-hash-table :test #'equalp)) + (is-table (make-hash-table :test #'equalp)) + gone + stay + come) + (loop for w in was do (push w (gethash (output-record-hash w) was-table))) + (loop for i in is do (push i (gethash (output-record-hash i) is-table))) + ;; gone = was \ is + (loop for w in was do + (cond ((updating-output-record-p w) + (unless (eq :clean (output-record-dirty w)) + (push (old-children w) gone))) + (t + (let ((q (gethash (output-record-hash w) is-table))) + (unless (some #'(lambda (x) (output-record-equal w x)) q) + (push w gone)))))) + ;; come = is \ was + ;; stay = is ^ was + (loop for i in is do + (cond ((updating-output-record-p i) + (if (eq :clean (output-record-dirty i)) + (push i stay) + (push i come))) + (t + (let ((q (gethash (output-record-hash i) was-table))) + (if (some #'(lambda (x) (output-record-equal i x)) q) + (push i stay) + (push i come)))))) + ;; Now we essentially want 'gone', 'stay', 'come' + (let ((gone-overlap nil) + (come-overlap nil)) + (when check-overlapping + (setf (values gone gone-overlap) + (loop for k in gone + if (some (lambda (x) (region-intersects-region-p k x)) + stay) + collect k into gone-overlap* + else collect k into gone* + finally (return (values gone* gone-overlap*)))) + (setf (values come come-overlap) + (loop for k in come + if (some (lambda (x) (region-intersects-region-p k x)) + stay) + collect k into come-overlap* + else collect k into come* + finally (return (values come* come-overlap*))))) + ;; Hmm, we somehow miss come-overlap ... + (values + ;; erases + (loop for k in gone collect (list k k)) + ;; moves + nil + ;; draws + (loop for k in come collect (list k k)) + ;; erase overlapping + (append (loop for k in gone-overlap collect (list k k)) + (loop for k in come-overlap collect (list k k))) + ;; move overlapping + nil))))) (defparameter *enable-updating-output* t "Switch to turn on incremental redisplay")

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs May 2005