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

[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 12 May '05

12 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 11 May '05

11 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 11 May '05

11 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