PopUpButtonsImpl.mesa
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
DIRECTORY Atom, Basics, CedarProcess, Convert, Imager, ImagerBackdoor, ImagerColor, ImagerFont, ImagerTransformation, InputFocus, IO, List, MachineDependentPopping, Menus, MessageWindow, 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, ImagerColor, ImagerFont, ImagerTransformation, InputFocus, IO, List, MachineDependentPopping, MessageWindow, 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.Color ← ImagerColor.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 {
m: Viewer ~ ViewerPrivate.messageWindow;
ViewerOps.MoveViewer[m, m.wx, m.wy, m.ww-viewerInfo.ww, m.wh, FALSE];
viewerInfo.wx ← m.wx + m.ww;
viewerInfo.wy ← m.wy;
viewerInfo.wh ← m.wh;
viewerInfo.column ← static;
};
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 ~ inst.packageName.Cat["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 ~ clientPackageName.Cat["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
PROC [self: Viewer, input:
LIST
OF
REF
ANY]
--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};
msg: ROPE;
fi: FullInst ← NIL;
default: NAT;
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.PutFR[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.