Module: utilities
Author: Hugh Greene
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
/// ----------------------------------------------------------------------
/// HANDY UTILITIES
define function strings-size-info
(drawable /* :: <drawable> */, strings :: <vector> /* of: <string> */)
=> (total-width :: <real>, min-width :: <real>, max-width :: <real>,
total-height :: <real>, min-height :: <real>, max-height :: <real>)
let (tw, w-, w+, th, h-, h+) = values(0, 0, 0, 0, 0, 0);
for (str in strings)
let (width, height) = text-size(drawable, str);
tw := tw + width;
th := th + height;
when (width > w+) w+ := width end;
when (height > h+) h+ := height end;
when (width < w-) w- := width end;
when (height < h-) h- := height end;
end;
values(tw, w-, w+, th, h-, h+)
end function;
// Given a pathname which may refer to a non-existent directory, try to
// find some ancestor directory (includind the directory itself) which does
// exist.
define function find-existing-ancestor
(directory :: <directory-locator>)
=> (ancestor :: false-or(<directory-locator>))
local method %find-existing-ancestor
(directory :: <directory-locator>)
=> (ancestor :: false-or(<directory-locator>))
if (file-exists?(directory))
directory
else
let parent = directory.locator-directory;
unless (parent = directory)
%find-existing-ancestor(directory.locator-directory)
end;
end
end method;
%find-existing-ancestor(directory)
end function find-existing-ancestor;
define function maybe-ensure-project-directory
(directory :: <directory-locator>, #key owner)
=> (dir-ok? :: <boolean>)
if (file-exists?(directory))
// If it's not empty, warn the user
if (directory-empty?(directory))
#t
else
let dir-string = as(<string>, directory);
let message
= concatenate
("The directory '", dir-string, "' already exists"
" and is not empty.\nAre you sure you want to use it?\n"
"If not, you must enter a different location for the project.\n");
notify-user
(message, style: #"information", exit-style: #"yes-no",
owner: owner);
end
else
ensure-directories-exist(directory) & #t
//---*** What if it fails to create the directories?
end;
end function maybe-ensure-project-directory;
/// ----------------------------------------------------------------------
/// CHOICE
/// Class encapsulating an object and a flag determining whether or not
/// it is in some sense "included" (or "chosen"). The <choice> can also
/// encapsulate "children" of the encapsulated object, which are regarded
/// as "included" iff they _and_ their "parent" are "included".
// --- Yes, I know "choice" is a stupid, over-general, uninformative name.
define sealed class <choice> (<object>)
sealed constant slot choice-object,
required-init-keyword: object:;
sealed slot choice-children :: false-or(<vector>) = #f,
init-keyword: children:;
sealed slot choice-included? :: <boolean> = #f,
init-keyword: included?:,
setter: %included?-setter;
end class;
define sealed method choice-included?-setter
(included? :: <boolean>, choice :: <choice>, #key recursive?)
=> (included? :: <boolean>)
let children = choice.choice-children;
when (recursive? & children)
for (child in children)
child.choice-included? := included?;
end;
end;
choice.%included? := included?
end;
define function all-included-choices
(choices :: <vector>) // of: <choice>
=> (included-choices :: <vector>) // of: <choice>
if (empty?(choices))
choices
else
let included-choices = make(<stretchy-vector>);
reduce1(method (choice)
when (choice.choice-included?)
add!(included-choices,
make(<choice>, object: choice.choice-object,
children:
all-included-choices(choice.choice-children),
included?: #t))
end;
end,
choices);
included-choices
end
end function;
// This is intended to be used in a call to 'union' two sequences of
// same-type <choices>. If the two are the same according to 'test'
// (which you normally want to supply as '\='), it will mark both
// as 'included?' if either is. If 'recursive?' is true, it will do
// the same 'union' for the two choice-children lists, and give both
// choices the same resulting children.
//
// The intended use of this is to merge two lists of library-choices
// so that all the required libraries and modules are included.
define function union-choice-inclusion!
(choice1 :: <choice>, choice2 :: <choice>,
#key test :: false-or(<function>) = \==,
recursive? :: <boolean> = #f)
=> (same? :: <boolean>)
when (test(choice1, choice2))
let included? = choice1.choice-included? | choice2.choice-included?;
choice1.choice-included? := included?;
choice2.choice-included? := included?;
when (recursive?)
let children1 = choice1.choice-children;
let children2 = choice2.choice-children;
let new-children
= if (children1 & children2)
union(children1, children2,
test: rcurry(union-choice-inclusion!,
test: test, recursive?: #t));
else
// Take whichever of the "sequences" is really a <sequence>
children1 | children2
end;
new-children := new-children & as(<vector>, new-children);
choice1.choice-children := new-children;
choice2.choice-children := new-children;
end;
#t
end;
end function union-choice-inclusion!;
define sealed method \< (choice1 :: <choice>, choice2 :: <choice>)
=> (less? :: <boolean>)
choice1.choice-object < choice2.choice-object
end method;
define sealed method \= (choice1 :: <choice>, choice2 :: <choice>)
=> (equal? :: <boolean>)
choice1.choice-object = choice2.choice-object
end method;
/// ----------------------------------------------------------------------
/// FILE-BROWSE PANE CLASS
/// A "gadget" incorporating a text field and a "Browse..." button.
/// Pressing the button pops up a file dialog and selecting a file
/// (or directory) in the dialog (and then "OK"ing the dialog) will
/// set the text field to that string.
define pane <file-browse-pane> ()
// Arguments to pass to the choose-file dialog.
constant slot %file-browse-function-initargs :: <sequence>,
required-init-keyword: browse-function-initargs:;
slot file-browse-function :: <function> = choose-file,
init-keyword: browse-function:;
pane file-browse-text-pane (pane)
make(<text-field>);
pane file-browse-button (pane)
make(<push-button>, label: "Browse...",
activate-callback:
method (pb)
// Do choose-file and update text pane with results.
let location // ignore "filter"
= apply(pane.file-browse-function,
pane.%file-browse-function-initargs);
when (instance?(location, <string>))
gadget-value(pane.file-browse-text-pane, do-callback?: #t)
:= location;
end;
end);
layout (pane)
horizontally (x-spacing: 8, y-alignment: #"top", equalize-heights?: #t)
pane.file-browse-text-pane;
pane.file-browse-button;
end;
end pane;
define method make
(class == <file-browse-pane>, #rest initargs, #key, #all-keys)
=> (pane :: <file-browse-pane>)
// --- copy-sequence is a hack for emulator compatibility.
let initargs = copy-sequence(initargs);
apply(next-method, class, browse-function-initargs: initargs, initargs)
end method;
define method initialize
(pane :: <file-browse-pane>, #key value, #all-keys)
next-method();
gadget-value(pane.file-browse-text-pane) := value | "";
end method initialize;
define function file-browse-pane-enabled?-setter
(enabled? :: <boolean>, pane :: <file-browse-pane>)
=> (enabled? :: <boolean>)
gadget-enabled?(pane.file-browse-text-pane) := enabled?;
gadget-enabled?(pane.file-browse-button) := enabled?;
enabled?
end function;
/// ----------------------------------------------------------------------
/// TEXT-FIELD-OPTION PANE CLASS
define pane <text-field-option> ()
sealed constant slot %label :: <string>,
required-init-keyword: label:;
sealed constant slot text-field-option-text-field :: <text-field>,
required-init-keyword: text-field:;
sealed slot text-field-option-text-field-value = "";
pane text-field-option-check-button (pane)
make(<check-button>, label: pane.%label, value: #t,
value-changed-callback:
method (cb)
text-field-option-enabled?(pane) := gadget-value(cb)
end);
layout (pane)
pane.text-field-option-check-button;
end pane;
define method initialize
(pane :: <text-field-option>, #key enabled? = #t, value, #all-keys)
next-method();
if (~enabled?)
text-field-option-enabled?(pane) := #f
end;
when (value)
let text-field = pane.text-field-option-text-field;
gadget-value(text-field) := value;
end
end method initialize;
define method text-field-option-enabled?-setter
(enabled? :: <boolean>, pane :: <text-field-option>)
=> (enabled? :: <boolean>)
let button = pane.text-field-option-check-button;
gadget-value(button) := enabled?;
gadget-enabled?(pane.text-field-option-text-field) := enabled?;
// Whenever we change, swap the current value and our empty
// string, so that the disabled text field is blank and has
// an empty value when we retreive it to write the project.
let temp = pane.text-field-option-text-field-value;
pane.text-field-option-text-field-value
:= gadget-value(pane.text-field-option-text-field);
gadget-value(pane.text-field-option-text-field) := temp;
let cb = pane.text-field-option-text-field.gadget-value-changed-callback;
cb & cb(pane.text-field-option-text-field);
enabled?
end method text-field-option-enabled?-setter;
define function text-field-option-value
(pane :: <text-field-option>)
=> (value :: false-or(<string>))
gadget-value(pane.text-field-option-check-button)
& gadget-value(pane.text-field-option-text-field)
end function;
/* #### MULTI-LINE TEXT #############################
/// ----------------------------------------------------------------------
/// MULTI-LINE TEXT PANE CLASS
define pane <multi-line-text-pane> ()
sealed slot %labels :: <sequence>;
layout (pane)
make(<column-layout>, children: pane.%labels, y-spacing: 2);
required keyword labels:, type: <sequence>;
end pane;
define method make
(class == <multi-line-text-pane>, #key labels, #all-keys)
let real-labels = map(method (l) make(<label>, label: l) end, labels);
let space-req
= make(<space-requirement>,
function:
method (mltp)
let (tw, w-, w+, th, h-, h+)
= strings-size-info(port(mltp), labels);
values(w+, w+, $fill, th, th, $fill)
end);
apply(next-method, class, labels: real-labels,
space-requirement: space-req, #())
end method initialize;
/// ----------------------------------------------------------------------
/// MULTI-PAGE PANE CLASS
// I'm only faking up the minimum I need here.
define pane <multi-page-pane> ()
sealed slot pages :: <sequence>, // of: <pair>(label, page)
required-init-keyword: pages:;
sealed slot current-page,
setter: %current-page-setter;
layout (pane)
/* ??? */;
keyword current-page:;
end pane;
define method current-page-setter
(page-label, pane :: <multi-page-pane>)
=> (page-label)
let the-page = #f;
for (page in pane.pages, until: the-page)
when (head(page) == page-label)
the-page := tail(page);
end;
end;
when (the-page)
sheet-mapped?(pane.current-page) := #f;
pane.%current-page := the-page;
sheet-mapped?(pane.current-page) := #t;
relayout-parent(sheet-parent(the-page));
end;
end method;
define method initialize
(pane :: <multi-page-pane>, #key pages, current-page, #all-keys)
debug-assert("Attempt to create <multi-page-pane> with no pages",
~empty?(pages));
next-method();
pane.current-page := current-page | head(pages[0]);
end method initialize;
#### MULTI-LINE TEXT ############################# */