Module: duim-sheets-internals Synopsis: DUIM sheets Author: Scott McKay, Andy Armstrong Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. All rights reserved. License: Functional Objects Library Public License Version 1.0 Dual-license: GNU Lesser General Public License Warranty: Distributed WITHOUT WARRANTY OF ANY KIND /// Sheets // The basic sheet protocol define protocol <> () // Sheet region getter sheet-region (sheet :: ) => (region :: ); setter sheet-region-setter (region :: , sheet :: ) => (region :: ); function note-region-changed (sheet :: ) => (); // Sheet transform getter sheet-transform (sheet :: ) => (transform :: ); setter sheet-transform-setter (transform :: , sheet :: ) => (transform :: ); function note-transform-changed (sheet :: ) => (); function sheet-delta-transform (sheet :: , ancestor :: ) => (transform :: ); // Sheet mapping getter sheet-mapped? (sheet :: ) => (mapped? :: ); setter sheet-mapped?-setter (mapped? :: , sheet :: , #key do-repaint?, clear?) => (mapped? :: ); getter sheet-withdrawn? (sheet :: ) => (withdrawn? :: ); setter sheet-withdrawn?-setter (withdrawn? :: , sheet :: , #key do-repaint?, clear?) => (withdrawn? :: ); function note-sheet-mapped (sheet :: ) => (); function note-sheet-unmapped (sheet :: ) => (); getter sheet-layed-out? (sheet :: ) => (layed-out? :: ); setter sheet-layed-out?-setter (layed-out? :: , sheet :: ) => (layed-out? :: ); // Cursors getter sheet-cursor (sheet :: ) => (cursor :: ); setter sheet-cursor-setter (cursor :: , sheet :: ) => (cursor :: ); // Carets getter sheet-caret (sheet :: ) => (caret :: type-union(, one-of(#f, #t))); // Focus getter sheet-input-focus (sheet :: ) => (focus :: false-or()); getter sheet-accepts-focus? (sheet :: ) => (focus? :: ); setter sheet-accepts-focus?-setter (focus? :: , sheet :: ) => (focus? :: ); // Clearing function clear-box (drawable :: , left, top, right, bottom) => (); function clear-box* (drawable :: , region :: ) => (); // Destruction function destroy-sheet (sheet :: ) => (); function do-destroy-sheet (sheet :: ) => (); // Help getter sheet-help-context (sheet :: ) => (context); setter sheet-help-context-setter (context, sheet :: ) => (context); getter sheet-help-source (sheet :: ) => (locator); setter sheet-help-source-setter (locator, sheet :: ) => (locator); end protocol <>; // Sheet genealogy define protocol <> (<>) getter sheet-parent (sheet :: ) => (parent :: false-or()); setter sheet-parent-setter (parent :: false-or(), sheet :: ) => (parent :: false-or()); function sheet-ancestor? (sheet :: , putative-ancestor :: ) => (true? :: ); getter sheet-children (sheet :: ) => (children :: ); setter sheet-children-setter (children :: , sheet :: ) => (children :: ); getter sheet-child (sheet :: ) => (child :: false-or()); setter sheet-child-setter (child :: false-or(), sheet :: ) => (child :: false-or()); // Adding a child sheet function add-child (sheet :: , child :: , #key index, #all-keys) => (sheet :: ); function do-add-child (sheet :: , child :: , #key index, #all-keys) => (); function note-child-added (sheet :: , child :: ) => (); // Removing a child sheet function remove-child (sheet :: , child :: ) => (sheet :: ); function do-remove-child (sheet :: , child :: ) => (); function note-child-removed (sheet :: , child :: ) => (); // Replacing a child function replace-child (sheet :: , old-child :: , new-child :: ) => (sheet :: ); function do-replace-child (sheet :: , old-child :: , new-child :: ) => (); // Traversing children function child-containing-position (sheet :: , x :: , y :: ) => (sheet :: false-or()); function do-children-containing-position (function :: , sheet :: , x :: , y :: ) => (); function children-overlapping-region (sheet :: , region :: ) => (sheets :: ); function do-children-overlapping-region (function :: , sheet :: , region :: ) => (); // Raising and lowering function raise-sheet (sheet :: , #key activate?) => (sheet :: ); function do-raise-sheet (parent :: , sheet :: , #key activate? = #t) => (); function lower-sheet (sheet :: ) => (sheet :: ); function do-lower-sheet (parent :: , sheet :: ) => (); end protocol <>; // Cached geometry define open generic invalidate-cached-regions (sheet :: ) => (); define open generic invalidate-cached-region (drawable :: ) => (); define open generic invalidate-cached-transforms (sheet :: ) => (); define open generic invalidate-cached-transform (drawable :: ) => (); define open generic invalidate-cached-drawing-state (medium :: , new-state :: ) => (); /// General accessors define open generic port (object) => (port :: false-or()); define open generic port-setter (port :: false-or(), object) => (port :: false-or()); define open generic %port-setter //--- sigh... (port :: false-or(), object) => (port :: false-or()); define open generic display (object) => (display :: false-or()); define open generic display-setter (display :: false-or(), object) => (display :: false-or()); define open generic sheet-frame (sheet :: ) => (frame :: false-or()); define open generic sheet-frame-setter (frame :: false-or(), sheet :: ) => (frame :: false-or()); define open generic frame-manager (object) => (framem :: false-or()); define open generic frame-manager-setter (framem :: false-or(), object) => (framem :: false-or()); define open generic top-level-sheet (object) => (sheet :: false-or()); define open generic top-level-sheet-setter (sheet :: false-or(), object) => (sheet :: false-or()); define constant = one-of(#f, #"top-down", #"bottom-up"); define open generic do-sheet-children (function :: , sheet :: , #key z-order :: ) => (); define open generic do-sheet-tree (function :: , sheet :: ) => (); define open generic sheet-shell (sheet :: ) => (sheet :: false-or()); /// Decoding the sheet flags // Bits 0..1 are the sheet's state define constant %sheet_mapped_mask :: = #o03; define constant %sheet_withdrawn :: = #o00; define constant %sheet_managed :: = #o01; define constant %sheet_mapped :: = #o02; define constant $sheet-states :: = #[#"withdrawn", #"managed", #"mapped", #"unknown"]; // Bit 2 is the "layed out" flag define constant %layed_out :: = #o04; // Bits 3..5 are the event mask define constant %sheet_event_mask :: = #o70; define constant %pointer_motion_mask :: = #o10; define constant %pointer_button_mask :: = #o20; define constant %keyboard_mask :: = #o40; // Bits 6..11 are the pointer cursor type define constant %pointer_cursor_shift :: = 6; define constant %pointer_cursor_mask :: = #o7700; // Bits 12..13 are reserved for box layouts (see layouts/box-pane) // define constant %equalize_widths :: = #o10000; // define constant %equalize_heights :: = #o20000; // Bit 14 is the "mirror accepts children" flag define constant %mirror_accepts_children :: = #o40000; // Bits 15..16 are reserved for fixed space requirements (see layouts/layout) // define constant %fixed_width :: = #o100000; // define constant %fixed_height :: = #o200000; // Bit 17 is presently unused // define constant %presently_unused :: = #o400000; // Bit 18 and 19 are the "accepts focus" and "keyboard navigation tab stop" flags define constant %accepts_focus :: = #o1000000; define constant %tab_stop :: = #o2000000; define constant $initial-sheet-flags :: = logior(%sheet_managed, %pointer_motion_mask, %pointer_button_mask, %keyboard_mask, %mirror_accepts_children, %accepts_focus, %tab_stop); // Note: these are intentionally not open define generic sheet-flags (sheet :: ) => (flags :: ); define generic sheet-flags-setter (flags :: , sheet :: ) => (flags :: ); /// Basic sheet implementation class define open abstract primary class () sealed slot sheet-parent :: false-or() = #f, setter: %parent-setter; sealed slot sheet-region :: = $nowhere, init-keyword: region:, setter: %region-setter; sealed slot sheet-transform :: = $identity-transform, init-keyword: transform:, setter: %transform-setter; sealed slot sheet-cached-device-region :: false-or() = #f; sealed slot sheet-cached-device-transform :: false-or() = #f; // This is the port to which the sheet has been grafted //--- This should really be a %display slot (but see ) sealed slot port :: false-or() = #f, init-keyword: port:, setter: %port-setter; // #t if the sheet (and it's mirror, if it has one) has been mapped, // #f otherwise (by "mapped" we mean "visible on the display" -- ignoring // issues of occlusion, of course) sealed slot sheet-flags :: = $initial-sheet-flags; // Default style, for when we create mediums and mirrors sealed slot %style-descriptor :: false-or() = #f, init-keyword: style-descriptor:; // Help contexts and locators // We store these as class slots in separate tables because we expect the // number of UI objects that have distinct contexts and locators to be small. // Pretending that these are slots lets users use 'help-context: #"foo"' //--- Maybe just add a 'sheet-properties' slots for these and for documentation? virtual slot sheet-help-context, init-keyword: help-context:; class slot %help-contexts :: = make(, weak: #"key"), setter: #f; virtual slot sheet-help-source, init-keyword: help-source:; class slot %help-sources :: = make(

, weak: #"key"), setter: #f; end class ; define method initialize (sheet :: , #key parent) next-method(); when (parent) sheet-parent(sheet) := parent end end method initialize; define constant $default-sheet-size :: = 100; // The flag initializations here need to be consonant with $initial-sheet-flags define method initialize (sheet :: , #key x, y, width, height, region, transform, withdrawn?, accepts-focus? = #t, tab-stop? = #t, cursor, foreground, background, text-style, help-context, help-source) // Be forgiving of things that pass in #f by mistake... initialize-sheet-geometry (sheet, x | 0, y | 0, width | $default-sheet-size, height | $default-sheet-size, region: region, transform: transform); when (foreground | background | text-style) sheet.%style-descriptor := make(, foreground: foreground, background: background, text-style: text-style) end; unless (accepts-focus?) // If this sheet doesn't accept the focus, turn off the flag sheet-flags(sheet) := logand(sheet-flags(sheet), lognot(%accepts_focus)) end; unless (tab-stop?) // Ditto for the "tab stop" flag sheet-flags(sheet) := logand(sheet-flags(sheet), lognot(%tab_stop)) end; when (cursor) let index = position($pointer-cursors, cursor) | 0; sheet-flags(sheet) := logior(logand(sheet-flags(sheet), lognot(%pointer_cursor_mask)), ash(index, %pointer_cursor_shift)) end; next-method(); when (withdrawn?) sheet-withdrawn?(sheet) := #t end; when (help-context) gethash(sheet.%help-contexts, sheet) := help-context end; when (help-source) gethash(sheet.%help-sources, sheet) := help-source end end method initialize; define open generic initialize-sheet-geometry (sheet :: , x :: , y :: , width :: , height :: , #key region, transform) => (); define sealed inline method initialize-sheet-geometry (sheet :: , x :: , y :: , width :: , height :: , #key region, transform) => () unless (region) sheet.%region := make-bounding-box(0, 0, width, height) end; unless (transform) sheet.%transform := make-translation-transform(x, y) end end method initialize-sheet-geometry; define method destroy-sheet (sheet :: ) => () local method destroy (sheet :: ) do(destroy, sheet-children(sheet)); do-destroy-sheet(sheet) end method; // First remove the sheet from its parent, then destroy the // hierarchy under the sheet from the bottom up. We are // relying on the fact that removing the top sheet from its // parent will degraft all the descendent sheets. let parent = sheet-parent(sheet); when (parent) remove-child(parent, sheet) end; destroy(sheet) end method destroy-sheet; define method do-destroy-sheet (sheet :: ) => () #f end method do-destroy-sheet; define method do-destroy-sheet (sheet :: ) => () remhash(sheet.%help-contexts, sheet); remhash(sheet.%help-sources, sheet) end method do-destroy-sheet; define method sheet-parent-setter (parent :: , sheet :: ) => (parent :: ) add-child(parent, sheet); parent end method sheet-parent-setter; define method sheet-parent-setter (parent == #f, sheet :: ) => (parent :: singleton(#f)) remove-child(sheet-parent(sheet), sheet); parent end method sheet-parent-setter; // By default, sheets have no children define method sheet-children (sheet :: ) => (children :: ) #[] end method sheet-children; define method sheet-region-setter (region :: , sheet :: ) => (region :: ) sheet.%region := region; note-region-changed(sheet); region end method sheet-region-setter; define method sheet-transform-setter (transform :: , sheet :: ) => (transform :: ) sheet.%transform := transform; note-transform-changed(sheet); transform end method sheet-transform-setter; // Returns the edges of the sheet in the sheet's own coordinate space // Note that this is different from calling 'sheet-edges' on a sheet! define method box-edges (sheet :: ) => (left :: , top :: , right :: , bottom :: ) box-edges(sheet-region(sheet)) end method box-edges; define sealed method sheet-state (sheet :: ) => (state) let state = logand(sheet-flags(sheet), %sheet_mapped_mask); $sheet-states[state] end method sheet-state; define sealed method sheet-state-setter (state, sheet :: , #rest keys, #key do-repaint?, clear?) => (state) ignore(do-repaint?, clear?); select (state) #"mapped" => apply(sheet-mapped?-setter, #t, sheet, keys); #"managed" => apply(sheet-mapped?-setter, #f, sheet, keys); #"withdrawn" => apply(sheet-withdrawn?-setter, #t, sheet, keys); end; state end method sheet-state-setter; // Is the sheet mapped, i.e., is both grafted and visible on the display device // (ignoring issues of occluding windows)? define sealed inline method sheet-mapped? (sheet :: ) => (mapped? :: ) logand(sheet-flags(sheet), %sheet_mapped_mask) = %sheet_mapped end method sheet-mapped?; // Map sheets from the bottom up // This can only move a sheet tree from the "managed" to the "mapped" state define method sheet-mapped?-setter (mapped? == #t, sheet :: , #key do-repaint? = #t, clear? = do-repaint?) => (mapped? :: ) //--- We should really do something like this to protect unwary users /* assert(sheet-mapped?(sheet-parent(sheet)), "Attempting to map %= whose parent %= is unmapped", sheet, sheet-parent(sheet)); */ let flags = sheet-flags(sheet); let state = logand(flags, %sheet_mapped_mask); unless (state = %sheet_withdrawn) // sheet is withdrawn, stop here for (child :: in sheet-children(sheet)) sheet-mapped?(child, do-repaint?: #f) := #t end; when (state = %sheet_managed) sheet-flags(sheet) := logior(logand(flags, lognot(%sheet_mapped_mask)), %sheet_mapped); note-sheet-mapped(sheet); when (do-repaint? & sheet-handles-repaint?(sheet)) repaint-within-parent(sheet, clear?: clear?) end end end; #t end method sheet-mapped?-setter; define method note-sheet-mapped (sheet :: ) => () #f end method note-sheet-mapped; define open generic repaint-within-parent (sheet :: , #key clear?) => (); //---*** Suspicious! Should maybe use 'sheet-device-parent' define method repaint-within-parent (sheet :: , #key clear? = #t) => () let parent = sheet-parent(sheet); when (sheet-mapped?(parent)) let region = transform-region(sheet-transform(sheet), sheet-region(sheet)); when (clear?) clear-box*(parent, region) end; repaint-sheet(parent, region) end end method repaint-within-parent; // Unmap sheets from the top down // This can only move a sheet tree from the "mapped" to the "managed" state define method sheet-mapped?-setter (mapped? == #f, sheet :: , #key do-repaint? = #t, clear? = do-repaint?) => (mapped? :: ) let flags = sheet-flags(sheet); let state = logand(flags, %sheet_mapped_mask); unless (state = %sheet_withdrawn) // sheet is withdrawn, stop here when (state = %sheet_mapped) sheet-flags(sheet) := logior(logand(flags, lognot(%sheet_mapped_mask)), %sheet_managed); note-sheet-unmapped(sheet) end; for (child :: in sheet-children(sheet)) sheet-mapped?(child, do-repaint?: #f) := #f end; when (do-repaint? & state = %sheet_mapped & sheet-handles-repaint?(sheet)) repaint-within-parent(sheet, clear?: clear?) end end; #f end method sheet-mapped?-setter; define method note-sheet-unmapped (sheet :: ) => () // If we're unmapping a sheet, make sure it doesn't hold the focus let _port = port(sheet); let new-focus = #f; let old-focus = port & port-input-focus(_port); when (sheet == old-focus) port-input-focus(_port) := new-focus end end method note-sheet-unmapped; // Stronger than unmapped. The sheet doesn't even participate in layout define sealed inline method sheet-withdrawn? (sheet :: ) => (withdrawn? :: ) logand(sheet-flags(sheet), %sheet_mapped_mask) = %sheet_withdrawn end method sheet-withdrawn?; // Moves a sheet from "mapped" or "managed" to "withdrawn" define method sheet-withdrawn?-setter (withdrawn? == #t, sheet :: , #key do-repaint? = #t, clear? = do-repaint?) => (withdrawn? :: ) let flags = sheet-flags(sheet); let state = logand(flags, %sheet_mapped_mask); unless (state = %sheet_withdrawn) sheet-flags(sheet) := logior(logand(flags, lognot(%sheet_mapped_mask)), %sheet_withdrawn); // When we go into the withdrawn state, pass through unmapped first... when (state = %sheet_mapped) note-sheet-unmapped(sheet) end; // Ensure all of the kids are unmapped (not withdrawn!) // We do this so that layout is unaffected below the withdrawn sheet for (child :: in sheet-children(sheet)) sheet-mapped?(child) := #f end; when (do-repaint? & state = %sheet_mapped) repaint-within-parent(sheet, clear?: clear?) end end; #t end method sheet-withdrawn?-setter; // Moves a sheet from "withdrawn" to "managed" (_not_ to "mapped") define method sheet-withdrawn?-setter (withdrawn? == #f, sheet :: , #key do-repaint? = #t, clear? = do-repaint?) => (withdrawn? :: ) ignore(do-repaint?, clear?); let flags = sheet-flags(sheet); let state = logand(flags, %sheet_mapped_mask); when (state = %sheet_withdrawn) sheet-flags(sheet) := logior(logand(flags, lognot(%sheet_mapped_mask)), %sheet_managed); // Ensure all of the kids are unwithdrawn, so that they can be // moved into managed or mapped later for (child :: in sheet-children(sheet)) sheet-withdrawn?(child) := #f end end; #f end method sheet-withdrawn?-setter; // Returns #t only when 'allocate-space' has been run on the sheet define sealed inline method sheet-layed-out? (sheet :: ) => (layed-out? :: ) logand(sheet-flags(sheet), %layed_out) = %layed_out end method sheet-layed-out?; // Don't seal this, because layout needs to augment it define method sheet-layed-out?-setter (layed-out? :: , sheet :: ) => (layed-out? :: ) sheet-flags(sheet) := logior(logand(sheet-flags(sheet), lognot(%layed_out)), if (layed-out?) %layed_out else 0 end); layed-out? end method sheet-layed-out?-setter; define method sheet-accepts-focus? (sheet :: ) => (accepts-focus? :: ) logand(sheet-flags(sheet), %accepts_focus) = %accepts_focus end method sheet-accepts-focus?; define method sheet-accepts-focus?-setter (accepts-focus? :: , sheet :: ) => (accepts-focus? :: ) sheet-flags(sheet) := logior(logand(sheet-flags(sheet), lognot(%accepts_focus)), if (accepts-focus?) %accepts_focus else 0 end); accepts-focus? end method sheet-accepts-focus?-setter; define sealed inline method sheet-tab-stop? (sheet :: ) => (tab-stop? :: ) logand(sheet-flags(sheet), %tab_stop) = %tab_stop end method sheet-tab-stop?; // This property allows certain mirrored sheets (e.g., Windows group boxes) // to decline to have mirrors parented into them. The interesting method // is defined on . // For unmirrored sheets, this must return #f. define method sheet-mirror-accepts-children? (sheet :: ) => (accepts-children? :: ) #f end method sheet-mirror-accepts-children?; define sealed inline method sheet-event-mask (sheet :: ) => (mask :: ) logand(sheet-flags(sheet), %sheet_event_mask) end method sheet-event-mask; define sealed method sheet-event-mask-setter (mask :: , sheet :: ) => (mask :: ) sheet-flags(sheet) := logior(logand(sheet-flags(sheet), lognot(%sheet_event_mask)), mask) end method sheet-event-mask-setter; define method display (sheet :: ) => (display :: false-or()) let top-sheet = top-level-sheet(sheet); top-sheet & display(top-sheet) end method display; // This method just provides a uniform protocol for setting the display //--- Note that setting the display is done only during the grafting process define method display-setter (_display :: false-or(), sheet :: ) => (_display :: false-or()) _display end method display-setter; define method sheet-frame (sheet :: ) => (frame :: false-or()) let top-sheet = top-level-sheet(sheet); top-sheet & sheet-frame(top-sheet) end method sheet-frame; define method sheet-frame-setter (frame :: false-or(), sheet :: ) => (frame :: false-or()) error("Attempt to set frame of a non top-level sheet %=\n", sheet) end method sheet-frame-setter; define method frame-manager (sheet :: ) => (framem :: false-or()) let top-sheet = top-level-sheet(sheet); top-sheet & frame-manager(top-sheet) end method frame-manager; // Some mirrored sheets might have a "shell" that acts as it's external handle define method sheet-shell (sheet :: ) => (shell :: ) sheet end method sheet-shell; // This method allows a sheet to delegate its focus somewhere else. // Most sheets just keep the focus themselves -- but not viewports define method sheet-input-focus (sheet :: ) => (focus :: ) sheet end method sheet-input-focus; define sealed method default-foreground (sheet :: ) => (fg :: false-or()) let style = sheet.%style-descriptor; style & default-foreground(style) end method default-foreground; define sealed method default-foreground-setter (fg :: false-or(), sheet :: ) => (fg :: false-or()) let style = sheet.%style-descriptor | begin let style = make(); sheet.%style-descriptor := style; style end; default-foreground(style) := fg; fg end method default-foreground-setter; define sealed method default-background (sheet :: ) => (fg :: false-or()) let style = sheet.%style-descriptor; style & default-background(style) end method default-background; define sealed method default-background-setter (bg :: false-or(), sheet :: ) => (bg :: false-or()) let style = sheet.%style-descriptor | begin let style = make(); sheet.%style-descriptor := style; style end; default-background(style) := bg; bg end method default-background-setter; define sealed method default-text-style (sheet :: ) => (ts :: false-or()) let style = sheet.%style-descriptor; style & default-text-style(style) end method default-text-style; define sealed method default-text-style-setter (ts :: false-or(), sheet :: ) => (ts :: false-or()) let style = sheet.%style-descriptor | begin let style = make(); sheet.%style-descriptor := style; style end; default-text-style(style) := ts; ts end method default-text-style-setter; /// Help define method sheet-help-context (sheet :: ) => (context) gethash(sheet.%help-contexts, sheet) end method sheet-help-context; define method sheet-help-context-setter (context, sheet :: ) => (context) gethash(sheet.%help-contexts, sheet) := context end method sheet-help-context-setter; define method sheet-help-source (sheet :: ) => (locator) gethash(sheet.%help-sources, sheet) end method sheet-help-source; define method sheet-help-source-setter (locator, sheet :: ) => (locator) gethash(sheet.%help-sources, sheet) := locator end method sheet-help-source-setter; /// Cursors define constant $pointer-cursors :: = #[#"default", // must be at index 0 #"busy", #"vertical-scroll", #"horizontal-scroll", #"scroll-up", #"scroll-down", #"scroll-left", #"scroll-right", #"upper-left", #"upper-right", #"lower-left", #"lower-right", #"vertical-thumb", #"horizontal-thumb", #"button", #"prompt", #"move", #"position", #"i-beam", #"cross", #"starting", #"hand"]; define method sheet-cursor (sheet :: ) => (cursor :: ) let index = ash(logand(sheet-flags(sheet), %pointer_cursor_mask), -%pointer_cursor_shift); $pointer-cursors[index] end method sheet-cursor; define method sheet-cursor-setter (cursor :: , sheet :: ) => (cursor :: ) unless (sheet-cursor(sheet) == cursor) do-set-sheet-cursor(port(sheet), sheet, cursor); let index = position($pointer-cursors, cursor) | 0; sheet-flags(sheet) := logior(logand(sheet-flags(sheet), lognot(%pointer_cursor_mask)), ash(index, %pointer_cursor_shift)) end; cursor end method sheet-cursor-setter; /// Carets define open abstract class () sealed slot sheet-caret :: type-union(, one-of(#f, #t)) = #f, init-keyword: caret:; end class ; define method sheet-caret (sheet :: ) => (caret :: singleton(#f)) #f end method sheet-caret; define method note-sheet-attached (sheet :: ) => () next-method(); when (sheet-caret(sheet) = #t) sheet-caret(sheet) := make-caret(port(sheet), sheet) end end method note-sheet-attached; /// Genealogy define method sheet-child (sheet :: ) => (child :: false-or()) let children = sheet-children(sheet); let n-children :: = size(children); assert(n-children <= 1, "The sheet %= has more than one child", sheet); if (zero?(n-children)) #f else children[0] end end method sheet-child; //--- Kludge so that sheets can be shared among multiple layouts define thread variable *old-layout* :: false-or() = #f; define method add-child (sheet :: , child :: , #rest keys, #key index) => (sheet :: ) dynamic-extent(keys); ignore(index); when (sheet-parent(child)) if (*old-layout* & sheet-ancestor?(child, *old-layout*)) // If this child is parented into an old layout, just remove it remove-child(sheet-parent(child), child) else assert(~sheet-parent(child), "The sheet %= already has a parent", child) end end; apply(do-add-child, sheet, child, keys); note-child-added(sheet, child); sheet end method add-child; define method note-child-added (sheet :: , child :: ) => () sheet-layed-out?(sheet) := #f; when (sheet-attached?(sheet)) // If the sheet we're adding is attached, attach the child as well graft-sheet(sheet, child) end end method note-child-added; define method note-child-added (sheet :: , child :: ) => () child.%parent := sheet; next-method() end method note-child-added; // Attach the sheet all the way up to the display, and make sure all its // children are attached as well. Note that this doesn't map the sheet, // because we don't want to willy-nilly pop windows up on the screen. //--- Should this avoid grafting if the sheet is withdrawn? define method graft-sheet (parent :: , sheet :: ) => () let _port = port(parent); let _display = display(parent); sheet.%port := _port; display(sheet) := _display; note-sheet-attached(sheet); for (child :: in sheet-children(sheet)) graft-sheet(sheet, child) // graft it, but don't map it end end method graft-sheet; define method remove-child (sheet :: , child :: ) => (sheet :: ) assert(sheet-parent(child) == sheet, "The sheet %= is not a child of %=", child, sheet); do-remove-child(sheet, child); note-child-removed(sheet, child); sheet end method remove-child; define method note-child-removed (sheet :: , child :: ) => () sheet-layed-out?(sheet) := #f; when (sheet-attached?(sheet)) // If we're going to degraft it, unmap it first sheet-mapped?(child) := #f; // If the sheet we're removing from was attached, detach the child degraft-sheet(sheet, child) end end method note-child-removed; define method note-child-removed (sheet :: , child :: ) => () next-method(); child.%parent := #f end method note-child-removed; define method degraft-sheet (parent :: , sheet :: ) => () for (child :: in sheet-children(sheet)) degraft-sheet(sheet, child) end; note-sheet-detached(sheet); sheet-layed-out?(sheet) := #f; // We remove the sheet from the display, but not from the port. The // reason is that we don't want to lose any closing-down events display(sheet) := #f end method degraft-sheet; define method replace-child (sheet :: , old-child :: , child :: ) => (sheet :: ) when (sheet-parent(child)) if (*old-layout* & sheet-ancestor?(child, *old-layout*)) // If this child is parented into an old layout, just remove it remove-child(sheet-parent(child), child) else assert(~sheet-parent(child), "The sheet %= already has a parent", child) end end; do-replace-child(sheet, old-child, child); note-child-removed(sheet, old-child); note-child-added(sheet, child); sheet end method replace-child; define open abstract class () sealed slot sheet-children :: = make(), setter: %children-setter; end class ; define method initialize (sheet :: , #key children) next-method(); when (children) sheet.%children := as(, children); do(curry(note-child-added, sheet), children) end end method initialize; define method sheet-children-setter (children :: , sheet :: ) => (children :: ) let old-children = sheet-children(sheet); let new-children :: = as(, children); sheet.%children := new-children; for (child :: in old-children) unless (member?(child, new-children)) note-child-removed(sheet, child) end end; for (child :: in new-children) unless (member?(child, old-children)) note-child-added(sheet, child) end end; children end method sheet-children-setter; define method do-add-child (sheet :: , child :: , #key index = #"end") => () //--- This might not get the Z-ordering right if the children overlap... insert-at!(sheet-children(sheet), child, index) end method do-add-child; define method do-remove-child (sheet :: , child :: ) => () remove!(sheet-children(sheet), child) end method do-remove-child; define method do-replace-child (sheet :: , old-child :: , new-child :: ) => () substitute!(sheet-children(sheet), old-child, new-child) end method do-replace-child; define open abstract class () sealed slot sheet-children :: = #[], setter: %children-setter; end class ; define method initialize (sheet :: , #key child) next-method(); when (child) sheet.%children := vector(child); note-child-added(sheet, child) end end method initialize; define method sheet-children-setter (children :: , sheet :: ) => (children :: ) assert(size(children) <= 1, "You can only add one child to the sheet %=", sheet); let old-children = sheet-children(sheet); let old-child = ~empty?(old-children) & old-children[0]; let new-child = ~empty?(children) & children[0]; sheet.%children := as(, children); unless (old-child == new-child) when (old-child) note-child-removed(sheet, old-child) end; when (new-child) note-child-added(sheet, new-child) end end; children end method sheet-children-setter; define method sheet-child (sheet :: ) => (child :: false-or()) let children = sheet-children(sheet); unless (empty?(children)) children[0] end end method sheet-child; define method sheet-child-setter (child :: , sheet :: ) => (child :: ) sheet-children(sheet) := vector(child); child end method sheet-child-setter; define method do-add-child (sheet :: , child :: , #key index) => () ignore(index); assert(empty?(sheet-children(sheet)), "The single-child sheet %= already has a child", sheet); sheet.%children := vector(child) end method do-add-child; define method do-remove-child (sheet :: , child :: ) => () sheet.%children := #[] end method do-remove-child; define method do-replace-child (sheet :: , old-child :: , new-child :: ) => () substitute!(sheet-children(sheet), old-child, new-child) end method do-replace-child; /// Traversing sheet regions // When a sequence is used to store children, DUIM requires that the // lowest sheets in the Z-ordering (bottom) be at the front of the sequence define sealed inline method bottom-up-iteration-protocol (children :: ) => (initial-state :: , limit :: , next-state :: , finished-state? :: , current-key :: , current-element :: , current-element-setter :: , copy-state :: ) forward-iteration-protocol(children) end method bottom-up-iteration-protocol; // When a sequence is used to store children, DUIM requires that the // highest sheets in the Z-ordering (top) be at the back of the sequence define sealed inline method top-down-iteration-protocol (children :: ) => (initial-state :: , limit :: , next-state :: , finished-state? ::