DIRECTORY
TrcButtons,
Buttons USING [ButtonProc],
Menus USING [MouseButton],
TIPUser USING [InstantiateNewTIPTable],
Trc,
TrcViewers USING [CreateTRCViewer, InfoFromTRCViewer],
ViewerClasses USING [Viewer, ViewerRec],
ViewerOps USING [PaintViewer];
OPEN TrcButtons;
Create:
PUBLIC
PROC [trc: Trc.
TRC, rectangle: Trc.Rectangle, dx:
REAL, info: ViewerClasses.ViewerRec, proc: Buttons.ButtonProc, clientData:
REF ←
NIL, fork:
BOOL ←
TRUE, paint:
BOOL ←
TRUE]
RETURNS [button: ViewerClasses.Viewer] ~ {
instance: ButtonInstance ~ NEW[ButtonInstanceRep];
buttonTrc: Trc.TRC ~ NEW[Trc.TRCRep ← [class: buttonClass, instance: instance]];
info.data ← buttonTrc;
button ← TrcViewers.CreateTRCViewer[trc: buttonTrc, rectangle: rectangle, dx: dx, info: info];
instance^ ← [
trc: trc,
proc: proc,
clientData: clientData,
fork: fork,
listenerReg: Trc.InstallListener[trc: trc, listener: [proc: ButtonListener, listenerData: button]]
];
};
AttachNewTrcToButton:
PUBLIC
PROC [button: ViewerClasses.Viewer, trc: Trc.
TRC, paint:
BOOL ←
TRUE] ~ {
buttonTrc: Trc.TRC ~ TrcViewers.InfoFromTRCViewer[button].trc;
instance: ButtonInstance ~ NARROW[buttonTrc.instance];
Trc.DeinstallListener[registration: instance.listenerReg];
instance.trc ← trc;
instance.listenerReg ← Trc.InstallListener[trc: trc, listener: [proc: ButtonListener, listenerData: button]];
IF paint THEN ViewerOps.PaintViewer[viewer: button, hint: all];
};
TrcFromButton:
PUBLIC PROC [button: ViewerClasses.Viewer]
RETURNS [trc: Trc.
TRC] ~ {
buttonTrc: Trc.TRC ~ TrcViewers.InfoFromTRCViewer[button].trc;
instance: ButtonInstance ~ NARROW[buttonTrc.instance];
RETURN [instance.trc];
};
ButtonListener: Trc.ListenerProc = {
[trc: TRC, listenerData: REF ANY]
button: ViewerClasses.Viewer ~ NARROW[listenerData];
buttonTrc: Trc.TRC ~ NARROW[button.data];
instance: ButtonInstance ~ NARROW[buttonTrc.instance];
Trc.NotifyListeners[trc: buttonTrc, fork: instance.fork];
};
ButtonInstance:
TYPE ~
REF ButtonInstanceRep;
ButtonInstanceRep:
TYPE ~
RECORD [
trc: Trc.TRC,
proc: Buttons.ButtonProc,
clientData: REF ← NIL,
fork: BOOL ← TRUE,
listenerReg: REF ← NIL
];
ButtonFcn: Trc.Fcn = {
[trc: TRC, a: REAL] RETURNS [b: REAL]
instance: ButtonInstance ~ NARROW[trc.instance];
RETURN [Trc.ApplyFcn[instance.trc, a]];
};
ButtonBlockFcn: Trc.BlockFcn =
UNCHECKED {
[trc: TRC, from: Trc.UnsafeTable, to: Trc.UnsafeTable, count: NAT]
instance: ButtonInstance ~ NARROW[trc.instance];
Trc.ApplyBlockFcn[trc: instance.trc, from: from, to: to, count: count];
};
ButtonNotify: Trc.NotifyProc = {
[viewer: ViewerClasses.Viewer, trc: TRC, input: LIST OF REF ANY]
instance: ButtonInstance ~ NARROW[trc.instance];
control, shift: BOOL ← FALSE;
mouseButton: Menus.MouseButton ← red;
FOR each:
LIST
OF
REF
ANY ← input, each.rest
UNTIL each=
NIL
DO
WITH each.first
SELECT
FROM
token:
ATOM =>
SELECT token
FROM
$Control => control ← TRUE;
$Shift => shift ← TRUE;
$Red => mouseButton ← red;
$Yellow => mouseButton ← yellow;
$Blue => mouseButton ← blue;
$Hit => instance.proc[parent: viewer, clientData: instance.clientData, mouseButton: mouseButton, shift: shift, control: control];
ENDCASE;
ENDCASE;
ENDLOOP;
};
ButtonBackground: Trc.BackgroundProc = {
[trc: TRC, context: Imager.Context, rectangle: ImagerTransformation.Rectangle]
instance: ButtonInstance ~ NARROW[trc.instance];
Trc.PaintBackground[trc: instance.trc, context: context, rectangle: rectangle, whatChanged: $Button];
};
buttonClass: Trc.Class ~
NEW[Trc.ClassRep ← [
flavor: $Button,
fcn: ButtonFcn,
blockFcn: ButtonBlockFcn,
pickle: Trc.DefaultPickle,
depickle: Trc.DefaultDepickle,
notify: ButtonNotify,
tipTable: TIPUser.InstantiateNewTIPTable[file: "TrcButton.tip"],
background: ButtonBackground,
control: Trc.DefaultControl,
classData: NIL
]];