<<>> <> <> <> <> <> <> <> <> DIRECTORY Buttons USING [Button, ButtonProc], ButtonsPrivate USING [ButtonData, ButtonDataRec, DisplayStyle], CedarProcess USING [SetPriority], ChoiceButtons, Containers USING [ChildXBound], Imager USING [black, Color, Font, MaskRectangleI, SetColor, SetFont, SetXYI, ShowRope, white], ImagerBackdoor USING [invert, MakeStipple], InputFocus USING [CaptureButtons, ReleaseButtons], Labels USING [Create, Label, Set], MessageWindowBackdoor, Process USING [Detach, Milliseconds, MsecToTicks, SetTimeout], Rope USING [ROPE, Equal], TIPUser USING [InstantiateNewTIPTable, TIPScreenCoords], VFonts USING [CharWidth, defaultFont, DefaultFont, Font, FontHeight, StringWidth], ViewerClasses USING [GetProc, GuardState, MouseButton, NotifyProc, PaintProc, PaintRectangle, SetProc, Viewer, ViewerClass, ViewerClassRec, ViewerRec], ViewerOps USING [AddProp, CreateViewer, DestroyViewer, EnumerateChildren, EnumProc, FetchProp, MouseInViewer, PaintViewer, RegisterViewerClass], ViewerPrivate USING [Document], ViewerTools USING [MakeNewTextViewer, SetContents, SetSelection]; ButtonsImpl: CEDAR MONITOR LOCKS data USING data: ButtonData IMPORTS CedarProcess, Containers, Imager, ImagerBackdoor, InputFocus, Labels, MessageWindowBackdoor, Process, Rope, TIPUser, VFonts, ViewerOps, ViewerPrivate, ViewerTools EXPORTS Buttons, ChoiceButtons = BEGIN OPEN Buttons, ButtonsPrivate, ChoiceButtons, ViewerClasses; <> bottomOffset: INTEGER = 2; guardOffset: INTEGER = 3; sideMargin: INTEGER = 3; extraHeight: INTEGER = 3; entryHeight: CARDINAL = 15; -- how tall to make each line of items entryHSpace: CARDINAL = 10; -- horizontal space between title and selections fudge: CARDINAL = 5; -- fudge factor so that the baselines of text viewers are aligned with <> on: ATOM = $WhiteOnBlack; off: ATOM = $BlackOnWhite; <> armingTime: Process.Milliseconds ¬ 100; -- cover removal time. armedTime: Process.Milliseconds ¬ 5000; -- unguarded interval. <> Create: PUBLIC PROC [info: ViewerRec ¬ [], proc: ButtonProc, clientData: REF ANY ¬ NIL, fork: BOOL ¬ FALSE, font: Imager.Font ¬ NIL, documentation: REF ANY ¬ NIL, guarded: BOOL ¬ FALSE, paint: BOOL ¬ TRUE] RETURNS [button: Button] = { data: ButtonData ¬ NEW[ButtonDataRec ¬ [proc: proc, font: VFonts.DefaultFont[font], clientData: clientData, documentation: documentation, fork: fork, guarded: guarded, state: IF guarded THEN guarded ELSE armed]]; IF info.ww=0 THEN info.ww ¬ VFonts.StringWidth[info.name, data.font]+sideMargin*2; IF info.wh=0 THEN info.wh ¬ VFonts.FontHeight[data.font]+extraHeight; IF info.parent=NIL AND info.wx=0 AND info.wy=0 THEN { [info.wx, info.wy, info.ww, info.wh] ¬ MessageWindowBackdoor.AllocateStaticArea[info.ww]; info.column ¬ static; info.spare5 ¬ TRUE; -- mark as top row }; info.data ¬ data; IF documentation#NIL THEN WITH documentation SELECT FROM doc: REF TEXT => NULL; doc: REF ButtonProc => NULL; doc: Rope.ROPE => NULL; ENDCASE => ERROR; -- not valid documentation RETURN[ViewerOps.CreateViewer[$Button, info, paint]]; }; buttonGrey: Imager.Color ~ ImagerBackdoor.MakeStipple[stipple: 001010B]; ButtonPaint: PaintProc = { data: ButtonData ~ NARROW[self.data]; margin: INTEGER ~ 1; x: INTEGER ~ margin-self.cx; y: INTEGER ~ margin-self.cy; w: INTEGER ~ self.ww-2*margin; h: INTEGER ~ self.wh-2*margin; <> IF data = NIL THEN RETURN; IF ISTYPE[whatChanged, PaintRectangle] THEN whatChanged ¬ NIL; IF whatChanged=NIL THEN { <> background: Imager.Color ¬ Imager.white; IF data.greyCount#0 THEN background ¬ buttonGrey ELSE SELECT data.displayStyle FROM blackOnWhite => background ¬ Imager.white; blackOnGrey => background ¬ buttonGrey; whiteOnBlack => background ¬ Imager.black; ENDCASE; IF clear AND background=Imager.white THEN NULL ELSE { Imager.SetColor[context, background]; Imager.MaskRectangleI[context, x, y, w, h]; }; Imager.SetColor[context, IF data.displayStyle=whiteOnBlack THEN Imager.white ELSE Imager.black]; Imager.SetXYI[context, x+sideMargin, y+bottomOffset]; Imager.SetFont[context, data.font]; Imager.ShowRope[context, self.name]; IF data.guarded AND data.state#armed THEN { Imager.MaskRectangleI[context, x, y+bottomOffset+guardOffset, w, 1]; }; }; IF whatChanged=$Invert OR data.inverted THEN { -- invert to indicate highlighting Imager.SetColor[context, ImagerBackdoor.invert]; Imager.MaskRectangleI[context, x, y, w, h]; IF whatChanged=$Invert THEN data.inverted ¬ ~data.inverted; }; }; ButtonNotify: NotifyProc = { data: ButtonData ¬ NARROW[self.data]; EntryButtonNotify[self, input, data]; }; EntryButtonNotify: ENTRY PROC [self: Viewer, input: LIST OF REF ANY, data: ButtonData] = { ENABLE UNWIND => InputFocus.ReleaseButtons[]; button: ViewerClasses.MouseButton ¬ red; shift, control: BOOL ¬ FALSE; mouse: TIPUser.TIPScreenCoords; IF data = 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; $Documentation => IF data.documentation#NIL THEN ViewerPrivate.Document[data.documentation, self, data.clientData, button, shift, control]; $Hit => IF data.inverted THEN SELECT data.state FROM guarded => { data.state¬arming; ViewerOps.PaintViewer[self, client, FALSE, $Invert]; InputFocus.ReleaseButtons[]; TRUSTED {Process.Detach[FORK ArmButtonProc[data, self]]}; IF data.documentation#NIL THEN -- post documentation ViewerPrivate.Document[data.documentation, self, data.clientData, button, shift, control]; }; arming=> NULL; -- no action armed=> { InputFocus.ReleaseButtons[]; ViewerOps.PaintViewer[self, client, FALSE, $Invert]; IF data.guarded THEN { data.state¬guarded; ViewerOps.PaintViewer[self, client]; }; IF data.fork THEN TRUSTED {Process.Detach[FORK ButtonPusher[self, data, data.proc, data.clientData, button, shift, control, TRUE]]} ELSE ButtonPusher[self, data, data.proc, data.clientData, button, shift, control, FALSE]; }; ENDCASE; $Mark => IF ~data.inverted THEN { InputFocus.CaptureButtons[ButtonNotify, buttonClass.tipTable, self]; ViewerOps.PaintViewer[self, client, FALSE, $Invert]; } ELSE { v: Viewer; c: BOOL; [v, c] ¬ ViewerOps.MouseInViewer[mouse]; IF v=self AND c THEN RETURN; ViewerOps.PaintViewer[self, client, FALSE, $Invert]; InputFocus.ReleaseButtons[]; }; $Red => button ¬ red; $Shift => shift ¬ TRUE; $Yellow => button ¬ yellow; ENDCASE => NULL; z: TIPUser.TIPScreenCoords => mouse ¬ z; ENDCASE => ERROR; ENDLOOP; }; ArmButtonProc: ENTRY PROC [data: ButtonData, button: Buttons.Button] = { <> IF data = NIL THEN RETURN; ButtonWait[data, armingTime]; IF data.state = arming THEN { data.state¬armed; ViewerOps.PaintViewer[button, client]; ButtonWait[data, armedTime]; }; IF data.state#guarded THEN { data.state¬guarded; ViewerOps.PaintViewer[button, client]; }; }; ButtonWait: INTERNAL PROC[data: ButtonData, ticks: Process.Milliseconds] = TRUSTED { buttonWaitCondition: CONDITION; Process.SetTimeout[LONG[@buttonWaitCondition], Process.MsecToTicks[ticks]]; WAIT buttonWaitCondition; }; ButtonPusher: PROC [button: Button, myData: ButtonData, proc: ButtonProc, data: REF ANY, mouseButton: ViewerClasses.MouseButton, shift, control, normalPriority: BOOL] = { IF myData = NIL THEN RETURN; myData.greyCount ¬ myData.greyCount + 1; IF myData.displayStyle#blackOnGrey THEN ViewerOps.PaintViewer[button, client]; IF normalPriority THEN CedarProcess.SetPriority[normal]; proc[button, data, mouseButton, shift, control ! ABORTED => CONTINUE]; myData.greyCount ¬ MAX[myData.greyCount - 1, 0]; IF myData.displayStyle#blackOnGrey THEN ViewerOps.PaintViewer[button, client]; }; ButtonGet: PRIVATE GetProc = { RETURN[self.name]; }; ButtonSet: PRIVATE SetProc = { IF op=NIL THEN self.name ¬ NARROW[data] ELSE WITH self.data SELECT FROM myData: ButtonData => SELECT data FROM $BlackOnWhite => { myData.greyCount ¬ MAX[myData.greyCount - 1, 0]; IF myData.greyCount <= 0 THEN myData.displayStyle ¬ blackOnWhite}; $WhiteOnBlack => { myData.greyCount ¬ MAX[myData.greyCount - 1, 0]; IF myData.greyCount <= 0 THEN myData.displayStyle ¬ whiteOnBlack}; $BlackOnGrey, $BlackOnGray => { myData.greyCount ¬ myData.greyCount + 1; myData.displayStyle ¬ blackOnWhite}; ENDCASE => ERROR; ENDCASE => RETURN; IF finalise THEN ViewerOps.PaintViewer[self, all]; }; Destroy: PUBLIC PROC [button: Button] = { ViewerOps.DestroyViewer[button]; }; ReLabel: PUBLIC PROC [button: Button, newName: Rope.ROPE, paint: BOOL ¬ TRUE] = { button.class.set[button, newName, paint]; }; SetDisplayStyle: PUBLIC PROC [button: Button, style: ATOM, paint: BOOL ¬ TRUE] = { button.class.set[button, style, paint, $DisplayStyle] }; <> <<>> DefaultDoesntExist: PUBLIC SIGNAL = CODE; ChoiceDoesntExist: PUBLIC SIGNAL = CODE; ButtonsCannotBeUpdated: PUBLIC SIGNAL = CODE; BuildEnumTypeSelection: PUBLIC PROC [viewer: ViewerClasses.Viewer, x, y: CARDINAL, title: ROPE, buttonNames: ButtonList, default: ROPE, borderOnButtons: BOOL, notifyClientProc: SelectionNotifierProc, permit: EnumPermissionProc, clientdata: REF ANY, style: StyleChoice, allInOneRow: BOOL, maxWidth: INTEGER] RETURNS [EnumTypeRef] = { foundDefault: BOOL ¬ FALSE; stateInfo: EnumTypeRef ¬ NEW[EnumTypeRec]; DefaultFound: PROC[currentName, defaultName: ROPE] RETURNS [BOOL] = { IF Rope.Equal[currentName, defaultName, FALSE] THEN RETURN [foundDefault ¬ TRUE] ELSE RETURN [FALSE]; }; BuildMenuSelection: PROC = { border: INTEGER ¬ 10; startButtons: CARDINAL; startX: INTEGER ¬ 0; -- keeps a running tally of where the next x position is tempButton: Buttons.Button; eachButton: ButtonList; stateInfo.type ¬ menuStyle; IF title # NIL THEN { titleLabel: Labels.Label¬ Labels.Create[[ name: title, parent: viewer, wx: x, wy: y, wh: entryHeight, border: FALSE ]]; startButtons ¬ titleLabel.wx + titleLabel.ww + entryHSpace; } ELSE startButtons ¬ x; startX ¬ startButtons; FOR eachButton ¬ buttonNames, eachButton.rest UNTIL eachButton = NIL DO IF ~allInOneRow THEN { IF startX + VFonts.StringWidth[eachButton.first, VFonts.defaultFont] + border >= maxWidth THEN { startX ¬ startButtons; stateInfo.nexty ¬ stateInfo.nexty + entryHeight; }; }; tempButton ¬ Create[info: [ name: eachButton.first, wx: startX, wy: stateInfo.nexty, <> wh: entryHeight, -- specify rather than defaulting so line is uniform parent: viewer, border: borderOnButtons ], proc: MenuSelectionProc, clientData: stateInfo ]; ViewerOps.AddProp[tempButton, $ChoiceButtons, stateInfo]; IF DefaultFound[eachButton.first, default] THEN { stateInfo.buttonOn ¬ tempButton; SetDisplayStyle[button: tempButton, style: on]; }; startX ¬ tempButton.wx + tempButton.ww; ENDLOOP; stateInfo.nextx ¬ startX; }; BuildFlipThru: PROC = { eachButton: ButtonList; titleButton: Buttons.Button; nextx: INTEGER ¬ x; IF title # NIL THEN { <> stateInfo.type ¬ flipThruWithTitle; titleButton ¬ Create[ info: [name: title, parent: viewer, wx: nextx, wy: y, wh: entryHeight, border: TRUE ], proc: FlipThruButtonProc, clientData: stateInfo ]; nextx ¬ titleButton.wx + titleButton.ww + 3; } ELSE stateInfo.type ¬ flipThruNoTitle; FOR eachButton ¬ buttonNames, eachButton.rest UNTIL (eachButton = NIL) OR DefaultFound[eachButton.first, default] DO -- do nothing ENDLOOP; <> IF title # NIL THEN stateInfo.flipLabel ¬ Labels.Create[[ name: eachButton.first, wx: nextx, wy: y, ww: MaxNameWidth[buttonNames], -- first find the longest name so we can set up the <> wh: entryHeight, parent: viewer, border: FALSE ]] ELSE stateInfo.flipLabel ¬ Create[ info: [name: eachButton.first, wx: nextx, wy: y, ww: MaxNameWidth[buttonNames], wh: entryHeight, parent: viewer, border: borderOnButtons ], proc: FlipThruButtonProc, clientData: stateInfo ]; stateInfo.nextx ¬ stateInfo.flipLabel.wx + stateInfo.flipLabel.ww; }; stateInfo.nextx ¬ x; stateInfo.nexty ¬ y; stateInfo.proc ¬ notifyClientProc; stateInfo.namesOfButtons ¬ buttonNames; stateInfo.clientdata ¬ clientdata; stateInfo.permission ¬ permit; IF default = NIL THEN <> default ¬ buttonNames.first; SELECT style FROM menuSelection => BuildMenuSelection; flipThru => BuildFlipThru; ENDCASE => ERROR; <> IF ~foundDefault THEN SIGNAL DefaultDoesntExist; stateInfo.nexty ¬ stateInfo.nexty + entryHeight; RETURN[stateInfo]; }; MenuSelectionProc: Buttons.ButtonProc = { viewer: ViewerClasses.Viewer ¬ NARROW[parent]; WITH clientData SELECT FROM info: EnumTypeRef => IF info.permission = NIL OR info.permission[info] THEN { SwitchButtons[info.buttonOn, viewer]; info.buttonOn ¬ viewer; <> IF info.proc # NIL THEN info.proc[viewer.name, info.clientdata]; }; ENDCASE; }; SwitchButtons: PRIVATE PROC[oldButton, newButton: Buttons.Button] = { <> <> SetDisplayStyle[button: oldButton, style: off]; <> SetDisplayStyle[button: newButton, style: on]; }; FlipThruButtonProc: Buttons.ButtonProc = { WITH clientData SELECT FROM info: EnumTypeRef => IF info.permission = NIL OR info.permission[info] THEN { IF mouseButton=red THEN <> ViewerTools.SetContents[viewer: info.flipLabel, contents: GetNextName[info.namesOfButtons, info.flipLabel.name]] ELSE <> ViewerTools.SetContents[viewer: info.flipLabel, contents: GetPrevName[info.namesOfButtons, info.flipLabel.name]]; <> IF info.proc # NIL THEN info.proc[info.flipLabel.name, info.clientdata]; }; ENDCASE; }; UpdateChoiceButtons: PUBLIC PROC [viewer: ViewerClasses.Viewer, enumTypeInfo: EnumTypeRef, newName: ROPE] = { newButton: Buttons.Button ¬ NIL; GetDesiredButton: ViewerOps.EnumProc = { IF (Rope.Equal[v.name, newName, FALSE]) AND (ViewerOps.FetchProp[v, $ChoiceButtons] = enumTypeInfo) THEN { newButton ¬ v; RETURN [FALSE]; }; }; IF enumTypeInfo = NIL THEN SIGNAL ButtonsCannotBeUpdated; SELECT enumTypeInfo.type FROM menuStyle => { ViewerOps.EnumerateChildren[viewer, GetDesiredButton]; IF newButton # NIL THEN { SwitchButtons[enumTypeInfo.buttonOn, newButton]; enumTypeInfo.buttonOn ¬ newButton; } ELSE SIGNAL ChoiceDoesntExist; }; flipThruWithTitle => Labels.Set[label: enumTypeInfo.flipLabel, value: newName]; flipThruNoTitle => ReLabel[button: enumTypeInfo.flipLabel, newName: newName]; ENDCASE => ERROR; }; GetSelectedButton: PUBLIC PROC [handle: EnumTypeRef] RETURNS [ROPE] = { IF handle.type = menuStyle THEN { IF handle.buttonOn = NIL THEN ERROR; RETURN [handle.buttonOn.name] } ELSE { IF handle.flipLabel = NIL THEN ERROR; RETURN[handle.flipLabel.name] }; }; GetNextName: PRIVATE PROC[listOfNames: ButtonList, currentName: ROPE] RETURNS [ROPE] = { eachButton: ButtonList ¬ listOfNames; WHILE (eachButton # NIL) AND (eachButton.first # currentName) DO eachButton ¬ eachButton.rest; ENDLOOP; IF eachButton = NIL THEN ERROR; -- This shouldn't happen; we should always be able to <> IF eachButton.rest = NIL THEN <> RETURN [listOfNames.first] ELSE RETURN [(eachButton.rest).first]; }; GetPrevName: PRIVATE PROC [listOfNames: ButtonList, currentName: ROPE] RETURNS [ROPE] = { prev: ROPE ¬ listOfNames.first; eachName: ChoiceButtons.ButtonList ¬ listOfNames.rest; WHILE (eachName # NIL) AND ~Rope.Equal[eachName.first, currentName, FALSE] DO prev ¬ eachName.first; eachName ¬ eachName.rest; ENDLOOP; RETURN[prev]; }; MaxNameWidth: PRIVATE PROC[listOfNames: ButtonList] RETURNS [CARDINAL] = { eachButton: ButtonList ¬ listOfNames; maxWidth: CARDINAL; IF eachButton # NIL THEN { maxWidth ¬ VFonts.StringWidth[string: eachButton.first, font: VFonts.defaultFont]; eachButton ¬ eachButton.rest } ELSE RETURN [0]; WHILE (eachButton # NIL) DO IF VFonts.StringWidth[string: eachButton.first, font: VFonts.defaultFont] > maxWidth THEN maxWidth ¬ VFonts.StringWidth[string: eachButton.first, font: VFonts.defaultFont]; eachButton ¬ eachButton.rest; ENDLOOP; maxWidth ¬ maxWidth + VFonts.CharWidth['M]; -- add on a little extra just to be sure RETURN[maxWidth]; }; BuildTriStateButton: PUBLIC PROC [viewer: ViewerClasses.Viewer, x,y: INTEGER, name: ROPE] RETURNS [stateInfo: ThreeStateRef, nextX: INTEGER] = { tempButton: Buttons.Button; stateInfo ¬ NEW[ThreeState]; tempButton ¬ Create[ info: [name: name, wx: x, wy: y, <> wh: entryHeight, -- specify rather than defaulting so line is uniform parent: viewer, border: TRUE ], proc: TriSwitchProc, clientData: stateInfo -- this will be passed to our button proc ]; stateInfo.button ¬ tempButton; nextX ¬ tempButton.wx + tempButton.ww + 4; }; SetButtonState: PUBLIC PROC [buttonSelected: Buttons.Button, state: StateType] = { SELECT state FROM on => SetDisplayStyle[button: buttonSelected, style: $WhiteOnBlack]; off => SetDisplayStyle[button: buttonSelected, style: $BlackOnWhite]; default => SetDisplayStyle[button: buttonSelected, style: $BlackOnGrey]; ENDCASE => ERROR; }; TriSwitchProc: Buttons.ButtonProc = { handle: ThreeStateRef ¬ NARROW[clientData]; state: StateType ¬ handle.state; handle.state ¬ state ¬ IF state = LAST[StateType] THEN FIRST[StateType] ELSE SUCC[state]; <> SetButtonState[handle.button, state]; }; BuildTextPrompt: PUBLIC PROC [viewer: ViewerClasses.Viewer, x,y: CARDINAL, title: ROPE, default: ROPE, font: VFonts.Font, textViewerWidth: INTEGER, clientdata: REF ANY, notify: SelectionNotifierProc, permit: PromptPermissionProc] RETURNS [promptData: PromptDataRef] = { container: BOOL ~ viewer.class # NIL AND viewer.class.flavor = $Container; buttonY: NAT ~ IF container THEN y+3 ELSE y; textY: NAT ~ IF container THEN y+1 ELSE y+2; height: INTEGER ¬ VFonts.FontHeight[font]; promptData ¬ NEW[PromptDataRec]; promptData.promptButton ¬ Create[info: [name: title, wx: x, wy: buttonY, wh: height, parent: viewer, border: FALSE], font: font, proc: PromptProc, clientData: promptData]; promptData.textViewer ¬ ViewerTools.MakeNewTextViewer [[ parent: viewer, wx: promptData.promptButton.wx + promptData.promptButton.ww + entryHSpace, wy: textY, ww: textViewerWidth, wh: height, name: title, -- give it the name of the prompt associated with it data: default, scrollable: FALSE, border: FALSE ]]; IF textViewerWidth = LAST[INTEGER] THEN { Containers.ChildXBound[viewer, promptData.textViewer]; promptData.newx ¬ LAST[INTEGER]; } ELSE promptData.newx ¬ promptData.textViewer.wx + promptData.textViewer.ww; IF default # NIL THEN ViewerTools.SetContents[promptData.textViewer, default]; promptData.clientdata ¬ clientdata; promptData.notify ¬ notify; promptData.permission ¬ permit; promptData.newy ¬ y + height; }; PromptProc: Buttons.ButtonProc = { viewer: ViewerClasses.Viewer ¬ NARROW[parent]; WITH clientData SELECT FROM handle: PromptDataRef => IF handle.permission = NIL OR handle.permission[handle] THEN SELECT TRUE FROM mouseButton=red => <> ViewerTools.SetSelection[handle.textViewer]; handle.notify # NIL => <> handle.notify[viewer.name, handle.clientdata]; ENDCASE; ENDCASE; }; <<>> <> buttonClass: ViewerClasses.ViewerClass ¬ NEW[ViewerClasses.ViewerClassRec ¬ [ paint: ButtonPaint, get: ButtonGet, set: ButtonSet, notify: ButtonNotify, tipTable: TIPUser.InstantiateNewTIPTable["Button.tip"], cursor: bullseye ]]; ViewerOps.RegisterViewerClass[$Button, buttonClass]; -- plug in to Viewers END.