XTkChoiceWidgetsImpl.mesa
Copyright Ó 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, February 22, 1989 7:53:06 pm PST
Christian Jacobi, October 1, 1992 9:47 pm PDT
DIRECTORY
Rope,
XTk,
XTkButtons,
XTkCollections,
XTkContainers,
XTkLabels,
XTkChoiceWidgets,
XTkFriends;
XTkChoiceWidgetsImpl: CEDAR MONITOR
IMPORTS Rope, XTkButtons, XTkCollections, XTkContainers, XTk, XTkFriends, XTkLabels
EXPORTS XTkChoiceWidgets =
BEGIN OPEN XTk, XTkChoiceWidgets;
myKey: REF ATOM = NEW[ATOM ¬ $choice];
choiceXClass: ImplementorClass ¬ XTkFriends.CreateClass[[key: $xchoice, wDataNum: 1, super: XTkContainers.xStack]];
choiceYClass: ImplementorClass ¬ XTkFriends.CreateClass[[key: $ychoice, wDataNum: 1, super: XTkContainers.yStack]];
toggleClass: ImplementorClass ¬ XTkFriends.CreateClass[[key: $toggle, wDataNum: 1, super: XTkButtons.buttonClass]];
CRec: TYPE = RECORD [
hitProc: XTk.WidgetNotifyProc,
originalStyle: ATOM,
registerData: REF ¬ NIL,
choices: ChoiceList ¬ NIL,
current: ChoiceList ¬ NIL,
selected: Widget ¬ NIL,
callData: REF ¬ NIL
];
ChoicesHitProc: XTk.WidgetNotifyProc = {
cRef: REF CRec ¬ NARROW[registerData];
cRef.callData ¬ callData;
IF cRef.selected=widget THEN RETURN;
IF cRef.selected#NIL THEN XTkLabels.SetStyleKey[cRef.selected, NIL, delayed];
cRef.selected ¬ widget;
XTkLabels.SetStyleKey[widget, $Gray1];
IF cRef.hitProc#NIL THEN
cRef.hitProc[widget: widget.parent, registerData: cRef.registerData, callData: callData, event: event];
};
Choose: PUBLIC PROC [widget: XTk.Widget, ce: ChoiceElement] = {
--does NOT call the hitproc
IF XTk.HasClass[widget, toggleClass]
THEN ChooseForToggle[widget, ce]
ELSE ChooseForChoice[widget, ce];
};
ChooseForChoice: PROC [widget: XTk.Widget, ce: ChoiceElement] = {
--does NOT call the hitproc
cRef: REF CRec ~ NARROW[XTkFriends.InstPart[widget, choiceYClass]];
c: ChoiceList ¬ FindChoice[cRef.choices, ce];
EachChild: XTkCollections.EachChildProc = {
IF c=XTk.GetWidgetProp[child, myKey] THEN {
cRef.selected ¬ child;
XTkLabels.SetStyleKey[child, $Gray1];
stop ¬ TRUE
};
};
IF c#NIL THEN {
IF cRef.selected#NIL THEN XTkLabels.SetStyleKey[cRef.selected, NIL, delayed];
XTkCollections.EnumerateChildren[widget, EachChild];
};
};
ChooseForToggle: PROC [widget: XTk.Widget, ce: ChoiceElement] = {
--does NOT call the hitproc
cRef: REF CRec ~ NARROW[XTkFriends.InstPart[widget, toggleClass]];
c: ChoiceList ¬ FindChoice[cRef.choices, ce];
IF c#NIL THEN {
cRef.current ¬ c;
XTkLabels.SetText[widget, cRef.current.first.text];
};
};
FindChoice: PROC [choices: ChoiceList, el: ChoiceElement] RETURNS [ChoiceList ¬ NIL] = {
Returns sub list starting with found choice
FOR c: ChoiceList ¬ choices, c.rest WHILE c#NIL DO
IF c.first=el THEN RETURN [c];
ENDLOOP;
IF el.text#NIL THEN
FOR c: ChoiceList ¬ choices, c.rest WHILE c#NIL DO
IF Rope.Equal[c.first.text, el.text] THEN RETURN [c];
ENDLOOP;
IF el.callData#NIL THEN
FOR c: ChoiceList ¬ choices, c.rest WHILE c#NIL DO
IF c.first.callData=el.callData THEN RETURN [c];
ENDLOOP;
};
CreateChoices: PUBLIC PROC [widgetSpec: WidgetSpec, choices: ChoiceList, horizontal: BOOL ¬ TRUE, hitProc: XTk.WidgetNotifyProc, registerData: REF, tq: XTk.TQ, style: StyleSpec] RETURNS [widget: ChoiceWidget] = {
cRef: REF CRec = NEW[CRec ¬ [hitProc: hitProc, registerData: registerData, originalStyle: style.styleKey, choices: choices]];
class: Class ¬ SELECT horizontal FROM TRUE => choiceXClass, FALSE => choiceYClass ENDCASE => ERROR;
IF choices=NIL THEN ERROR;
widgetSpec.class ¬ XTkFriends.InitClassField[widgetSpec.class, class];
widget ¬ XTkCollections.Create[widgetSpec];
XTkFriends.AssignInstPart[widget, class, cRef];
FOR c: ChoiceList ¬ choices, c.rest WHILE c#NIL DO
child: Widget;
style.styleKey ¬ cRef.originalStyle;
IF c.first.callData=NIL
THEN child ¬ XTkLabels.CreateLabel[text: c.first.text, style: style]
ELSE {
IF cRef.selected=NIL THEN {style.styleKey ¬ $Gray1};
child ¬ XTkButtons.CreateButton[text: c.first.text,
style: style,
hitProc: ChoicesHitProc, registerData: cRef, callData: c.first.callData, hitTQ: tq
];
IF cRef.selected=NIL THEN {
cRef.selected ¬ child; cRef.callData ¬ c.first.callData
};
};
XTk.PutWidgetProp[child, myKey, c];
XTkCollections.AddChildLR[widget, child]; --this is creation
ENDLOOP;
};
ToggleHitProc: XTk.WidgetNotifyProc = {
cRef: REF CRec ¬ NARROW[registerData];
curr: ChoiceList ¬ cRef.current;
ce: ChoiceElement;
IF curr=NIL OR curr.rest=NIL
THEN cRef.current ¬ cRef.choices
ELSE cRef.current ¬ curr.rest;
ce ¬ cRef.current.first;
XTkLabels.SetText[widget, ce.text];
IF cRef.hitProc#NIL THEN
cRef.hitProc[widget: widget, registerData: cRef.registerData, callData: ce.callData, event: event];
};
CreateToggle: PUBLIC PROC [widgetSpec: WidgetSpec, choices: ChoiceList, hitProc: XTk.WidgetNotifyProc, registerData: REF, tq: XTk.TQ, style: StyleSpec] RETURNS [widget: ChoiceWidget] = {
cRef: REF CRec = NEW[CRec ¬ [registerData: registerData, current: choices, choices: choices, hitProc: hitProc]];
IF choices=NIL THEN ERROR;
widgetSpec.class ¬ XTkFriends.InitClassField[widgetSpec.class, toggleClass];
widget ¬ XTkButtons.CreateButton[widgetSpec: widgetSpec, text: choices.first.text, hitProc: ToggleHitProc, registerData: cRef, hitTQ: tq];
XTkFriends.AssignInstPart[widget, toggleClass, cRef];
};
GetCRef: PROC [w: Widget] RETURNS [cRef: REF CRec] = {
SELECT w.s.class FROM
choiceXClass => RETURN [NARROW[XTkFriends.InstPart[w, choiceXClass]]];
choiceYClass => RETURN [NARROW[XTkFriends.InstPart[w, choiceYClass]]];
toggleClass => RETURN [NARROW[XTkFriends.InstPart[w, toggleClass]]];
ENDCASE => ERROR;
};
CurrentChoice: PUBLIC PROC [widget: Widget] RETURNS [REF ANY] = {
cRef: REF CRec ~ GetCRef[widget];
RETURN [cRef.callData];
};
IsChoice: PUBLIC PROC [w: XTk.Widget] RETURNS [BOOL] = {
IF w=NIL THEN RETURN [FALSE];
RETURN [w.s.class=choiceXClass OR w.s.class=choiceYClass OR w.s.class=toggleClass]
};
END.