PopUpButtonsImpl.mesa
Copyright Ó 1991 by Xerox Corporation. All rights reserved.
Demers, January 5, 1987 12:21:07 pm PST
Last tweaked by Mike Spreitzer on September 8, 1989 6:03:03 pm PDT
Bier, July 17, 1989 10:16:56 pm PDT
Willie-s, October 26, 1992 4:40 pm PST
Michael Plass, February 7, 1992 5:49 pm PST
DIRECTORY Atom, Basics, CedarProcess, Convert, Imager, ImagerBackdoor, ImagerColor, ImagerColorPrivate, ImagerFont, ImagerTransformation, InputFocus, IO, List, MachineDependentPopping, Menus, MessageWindow, MessageWindowBackdoor, PopUpButtons, PopUpButtonsPrivate, PopUpSelection2, Process, ProcessProps, Real, RefTab, Rope, TEditSelection, TEditSplit, TIPUser, UserProfile, Vector2, VFonts, ViewerClasses, ViewerOps, ViewerPrivate, ViewerSpecs, ViewerTools;
PopUpButtonsImpl: CEDAR MONITOR
IMPORTS Atom, Basics, CedarProcess, Convert, Imager, ImagerBackdoor, ImagerColorPrivate, ImagerFont, ImagerTransformation, InputFocus, IO, List, MachineDependentPopping, MessageWindow, MessageWindowBackdoor, PopUpButtons, PopUpSelection2, Process, ProcessProps, Real, RefTab, Rope, TEditSelection, TEditSplit, TIPUser, UserProfile, Vector2, VFonts, ViewerOps, ViewerPrivate, ViewerSpecs, ViewerTools
EXPORTS PopUpButtons
=
BEGIN OPEN MDP:MachineDependentPopping, ViewerClasses, PUS:PopUpSelection2, PopUpButtonsPrivate, PopUpButtons;
LORA: TYPE = LIST OF REF ANY;
ATOMList: TYPE = LIST OF ATOM;
LOR: TYPE = LIST OF ROPE;
Instance: TYPE ~ REF InstancePrivate;
InstancePrivate: PUBLIC TYPE = PopUpButtonsPrivate.InstancePrivate;
leftMargin: INTEGER ¬ 3;
rightMargin: INTEGER ¬ 2;
bottomMargin: INTEGER ¬ 0;
topMargin: INTEGER ¬ 1;
Class: TYPE = REF ClassPrivate;
ClassPrivate: PUBLIC TYPE = PopUpButtonsPrivate.ClassPrivate;
dontPaint: PUBLIC Imager.SpecialColor ¬ ImagerColorPrivate.ColorFromStipple[
word: 0, function: [xor, null]];
noHelp: PUBLIC REF HelpPrivate[none] ¬ NEW [HelpPrivate[none] ¬ [none[]]];
undef: CharData = [ALL[0], 0];
maxHeight: NAT = 5;
CharData: TYPE = RECORD [
bits: ARRAY [0 .. maxHeight) OF WORD,
width: [0 .. Basics.bitsPerWord]
];
Char: TYPE = CHAR['A .. 'Z];
BitFont: TYPE = REF BitFontPrivate;
BitFontPrivate: TYPE = RECORD [
height, hSep, vSep: NAT,
chars: ARRAY Char OF CharData ¬ ALL[undef]
];
idTransform: Imager.Transformation ~ ImagerTransformation.Translate[[0.0, 0.0]];
smallBF: BitFont ¬ MakeSmallFont[];
MakeSmallFont: PROC RETURNS [smallBF: BitFont] = {
Set: PROC [char: CHAR, width: NAT, asRope: ROPE] = {
smallBF.chars[char].width ¬ width;
FOR row: NAT IN [0 .. 4] DO
FOR col: NAT IN [0 .. width) DO
SELECT asRope.Fetch[row*(width+1) + col + 1] FROM
'. => NULL;
'X => smallBF.chars[char].bits[row] ¬ Basics.BITOR[
smallBF.chars[char].bits[row],
Basics.BITSHIFT[1, Basics.bitsPerWord - col - 1]];
ENDCASE => ERROR;
ENDLOOP;
ENDLOOP;
};
smallBF ¬ NEW [BitFontPrivate ¬ [height: 5, hSep: 1, vSep: 1]];
Set['A, 3, "
.X.
X.X
XXX
X.X
X.X"];
Set['C, 4, "
.XXX
X...
X...
X...
.XXX"];
Set['F, 4, "
XXXX
X...
XXX.
X...
X..."];
Set['H, 4, "
X..X
X..X
XXXX
X..X
X..X"];
Set['I, 3, "
XXX
.X.
.X.
.X.
XXX"];
Set['L, 3, "
X..
X..
X..
X..
XXX"];
Set['N, 4, "
X..X
XX.X
XXXX
X.XX
X..X"];
Set['P, 4, "
XXX.
X..X
XXX.
X...
X..."];
Set['R, 4, "
XXX.
X..X
XXX.
X.X.
X..X"];
Set['S, 4, "
.XXX
X...
.XX.
...X
XXX."];
Set['T, 3, "
XXX
.X.
.X.
.X.
.X."];
};
mouseButtonIcons: ARRAY Menus.MouseButton OF PUS.Image ¬ [MakeMouseIcon[red], MakeMouseIcon[yellow], MakeMouseIcon[blue]];
sayPlain: PUS.Image ¬ MakeWords[LIST["PLAIN"]];
sayShf: PUS.Image ¬ MakeWords[LIST["SHIFT"]];
sayCtl: PUS.Image ¬ MakeWords[LIST["CNTRL"]];
sayBoth: PUS.Image ¬ MakeWords[LIST["CNTRL", "SHIFT"]];
MakeMouseIcon: PROC [mb: Menus.MouseButton] RETURNS [image: PUS.Image] = {
image ¬ NEW [PUS.ImagePrivate ¬ [
size: mbiSize[it].Add[[2*(mbiSize[other].x + mbiSep + mbiw), 2*mbiw]],
Draw: DrawMouseButtonIcon,
data: NEW [Menus.MouseButton ¬ mb]
]];
};
mbib: REAL = 1.0;
mbiw: REAL = 1.0;
mbiSize: ARRAY {it, other} OF Vector2.VEC = [[5, 11], [4, 9]];
mbiSep: REAL = 1.0;
DrawMouseButtonIcon: PROC [image: PUS.Image, context: Imager.Context, bounds: Imager.Rectangle, state: VisibleState] --PUS.Drawer-- = {
rmb: REF Menus.MouseButton = NARROW[image.data];
y: REAL = bounds.y + bounds.h/2 + mbiw;
x: REAL ¬ bounds.x + (bounds.w - image.size.x)/2 + mbiw;
FOR mb: Menus.MouseButton IN Menus.MouseButton DO
size: Imager.VEC = IF mb = rmb­ THEN mbiSize[it] ELSE mbiSize[other];
context.SetColor[Imager.black];
context.MaskRectangle[[x, y-size.y/2, size.x, size.y]];
IF mb # rmb­ THEN {
context.SetColor[Imager.white];
context.MaskRectangle[[x+mbib, y-size.y/2+mbib, size.x-2*mbib, size.y-2*mbib]];
};
x ¬ x + size.x + mbiSep;
ENDLOOP;
};
ww: REAL = 1.0;
MakeWords: PROC [wl: LOR] RETURNS [image: PUS.Image] = {
image ¬ NEW [PUS.ImagePrivate ¬ [
size: [0, 0],
Draw: DrawWords,
data: wl]];
FOR words: LOR ¬ wl, words.rest WHILE words # NIL DO
word: ROPE = words.first;
width: NAT ¬ 0;
FOR i: NAT IN [0 .. NAT[word.Length[]]) DO
char: CHAR = word.Fetch[i];
IF i > 0 THEN width ¬ width + smallBF.hSep;
width ¬ width + smallBF.chars[char].width;
ENDLOOP;
image.size.x ¬ MAX[image.size.x, width];
image.size.y ¬ image.size.y + smallBF.height;
IF words.rest # NIL THEN image.size.y ¬ image.size.y + smallBF.vSep;
ENDLOOP;
image.size ¬ image.size.Add[[2*ww, 2*ww]];
};
DrawWords: PROC [image: PUS.Image, context: Imager.Context, bounds: Imager.Rectangle, state: VisibleState] --PUS.Drawer-- = {
wl: LOR = NARROW[image.data];
y: INTEGER ¬ Real.Round[bounds.y + (image.size.y + bounds.h)/2];
context.SetColor[Imager.black];
FOR words: LOR ¬ wl, words.rest WHILE words # NIL DO
word: ROPE = words.first;
x: INTEGER ¬ Real.Round[bounds.x + (bounds.w - image.size.x)/2];
FOR i: NAT IN [0 .. NAT[word.Length[]]) DO
char: CHAR = word.Fetch[i];
TRUSTED {context.MaskBits[base: @smallBF.chars[char].bits[0], wordsPerLine: 1, sMin: 0, fMin: 0, sSize: smallBF.height, fSize: smallBF.chars[char].width, tx: x, ty: y]};
TRUSTED {ImagerBackdoor.MaskBits[context: context, base: @smallBF.chars[char].bits[0], wordsPerLine: 1, sMin: 0, fMin: 0, sSize: smallBF.height, fSize: smallBF.chars[char].width, tx: x, ty: y]};
x ¬ x + smallBF.chars[char].width + smallBF.hSep;
ENDLOOP;
y ¬ y - smallBF.vSep - smallBF.height;
ENDLOOP;
};
topMouse: PUS.Label ¬ MakeLabel[horiz, LIST[mouseButtonIcons[red], mouseButtonIcons[yellow], mouseButtonIcons[blue]]];
leftMouse: PUS.Label ¬ MakeLabel[vert, LIST[mouseButtonIcons[red], mouseButtonIcons[yellow], mouseButtonIcons[blue]]];
leftCtlShf: PUS.Label ¬ MakeLabel[vert, LIST[sayPlain, sayShf, sayCtl, sayBoth]];
topShf: PUS.Label ¬ MakeLabel[horiz, LIST[sayPlain, sayShf]];
leftShf: PUS.Label ¬ MakeLabel[vert, LIST[sayPlain, sayShf]];
leftCtl: PUS.Label ¬ MakeLabel[vert, LIST[sayPlain, sayCtl]];
MakeLabel: PROC [dim: Dim, images: PUSImageList] RETURNS [label: PUS.Label] = {
il: ImageLabel = NEW [ImageLabelPrivate ¬ [dim, images]];
label ¬ NEW [PUS.LabelPrivate ¬ [
minSpacing: 0,
minWidth: 0,
Draw: DrawLabel,
data: il]];
FOR list: PUSImageList ¬ images, list.rest WHILE list # NIL DO
image: PUS.Image = list.first;
Maxin: PROC [minSpacing, minWidth: NAT, s, w: REAL] RETURNS [newMinSpacing, newMinWidth: NAT] = {
newMinSpacing ¬ MAX[minSpacing, NAT[Ceiling[s]]];
newMinWidth ¬ MAX[minWidth, NAT[Ceiling[w]]];
};
SELECT dim FROM
horiz => [label.minSpacing, label.minWidth] ¬ Maxin[label.minSpacing, label.minWidth, image.size.x, image.size.y];
vert => [label.minSpacing, label.minWidth] ¬ Maxin[label.minSpacing, label.minWidth, image.size.y, image.size.x];
ENDCASE => ERROR;
ENDLOOP;
};
PUSImageList: TYPE = LIST OF PUS.Image;
ImageLabel: TYPE = REF ImageLabelPrivate;
ImageLabelPrivate: TYPE = RECORD [
dim: Dim,
images: PUSImageList
];
Dim: TYPE = {horiz, vert};
DrawLabel: PROC [context: Imager.Context, org: Imager.VEC, n, spacing, width: NAT, data: REF ANY] = {
il: ImageLabel = NARROW[data];
offset: Imager.VEC = SELECT il.dim FROM
horiz => [0, 0],
vert => [-width, -spacing],
ENDCASE => ERROR;
dOrg: Imager.VEC = SELECT il.dim FROM
horiz => [spacing, 0],
vert => [0, -spacing],
ENDCASE => ERROR;
bounds: Imager.Rectangle ¬ SELECT il.dim FROM
horiz => [0, 0, spacing, width],
vert => [0, 0, width, spacing],
ENDCASE => ERROR;
org ¬ org.Add[offset];
FOR list: PUSImageList ¬ il.images, list.rest WHILE list # NIL AND n > 0 DO
image: PUS.Image = list.first;
bounds.x ¬ org.x;
bounds.y ¬ org.y;
image.Draw[image, context, bounds, [FALSE, FALSE, FALSE]];
org ¬ org.Add[dOrg];
n ¬ n - 1;
ENDLOOP;
};
ImageForRope: PUBLIC PROC [rope: ROPE, colors: Colors ¬ NIL, font: Imager.Font ¬ NIL, align: Align ¬ bottomLeft] RETURNS [image: Image] ~ {RETURN PUS.ImageForRope[rope, colors, font, align]};
QuaClass: PUBLIC PROC [ra: REF ANY] RETURNS [MaybeClass] ~ {
WITH ra SELECT FROM
x: Class => RETURN [[TRUE, x]];
ENDCASE => RETURN [[FALSE, NIL]]};
MakeClass: PUBLIC PROC [spec: ClassSpec] RETURNS [class: Class] = {
helpLen: NAT ~ IF spec.help#NIL AND spec.help.kind=none THEN 0 ELSE 1;
choicesLen: NAT ~ ChoiceListLength[spec.choices];
choices: PUS.ChoiceS = NEW [PUS.ChoiceSequence[helpLen + choicesLen]];
columns: NAT;
left, top: PUS.Label ¬ NIL;
i: NAT ¬ 0;
headImage: PUS.Image ¬ IF spec.image#NIL THEN QuaTransformed[spec.image].i ELSE NIL;
DO
m, n: NAT ¬ 1;
Times: PROC [k: NAT] = {m ¬ n; n ¬ n*k};
IF spec.decodeMouseButton THEN Times[3];
IF spec.decodeShift THEN Times[2];
IF spec.decodeControl THEN Times[2];
IF choicesLen > m OR n = 1 THEN EXIT;
IF spec.decodeControl THEN spec.decodeControl ¬ FALSE
ELSE IF spec.decodeShift THEN spec.decodeShift ¬ FALSE
ELSE IF spec.decodeMouseButton THEN spec.decodeMouseButton ¬ FALSE
ELSE ERROR;
ENDLOOP;
IF helpLen=1 THEN {
choices[i] ¬ [helpImage, helpDoc];
i ¬ i + 1;
};
FOR cl: ChoiceList ¬ spec.choices, cl.rest WHILE cl # NIL DO
IF cl.first = nullChoice THEN choices[i] ¬ PUS.nullChoice
ELSE {
image: Image ¬ cl.first.image;
IF image = NIL THEN image ¬ PUS.ImageForRope[KeyText[cl.first.key]];
choices[i] ¬ [
image: image,
doc: cl.first.doc];
IF headImage=NIL THEN headImage ¬ choices[i].image;
};
i ¬ i + 1;
ENDLOOP;
SELECT TRUE FROM
spec.decodeMouseButton AND (spec.decodeShift OR spec.decodeControl) => {
columns ¬ 3;
top ¬ topMouse;
left ¬ SELECT TRUE FROM
spec.decodeShift AND spec.decodeControl => leftCtlShf,
spec.decodeShift => leftShf,
spec.decodeControl => leftCtl,
ENDCASE => ERROR;
};
spec.decodeMouseButton => {
columns ¬ 1;
left ¬ leftMouse;
};
spec.decodeShift AND spec.decodeControl => {
columns ¬ 2;
top ¬ topShf;
left ¬ leftCtl;
};
ENDCASE => {
columns ¬ 1;
left ¬ IF spec.decodeShift THEN leftShf ELSE IF spec.decodeControl THEN leftCtl ELSE NIL;
};
class ¬ NEW [ClassPrivate ¬ [
spec: spec,
menu: PUS.Create[choices: choices, doc: spec.doc, allMayBeUp: FALSE, header: IF spec.headMenu THEN headImage ELSE NIL, left: left, top: top, fullRows: helpLen, columns: columns],
wDir: MDP.GetWDir[],
helpCount: helpLen,
choiceCount: choicesLen
]];
};
GetSpec: PUBLIC PROC [class: Class] RETURNS [spec: ClassSpec] = {
spec ¬ class.spec};
AmbushClass: PUBLIC PROC [class: Class, spec: ClassSpec] = {
class­ ¬ MakeClass[spec]­;
};
KeyText: PROC [key: REF ANY] RETURNS [text: ROPE] = {
WITH key SELECT FROM
rt: REF TEXT => text ¬ Rope.FromRefText[rt];
r: ROPE => text ¬ r;
a: ATOM => text ¬ Atom.GetPName[a];
ri: REF INT => text ¬ Convert.RopeFromInt[ri­];
ri: REF INTEGER => text ¬ Convert.RopeFromInt[ri­];
ri: REF NAT => text ¬ Convert.RopeFromInt[ri­];
rc: REF CARDINAL => text ¬ Convert.RopeFromCard[rc­];
rc: REF LONG CARDINAL => text ¬ Convert.RopeFromCard[rc­];
rr: REF REAL => text ¬ Convert.RopeFromReal[rr­];
l: LORA => {
text ¬ NIL;
FOR rs: LORA ¬ l, rs.rest WHILE rs # NIL DO
IF text # NIL THEN text ¬ text.Concat[", "];
text ¬ text.Concat[KeyText[rs.first]];
ENDLOOP;
};
l: ROPEList => {
text ¬ NIL;
FOR rs: ROPEList ¬ l, rs.rest WHILE rs # NIL DO
IF text # NIL THEN text ¬ text.Concat[", "];
text ¬ text.Concat[rs.first];
ENDLOOP;
};
l: ATOMList => {
text ¬ NIL;
FOR rs: ATOMList ¬ l, rs.rest WHILE rs # NIL DO
IF text # NIL THEN text ¬ text.Concat[", "];
text ¬ text.Concat[Atom.GetPName[rs.first]];
ENDLOOP;
};
ENDCASE => ERROR;
};
ChoicesDocs: PROC [choices: ChoiceList] RETURNS [ropes: ROPEList] = {
tail: ROPEList ¬ ropes ¬ NIL;
FOR choices ¬ choices, choices.rest WHILE choices # NIL DO
this: ROPEList = LIST[choices.first.doc];
IF tail # NIL THEN tail.rest ¬ this ELSE ropes ¬ this;
tail ¬ this;
ENDLOOP;
ropes ¬ ropes;
};
ChoiceListLength: PROC [list: ChoiceList] RETURNS [length: NAT ¬ 0] = {
FOR list ¬ list, list.rest WHILE list # NIL DO length ¬ length + 1 ENDLOOP;
};
defaultFont: PUBLIC Imager.Font ¬ VFonts.DefaultFont[NIL];
defaultColors: PUBLIC Colors ¬ PUS.defaultColors;
inverseColors: PUBLIC Colors ¬ PUS.inverseColors;
QuaRopeImage: PUBLIC PROC [i: Image] RETURNS [MaybeRope] ~ {
xfm: Imager.Transformation;
[[, i, xfm]] ¬ QuaTransformed[i];
WITH i.data SELECT FROM
ri: RopeImage => RETURN [[TRUE, ri.text, ri.colors, ri.font, ri.align, xfm]];
ENDCASE => RETURN [[FALSE, NIL, NIL, NIL, [-1.0, -1.0], NIL]]};
TransformedImage: TYPE ~ REF TransformedImagePrivate;
TransformedImagePrivate: TYPE ~ RECORD [i: Image, t: Imager.Transformation];
TransformImage: PUBLIC PROC [i: Image, t: Imager.Transformation] RETURNS [Image] ~ {
ti: TransformedImage ~ NEW [TransformedImagePrivate ¬ [i, t]];
tr: Imager.Rectangle ~ t.TransformRectangle[[0, 0, i.size.x, i.size.y]];
RETURN [NEW [ImagePrivate ¬ [size: [tr.w, tr.h], Draw: DrawTransformed, data: ti]]]};
QuaTransformed: PUBLIC PROC [gi: Image] RETURNS [MaybeTransformed] ~ {
WITH gi.data SELECT FROM
ti: TransformedImage => RETURN [[TRUE, ti.i, ti.t]];
ENDCASE => RETURN [[FALSE, gi, idTransform]]};
DrawTransformed: PROC [image: Image, context: Imager.Context, bounds: Imager.Rectangle, state: VisibleState] ~ {
ti: TransformedImage ~ NARROW[image.data];
tBounds: Imager.Rectangle ~ ti.t.InverseTransformRectangle[bounds];
DoSaved: PROC ~ {
context.ConcatT[ti.t];
ti.i.Draw[ti.i, context, tBounds, state];
RETURN};
context.DoSave[DoSaved];
RETURN};
helpFont: ImagerFont.Font ¬ ImagerFont.Find["Xerox/TiogaFonts/Tioga10I"];
helpImage: PUS.Image ¬ PUS.ImageForRope[rope: "Help", font: helpFont, align: center];
helpDoc: ROPE ¬ "Click here for more documentation (if you're lucky)";
Instantiate: PUBLIC PROC
[class: Class,
viewerInfo: ViewerClasses.ViewerRec ¬ [],
instanceData: REF ANY ¬ NIL,
image: Image ¬ NIL,
help: Help ¬ NIL,
paint: BOOL ¬ TRUE]
RETURNS [button: Viewer] = {
specdImage: Image ~ image;
specdHelp: Help ~ help;
bordW: NAT ~ IF viewerInfo.border THEN 2*ViewerSpecs.windowBorderSize ELSE 0;
inst: Instance ~ NEW [InstancePrivate ¬ [
spec: [class, instanceData, viewerInfo.name, specdImage, NIL, specdHelp, NIL, GetInerhitedProcessProps[]],
packageGlobalFrame: NIL,
state: IF class.spec.guarded THEN guarded ELSE armed,
Paint: ViewerPaintButton,
InTest: InViewer
]];
inst.packageGlobalFrame ¬ MDP.GetCaller2sGlobalFrame[];
image ¬ inst.spec.image ¬ ComputeImage[image, class, inst.spec.name];
IF viewerInfo.name = NIL THEN viewerInfo.name ¬ inst.spec.name ¬ QuaRopeImage[image].rope;
IF viewerInfo.ww=0 THEN viewerInfo.ww ¬ Real.Round[image.size.x + bordW];
IF viewerInfo.wh=0 THEN viewerInfo.wh ¬ Real.Round[image.size.y + bordW];
IF viewerInfo.parent = NIL AND viewerInfo.wx=0 AND viewerInfo.wy=0 THEN {
taken from ButtonsImpl.mesa
[viewerInfo.wx, viewerInfo.wy, viewerInfo.ww, viewerInfo.wh] ¬ MessageWindowBackdoor.AllocateStaticArea[viewerInfo.ww];
viewerInfo.column ¬ static;
viewerInfo.spare5 ¬ TRUE; -- mark as top row
};
viewerInfo.data ¬ inst;
RETURN[ViewerOps.CreateViewer[$PopUpButton, viewerInfo, paint]];
};
GeneralInstantiate: PUBLIC PROC [class: Class, Paint: PaintProc, InTest: InTestProc, name: ROPE ¬ NIL, instanceData: REF ANY ¬ NIL, image: Image ¬ NIL, help: Help ¬ NIL] RETURNS [Instance] = {
specdImage: Image ~ image;
specdHelp: Help ~ help;
inst: Instance ~ NEW [InstancePrivate ¬ [
spec: [class, instanceData, name, specdImage, NIL, specdHelp, NIL, GetInerhitedProcessProps[]],
packageGlobalFrame: MDP.GetCaller2sGlobalFrame[],
state: IF class.spec.guarded THEN guarded ELSE armed,
Paint: Paint,
InTest: InTest
]];
image ¬ inst.spec.image ¬ ComputeImage[image, class, name];
IF name = NIL THEN inst.spec.name ¬ QuaRopeImage[image].rope;
RETURN[inst]};
DefaultSize: PUBLIC PROC [viewerName: ROPE ¬ NIL, class: Class ¬ NIL, image: Image ¬ NIL, border: BOOL ¬ TRUE] RETURNS [ww, wh: INTEGER] ~ {
bordW: NAT ~ IF border THEN 2*ViewerSpecs.windowBorderSize ELSE 0;
image ¬ ComputeImage[image, class, viewerName];
ww ¬ Real.Round[image.size.x + bordW];
wh ¬ Real.Round[image.size.y + bordW];
};
ComputeImage: PROC [specdImage: Image, class: Class, viewerName: ROPE] RETURNS [use: Image] ~ {
use ¬ specdImage;
IF use=NIL AND class#NIL THEN use ¬ class.spec.image;
IF use=NIL AND viewerName#NIL THEN use ¬ PUS.ImageForRope[viewerName];
IF use=NIL AND class#NIL AND class.spec.choices#NIL THEN {
use ¬ IF class.spec.choices.first.image # NIL THEN class.spec.choices.first.image ELSE PUS.ImageForRope[KeyText[class.spec.choices.first.key]];
};
IF use=NIL THEN use ¬ PUS.ImageForRope["The turkey client didn't specify an image for this button"];
};
UnionHelp: PUBLIC PROC [a, b: Help] RETURNS [Help] ~ {
hu: REF HelpUnion ~ NEW [HelpUnion ¬ [a, b]];
IF a.kind=none THEN RETURN [b];
IF b.kind=none THEN RETURN [a];
RETURN [NEW [HelpPrivate[proc] ¬ [proc[UnionHelpProc, hu]]]]};
HelpUnion: TYPE ~ RECORD [a, b: Help];
UnionHelpProc: PROC [view: View, instSpec: InstanceSpec, data: REF ANY] --HelpProc-- ~ {
hu: REF HelpUnion ~ NARROW[data];
DoHelp[view, instSpec, hu.a];
DoHelp[view, instSpec, hu.b];
RETURN};
GetHelp: PROC [inst: Instance] RETURNS [help: Help] ~ {
IF inst.spec.help#NIL THEN RETURN [inst.spec.help];
IF inst.spec.specdHelp#NIL THEN RETURN [inst.spec.help ¬ inst.spec.specdHelp];
IF inst.spec.class.spec.help#NIL THEN RETURN [inst.spec.help ¬ inst.spec.class.spec.help];
IF inst.packageName=NIL THEN inst.packageName ¬ GuessPackageName[inst.packageGlobalFrame];
IF inst.packageName.Length[] # 0 THEN {
fileName: ROPE ~ Rope.Concat[inst.packageName, "Doc.Tioga"];
IF MDP.GetFullFilename[fileName, inst.spec.class.wDir].full#NIL THEN {
RETURN [inst.spec.help ¬ NEW [HelpPrivate[docs] ¬ [docs[LIST[[fileName, NIL]]]]]];
};
};
RETURN [inst.spec.help ¬ noHelp];
};
DeduceHelp: PUBLIC PROC [buttonName, installationDir, clientPackageName: ROPE ¬ NIL, clientPackageGlobalFrame: POINTER ¬ NIL] RETURNS [Help] ~ {
IF clientPackageName=NIL AND clientPackageGlobalFrame#NIL THEN clientPackageName ¬ GuessPackageName[clientPackageGlobalFrame];
IF clientPackageName.Length#0 THEN {
fileName: ROPE ~ Rope.Concat[clientPackageName, "Doc.Tioga"];
really: ROPE ~ MDP.GetFullFilename[fileName, installationDir].ohneVersion;
IF really#NIL THEN RETURN [NEW [HelpPrivate[docs] ¬ [docs[LIST[[really, NIL]]]]]];
};
RETURN [noHelp]};
QuaInstance: PUBLIC PROC [ra: REF ANY] RETURNS [MaybeInstance] ~ {
WITH ra SELECT FROM
x: Instance => RETURN [[TRUE, x]];
ENDCASE => RETURN [[FALSE, NIL]]};
ViewerQuaInstance: PUBLIC PROC [v: Viewer] RETURNS [MaybeInstance] ~ {
WITH v.data SELECT FROM
x: Instance => RETURN [[TRUE, x]];
ENDCASE => RETURN [[FALSE, NIL]]};
InstanceToSpec: PUBLIC PROC [inst: Instance] RETURNS [InstanceSpec]
~ {RETURN [inst.spec]};
ViewerToSpec: PUBLIC PROC [button: Viewer] RETURNS [is: InstanceSpec] = {
inst: Instance = NARROW[button.data];
[] ¬ GetHelp[inst];
is ¬ inst.spec;
};
InstanceToState: PUBLIC PROC [inst: Instance] RETURNS [VisibleState] ~ {
RETURN [[inst.highlight, inst.executingCount > 0, inst.state # armed]]};
AmbushGeneralInstance: PUBLIC PROC [view: View, inst: Instance, class: Class ¬ NIL, instanceData: REF ANY ¬ NIL, image: Image ¬ NIL, help: Help ¬ NIL, specInstanceData, specImage, specHelp, specProcessProps: BOOL ¬ FALSE, paint: BOOL ¬ TRUE] ~ {
IF class # NIL THEN inst.spec.class ¬ class;
IF specInstanceData OR instanceData # NIL THEN inst.spec.instanceData ¬ instanceData;
IF specImage OR image # NIL THEN inst.spec.specdImage ¬ image;
IF specHelp OR help # NIL THEN inst.spec.specdHelp ¬ help;
IF specProcessProps THEN inst.spec.processProps ¬ GetInerhitedProcessProps[];
inst.spec.image ¬ ComputeImage[inst.spec.specdImage, inst.spec.class, inst.spec.name];
inst.spec.help ¬ NIL;
IF paint THEN PaintButton[view, NIL, inst];
};
GetInerhitedProcessProps: PROC RETURNS [inherited: PropList] = {
inherited ¬ NIL;
FOR props: PropList ¬ ProcessProps.GetPropList[], props.rest WHILE props # NIL DO
SELECT props.first.key FROM
$EvalHead, $CommanderHandle => NULL;
$WorkingDirectory => inherited ¬ List.PutAssoc[props.first.key, props.first.val, inherited];
ENDCASE => unrecognized ¬ List.PutAssoc[props.first.key, props.first.val, unrecognized];
ENDLOOP;
inherited ¬ inherited;
};
unrecognized: PropList ¬ NIL;
ButtonPaint: PROC [self: Viewer, context: Imager.Context, whatChanged: REF, clear: BOOL] RETURNS [quit: BOOL ¬ FALSE] --ViewerClasses.PaintProc-- = {
inst: Instance ~ NARROW[self.data];
IF inst # NIL THEN {
image: Image ~ inst.spec.image;
state: VisibleState ¬ [
highlight: inst.highlight,
executing: inst.executingCount > 0,
guarded: inst.state # armed];
really: BOOL ¬ TRUE;
WITH whatChanged SELECT FROM
Decide: REF PaintDecider => [really, state] ¬ Decide[inst];
ENDCASE => NULL;
IF really THEN {
image.Draw[image, context, [0, 0, self.cw, self.ch], state];
context ¬ context}
ELSE self ¬ self; context ¬ context}
ELSE self ¬ self; RETURN};
RawNotify: PUBLIC ENTRY PROC [view: View, instance: Instance, actionQueue, action: REF ANY] = {
ENABLE UNWIND => NULL;
input: LIST OF REF ANY ~ MDP.MatchEvent[actionQueue, action];
InnerButtonNotify[view, input, instance];
RETURN};
ButtonNotify: ENTRY ViewerClasses.NotifyProc = {
ENABLE UNWIND => NULL;
IF self#NIL THEN {inst: Instance ~ NARROW[self.data]; InnerButtonNotify[self, input, inst]}
ELSE InnerButtonNotify[curView, input, curButt];
RETURN};
PaintButton: PROC [view: View, paintHint: ATOM, inst: Instance] = {
IF inst # NIL AND inst.Paint # NIL THEN {
inst.Paint[view, IF paintHint # $Increment THEN AlwaysPaint ELSE ConditionallyPaint, inst];
view ¬ view}
ELSE paintHint ¬ paintHint;
RETURN};
ConditionallyPaint: PROC [decisionData: REF ANY] RETURNS [paint: BOOL, state: VisibleState] ~ {
inst: Instance ~ NARROW[decisionData];
state ¬ [
highlight: inst.highlight,
executing: inst.executingCount > 0,
guarded: inst.state # armed];
IF inst.shownVS # state THEN {
inst.shownVS ¬ state;
paint ¬ TRUE}
ELSE paint ¬ FALSE;
RETURN};
AlwaysPaint: PROC [decisionData: REF ANY] RETURNS [paint: BOOL, state: VisibleState] ~ {
inst: Instance ~ NARROW[decisionData];
state ¬ [
highlight: inst.highlight,
executing: inst.executingCount > 0,
guarded: inst.state # armed];
inst.shownVS ¬ state;
paint ¬ TRUE;
RETURN};
ViewerPaintButton: PROC [view: View, Decide: PaintDecider, decisionData: REF ANY] --PaintProc-- ~ {
ViewerOps.PaintViewer[NARROW[view], client, FALSE, NEW [PaintDecider ¬ Decide]];
RETURN};
InnerButtonNotify: INTERNAL PROC [view: View, input: LIST OF REF ANY, inst: Instance] = {
ENABLE UNWIND => {
IF curButt # NIL THEN curButt.depressed ¬ curButt.highlight ¬ FALSE;
popOrDoc ¬ FALSE;
BROADCAST startCondition;
BROADCAST timeout;
InputFocus.ReleaseButtons[];
};
viewAsViewer: Viewer ~ WITH view SELECT FROM x: Viewer => x, ENDCASE => NIL;
button: Menus.MouseButton ¬ red;
shift, control: BOOL ¬ FALSE;
mouse: TIPUser.TIPScreenCoords ¬ NIL;
IF popping OR inst = NIL THEN RETURN;
FOR list: LIST OF REF ANY ¬ input, list.rest UNTIL list = NIL DO
WITH list.first SELECT FROM
x: ATOM => SELECT x FROM
$Blue => button ¬ blue;
$Control => control ¬ TRUE;
$Hit => {
IF inst # curButt THEN {
IF curButt#NIL AND curButt.depressed THEN ERROR;
curView ¬ view;
curButt ¬ inst;
};
IF inst.depressed THEN SELECT inst.state FROM
guarded => {
popOrDoc ¬ FALSE;
inst.depressed ¬ inst.highlight ¬ FALSE;
inst.state ¬ arming;
BROADCAST timeout;
InputFocus.ReleaseButtons[];
PaintButton[view, $Increment, inst];
TRUSTED {Process.Detach[FORK ArmButtonProc[inst, view]]};
IF inst.spec.class.spec.disarmMsg#NIL THEN ViewerPrivate.Document[inst.spec.class.spec.disarmMsg, viewAsViewer, inst.spec.instanceData, button, shift, control];
};
arming => NULL;
armed => {
popOrDoc ¬ FALSE;
inst.depressed ¬ inst.highlight ¬ FALSE;
IF inst.spec.class.spec.guarded THEN inst.state ¬ guarded;
BROADCAST timeout;
InputFocus.ReleaseButtons[];
PaintButton[view, $Increment, inst];
IF inst.spec.class.spec.disableDecoding THEN TRUSTED {Process.Detach[FORK Bitch["Quick-clicking of this button disabled; down-click and hold to get menu"]]}
ELSE IF inst.spec.class.spec.fork THEN TRUSTED {Process.Detach[FORK ButtonPusher[view, inst, firstChoice+inst.spec.class.helpCount, TRUE]]}
ELSE ButtonPusher[view, inst, firstChoice+inst.spec.class.helpCount, FALSE];
};
ENDCASE => ERROR;
};
$Mark => IF ~inst.depressed
THEN {
IF curButt#NIL AND curButt.depressed THEN ERROR;
popOrDoc ¬ inst.state = armed;
curView ¬ view;
curButt ¬ inst;
firstChoice ¬ Decode[inst, button, shift, control];
NOTIFY startCondition;
inst.depressed ¬ TRUE;
inst.highlight ¬ (firstChoice < inst.spec.class.choiceCount AND IthChoice[inst.spec.class.spec.choices, firstChoice] # nullChoice) OR inst.spec.class.choiceCount = 0;
InputFocus.CaptureButtons[ButtonNotify, buttonClass.tipTable, viewAsViewer];
PaintButton[view, $Increment, inst];
}
ELSE {
stillInButton: BOOL;
IF inst # curButt THEN ERROR;
stillInButton ¬ inst.InTest[view, mouse];
IF stillInButton THEN RETURN;
popOrDoc ¬ FALSE;
inst.depressed ¬ inst.highlight ¬ FALSE;
BROADCAST timeout;
InputFocus.ReleaseButtons[];
PaintButton[view, $Increment, inst];
};
$Red => button ¬ red;
$Shift => shift ¬ TRUE;
$Yellow => button ¬ yellow;
ENDCASE => NULL;
z: TIPUser.TIPScreenCoords => mouse ¬ z;
ENDCASE => ERROR;
ENDLOOP;
};
InViewer: PROC [view: View, coords: TIPUser.TIPScreenCoords] RETURNS [in: BOOL] --InTestProc-- ~ {
viewer: Viewer ~ NARROW[view];
vIn: Viewer;
[vIn, in] ¬ ViewerOps.MouseInViewer[coords];
in ¬ in AND vIn=viewer;
RETURN};
armingTime: Process.Milliseconds ¬ 100; -- cover removal time.
armedTime: Process.Milliseconds ¬ 5000; -- unguarded interval.
ArmButtonProc: ENTRY PROC [inst: Instance, view: View] = {
assert: state=arming
ButtonWait[inst, armingTime];
IF inst.state = arming THEN {
inst.state ¬ armed;
PaintButton[view, $Increment, inst];
ButtonWait[inst, armedTime];
};
IF inst.state # guarded THEN {
inst.state ¬ guarded;
PaintButton[view, $Increment, inst];
};
};
ButtonWait: INTERNAL PROC[inst: Instance, ticks: Process.Milliseconds] = TRUSTED {
buttonWaitCondition: CONDITION;
Process.SetTimeout[LONG[@buttonWaitCondition], Process.MsecToTicks[ticks]];
WAIT buttonWaitCondition;
};
Monitor Invariant:
inst.depressed for only one inst, which = curButt.
curButt.depressed <=> CapturedButtons[curView].
curButt.highlight = (curButt.depressed & (no choices OR firstChoice interesting)).
popOrDoc => curButt.depressed.
Monitored data:
popOrDoc: BOOL ¬ FALSE; --do we want to (pop or MessageWindow[help])?
popping: BOOL ¬ FALSE; --are we popping up a menu?
curView: View ¬ NIL;
curButt: Instance ¬ NIL;
--also anyInstance.depressed, anyInstance.highlight, and anyInstance.state--
firstChoice: NAT ¬ 0; --what's coded by shift keys when button "entered".
startCondition: CONDITION;
timeout: CONDITION;
timeoutMSec: NAT ¬ 0;
desiredTimeoutMSec: NAT ¬ 400;
FullInst: TYPE = REF FullInstPrivate;
FullInstPrivate: TYPE = RECORD [v: View, i: Instance];
Popper: PROC = {
x: INT ¬ 1;
do: {Pop, Msg} ¬ Pop;
msg: ROPE;
fi: FullInst ¬ NIL;
default: NAT ¬ 0;
WaitToPop: ENTRY PROC = {
ENABLE UNWIND => NULL;
DO
WHILE NOT popOrDoc DO WAIT startCondition ENDLOOP;
IF timeoutMSec # desiredTimeoutMSec THEN TRUSTED {Process.SetTimeout[@timeout, Process.MsecToTicks[timeoutMSec ¬ desiredTimeoutMSec]]};
WAIT timeout;
IF popOrDoc THEN {
popOrDoc ¬ FALSE;
IF curButt.spec.class.spec.choices = NIL
THEN {do ¬ Msg;
msg ¬ curButt.spec.class.spec.doc;
}
ELSE {do ¬ Pop;
popping ¬ TRUE;
curButt.depressed ¬ curButt.highlight ¬ FALSE;
InputFocus.ReleaseButtons[];
PaintButton[curView, $Increment, curButt];
fi ¬ NEW [FullInstPrivate ¬ [v: curView, i: curButt]];
default ¬ firstChoice + 1 + curButt.spec.class.helpCount;
};
RETURN;
}
ELSE x ¬ x;
ENDLOOP;
};
CedarProcess.SetPriority[excited];
DO
WaitToPop[];
SELECT do FROM
Pop => {
{ENABLE UNWIND => FinishPop[];
IF fi.i.spec.class.spec.fork THEN {
i: NAT;
[i,] ¬ PUS.Pop[menu: fi.i.spec.class.menu, default: default];
IF i > 0 THEN TRUSTED {Process.Detach[FORK ButtonPusher[fi.v, fi.i, i-1, TRUE]]};
}
ELSE {
[] ¬ PUS.Pop[menu: fi.i.spec.class.menu, default: default, InNotifier: ConsumeSelection, notifyData: fi];
};
};
FinishPop[];
};
Msg => MessageWindow.Append[msg, TRUE];
ENDCASE => ERROR;
ENDLOOP;
};
FinishPop: ENTRY PROC = {popping ¬ FALSE};
ConsumeSelection: PROC [i: INT, mb: MouseButton, data: REF ANY] = {
fi: FullInst = NARROW[data];
IF i > 0 THEN ButtonPusher[fi.v, fi.i, i-1, FALSE];
};
ForkPopper: PROC = TRUSTED {Process.Detach[FORK Popper[]]};
ButtonPusher: PROC [view: View, inst: Instance, i: NAT, forked: BOOL] = {
Doit: PROC = {
j: INT ~ i-inst.spec.class.helpCount;
choice: Choice ¬ nullChoice;
SELECT TRUE FROM
i=0 AND inst.spec.class.helpCount=1 => { -- try and print out help
IF view # NIL THEN { -- no help for non-viewer buttons (for now)
IF forked THEN GetAndDoHelp[view, inst]
ELSE TRUSTED {Process.Detach[FORK GetAndDoHelp[view, inst]]};
};
};
(j<inst.spec.class.choiceCount AND (choice ¬ IthChoice[inst.spec.class.spec.choices, j]) # nullChoice) OR inst.spec.class.choiceCount = 0 => {
inst.executingCount ¬ inst.executingCount + 1;
PaintButton[view, $Increment, inst];
IF forked THEN CedarProcess.SetPriority[normal];
inst.spec.class.spec.proc[view, inst.spec.instanceData, inst.spec.class.spec.classData, choice.key ! ABORTED => CONTINUE];
inst.executingCount ¬ MAX[inst.executingCount - 1, 0];
PaintButton[view, $Increment, inst];
};
ENDCASE => NULL;
};
ProcessProps.AddPropList[inst.spec.processProps, Doit];
};
GetAndDoHelp: PROC [view: View, inst: Instance] ~ {
CedarProcess.SetPriority[normal];
DoHelp[view, inst.spec, GetHelp[inst]];
RETURN};
Decode: PROC [inst: Instance, mouseButton: Menus.MouseButton, shift, control: BOOL] RETURNS [i: NAT] = {
IF inst.spec.class.choiceCount IN [0 .. 1] THEN RETURN [0];
{Add: PROC [base, digit: NAT] = INLINE {i ¬ i*base + digit};
decodeMouseButton: BOOL = inst.spec.class.spec.decodeMouseButton;
decodeShift: BOOL = inst.spec.class.spec.decodeShift;
decodeControl: BOOL = inst.spec.class.spec.decodeControl;
i ¬ IF decodeControl AND control THEN 1 ELSE 0;
IF decodeShift THEN Add[2, IF shift THEN 1 ELSE 0];
IF decodeMouseButton THEN Add[3, SELECT mouseButton FROM red => 0, yellow => 1, blue => 2, ENDCASE => ERROR];
}};
IthChoice: PROC [list: ChoiceList, i: NAT] RETURNS [ith: Choice] = {
IF list = NIL THEN RETURN [nullChoice];
THROUGH [0 .. i) DO list ¬ list.rest ENDLOOP;
ith ¬ list.first;
};
DoHelp: PUBLIC PROC [view: View, instSpec: InstanceSpec, help: Help] ~ {
WITH help SELECT FROM
x: REF HelpPrivate[none] => Bitch["Sorry, this button is helpless"];
x: REF HelpPrivate[docs] => {
FOR hl: HelpDocList ¬ x.docs, hl.rest WHILE hl # NIL DO
hd: HelpDocument ~ hl.first;
fullFileName: ROPE ~ MDP.GetFullFilename[hd.filename, instSpec.class.wDir].full;
usedViewers: RefTab.Ref ~ RefTab.Create[];
first: BOOL ¬ TRUE;
aDocViewer: Viewer ¬ NIL;
LookForFree: PROC RETURNS [found: BOOL] ~ {
v: Viewer ¬ aDocViewer;
DO
IF NOT usedViewers.Fetch[v].found THEN {aDocViewer ¬ v; RETURN [TRUE]};
v ¬ v.link;
IF v=NIL OR v=aDocViewer THEN EXIT;
ENDLOOP;
RETURN [FALSE];
};
SearchFor: PROC [rope: ROPE] ~ {
IF first THEN {
aDocViewer ¬ ViewerTools.FindExistingViewer[fullFileName];
IF aDocViewer=NIL THEN aDocViewer ¬ ViewerTools.MakeNewTextViewer[info: [name: fullFileName, file: fullFileName, iconic: FALSE, column: right]];
first ¬ FALSE;
}
ELSE {
IF NOT LookForFree[] THEN {
TEditSplit.Split[aDocViewer];
IF NOT LookForFree[] THEN ERROR;
Process.PauseMsec[splitMsec];
};
};
IF NOT usedViewers.Store[aDocViewer, $T] THEN ERROR;
IF aDocViewer.iconic THEN ViewerOps.OpenIcon[aDocViewer];
TEditSelection.FindRope[viewer: aDocViewer, rope: rope, word: TRUE, id: feedback];
Process.PauseMsec[settleMSec];
RETURN};
IF fullFileName.Length[] = 0 THEN {Bitch["Couldn't resolve file name hint %g", [rope[hd.filename]]]; LOOP};
IF hd.searches = NIL THEN {
target: ROPE ¬ instSpec.name;
IF target.Length[]=0 THEN target ¬ QuaRopeImage[instSpec.image].rope;
{stop: INT ¬ target.Length[];
WHILE stop > 0 AND target.Fetch[stop-1] IN [0C .. ' ] DO stop ¬ stop-1 ENDLOOP;
IF stop > 0 AND target.Fetch[stop-1]=': THEN stop ¬ stop-1;
{start: INT ¬ 0;
WHILE start < stop AND target.Fetch[start] IN [0C .. ' ] DO start ¬ start + 1 ENDLOOP;
IF stop > start THEN SearchFor[target.Substr[start: start, len: stop-start].Concat[":"]] ELSE Bitch["Couldn't determine what to search for in %g", [rope[hd.filename]]];
}}}
ELSE {
FOR ss: ROPEList ¬ hd.searches, ss.rest WHILE ss # NIL DO SearchFor[ss.first] ENDLOOP;
};
ENDLOOP;
};
x: REF HelpPrivate[proc] => x.Proc[view, instSpec, x.data];
ENDCASE => ERROR;
RETURN};
settleMSec: NAT ¬ 500;
splitMsec: NAT ¬ 100;
Bitch: PROC [msg: ROPE, parm: IO.Value ¬ [null[]]] ~ {
MessageWindow.Append[message: IO.PutFR1[msg, parm], clearFirst: TRUE];
MessageWindow.Blink[];
};
Ceiling: PROC [r: REAL] RETURNS [i: INT] = {
d: INT = Real.Fix[r]+1;
i ¬ Real.Fix[r-d]+d;
};
NoteProfile: PROC [reason: UserProfile.ProfileChangeReason] --UserProfile.ProfileChangedProc-- = {
n: INT = UserProfile.Number["PopUpButtons.Delay", 400];
desiredTimeoutMSec ¬ IF n IN [1 .. LAST[NAT]] THEN n ELSE 400;
};
buttonClass: ViewerClasses.ViewerClass ¬ NEW[ViewerClasses.ViewerClassRec ¬ [
paint: ButtonPaint,
notify: ButtonNotify,
tipTable: TIPUser.InstantiateNewTIPTable["PopUpButton.tip"],
cursor: bullseye
]];
MDP.SetTipTable[buttonClass.tipTable];
UserProfile.CallWhenProfileChanges[NoteProfile];
ViewerOps.RegisterViewerClass[$PopUpButton, buttonClass]; -- plug in to Viewers
TRUSTED {
Process.InitializeCondition[@startCondition, Process.SecondsToTicks[100]];
Process.InitializeCondition[@timeout, Process.MsecToTicks[timeoutMSec ¬ desiredTimeoutMSec]];
Process.EnableAborts[@timeout];
Process.EnableAborts[@startCondition];
};
ForkPopper[];
END.