XTkScrollableContainersImpl:
CEDAR
MONITOR
IMPORTS Xl, XTk, XTkContainers, XTkScroller, XTkWidgets
EXPORTS XTkScrollableContainers ~ {
Widget: TYPE = XTk.Widget;
WidgetSpec: TYPE = XTk.WidgetSpec;
ContainerWidget: TYPE = XTkContainers.ContainerWidget;
ScrollableContainerWidget: TYPE = XTkScrollableContainers.ScrollableContainerWidget;
ScrollableContainerData: TYPE ~ REF ScrollableContainerDataRec;
ScrollableContainerDataRec:
TYPE ~
RECORD [
main: XTkContainers.ContainerWidget ¬ NIL,
container: XTkContainers.ContainerWidget ¬ NIL,
containerContainer: XTkContainers.ContainerWidget ¬ NIL,
scrollBar: XTkScroller.Scroller ¬ NIL,
height: INT ¬ Xl.dontUse,
currentTop: INT ¬ 0,
granularity: INT ¬ 1,
redrawData: REF,
redrawProc: XTkScrollableContainers.RedrawProc,
hiddenBar: BOOL ¬ FALSE
];
sampleScrollableContainerData: ScrollableContainerData ¬ NEW[ScrollableContainerDataRec];
ScrollableContainer : TYPE = Widget;
Create:
PUBLIC
PROC [widgetSpec: WidgetSpec ¬ [], height:
INT ¬ Xl.dontUse, granularity:
INT ¬ Xl.dontUse, redrawProc: XTkScrollableContainers.RedrawProc ¬
NIL, redrawData:
REF ¬
NIL]
RETURNS [scrollable: ScrollableContainerWidget] ~ {
addScroller: BOOL ¬ TRUE;
data: ScrollableContainerData ¬ NEW[ScrollableContainerDataRec];
data.redrawProc ¬ redrawProc;
data.redrawData ¬ redrawData;
data.granularity ¬
SELECT
TRUE
FROM
granularity = 0 => 1,
granularity = Xl.dontUse => 1,
granularity < 0 => ABS[granularity],
ENDCASE => granularity;
data.height ¬
SELECT
TRUE
FROM
height < widgetSpec.geometry.size.height => widgetSpec.geometry.size.height,
height = Xl.dontUse => widgetSpec.geometry.size.height,
ENDCASE => height;
IF data.height <= widgetSpec.geometry.size.height
THEN
addScroller ¬ FALSE;
data.container ¬ XTkContainers.CreateContainer[
widgetSpec: [
geometry: [
pos: [0, 0],
size: [widgetSpec.geometry.size.width - 12, data.height]
]
]
];
IF ~addScroller THEN data.hiddenBar ¬ TRUE;
data.containerContainer ¬ XTkContainers.CreateContainer[
widgetSpec: [
geometry: [
pos: [IF addScroller THEN 12 ELSE 0, 0],
size: [widgetSpec.geometry.size.width - 12, widgetSpec.geometry.size.height]
]
]
];
XTkWidgets.AppendChild[data.containerContainer, data.container];
data.container.attributes.bitGravity ¬ northWest;
data.container.attributes.winGravity ¬ northWest;
data.container.attributes.backingStore ¬ always;
data.container.attributes.saveUnder ¬ true;
IF addScroller
THEN {
data.scrollBar ¬ XTkScroller.CreateScroller[
widgetSpec: [
geometry: [
pos: [0, 0],
size: [12, widgetSpec.geometry.size.height]]
]];
XTkScroller.InteractiveRegistrations[data.scrollBar, ScrollProc, data];
XTk.PutWidgetProp[data.scrollBar, sampleScrollableContainerData, data];
};
data.main ¬ XTkContainers.CreateContainer[widgetSpec: widgetSpec];
IF addScroller
THEN
XTkWidgets.AppendChildren[data.main,LIST[data.scrollBar, data.containerContainer]]
ELSE
XTkWidgets.AppendChildren[data.main,LIST[data.containerContainer]];
IF addScroller
THEN
XTkScroller.SetState[data.scrollBar, [0.0, REAL[widgetSpec.geometry.size.height] / data.height]];
scrollable ¬ data.main;
XTkContainers.SetVaryingSize[scrollable];
XTk.PutWidgetProp[data.container, sampleScrollableContainerData, data];
XTk.PutWidgetProp[data.containerContainer, sampleScrollableContainerData, data];
XTk.PutWidgetProp[data.main, sampleScrollableContainerData, data];
XTk.RegisterNotifier[data.container, XTk.postConfigureKey, ReconfigureProc, data];
};
RegisterRedrawProc:
PUBLIC
PROC [widget: ContainerWidget, redrawProc: XTkScrollableContainers.RedrawProc, redrawData:
REF] ~ {
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[widget, sampleScrollableContainerData];
IF d = NIL THEN RETURN;
data ¬ NARROW[d];
data.redrawProc ¬ redrawProc;
data.redrawData ¬ redrawData;
};
ReconfigureProc: XTk.WidgetNotifyProc ~ {
data: ScrollableContainerData ¬ NARROW[registerData];
IF data.redrawProc #
NIL
THEN
data.redrawProc[data.redrawData];
};
ContainerFromScrollable:
PUBLIC
PROCEDURE [scrollable: ScrollableContainerWidget]
RETURNS [container: ContainerWidget] ~ {
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[scrollable, sampleScrollableContainerData];
IF d = NIL THEN RETURN;
data ¬ NARROW[d];
RETURN[data.container];
};
SetGranularity:
PUBLIC
PROCEDURE [widget: ContainerWidget, granularity:
INT] ~ {
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[widget, sampleScrollableContainerData];
offBy: INT;
IF d = NIL THEN RETURN;
data ¬ NARROW[d];
data.granularity ¬
SELECT
TRUE
FROM
granularity = 0 => 1,
granularity = Xl.dontUse => 1,
granularity < 0 => ABS[granularity],
ENDCASE => granularity;
offBy ¬ data.currentTop MOD granularity;
IF data.currentTop - offBy >= 0
THEN
Scroll[widget, -offBy];
};
FixState:
PROCEDURE [data: ScrollableContainerData] ~ {
newState: XTkScroller.State;
newState.start ¬ REAL[data.currentTop] / REAL[data.height];
newState.next ¬ newState.start + REAL[data.containerContainer.actual.size.height] / REAL[data.height];
this doesn't work...it moves data.container left, but the scroller won't move.
this is here to hide the scrollbar, when there is no scrolling to do.
IF newState = [0, 1]
AND ~data.hiddenBar
THEN {
gScroller: Xl.Geometry ← data.scrollBar.actual;
gContainer: Xl.Geometry ¬ data.container.s.geometry;
gScroller.pos.x ← gScroller.pos.x - 15;
gContainer.pos.x ¬ gContainer.pos.x - 15;
data.scrollBar.s.geometry ← gScroller;
data.container.s.geometry ¬ gContainer;
data.hiddenBar ¬ TRUE;
XTkWidgets.RemoveChild[data.main, data.scrollBar];
XTk.NoteAndStartReconfigure[data.container];
XTk.ShallowInternalEnumerateChildren[data.container, ExposeSend];
data.scrollBar ¬ NIL;
IF data.redrawProc #
NIL
THEN
data.redrawProc[data.redrawData];
}
ELSE
IF newState # [0, 1]
AND data.hiddenBar
THEN {
gScroller: Xl.Geometry ← data.scrollBar.actual;
gContainer: Xl.Geometry ¬ data.container.s.geometry;
gScroller.pos.x ← gScroller.pos.x + 15;
gContainer.pos.x ¬ gContainer.pos.x + 15;
data.scrollBar.s.geometry ← gScroller;
data.container.s.geometry ¬ gContainer;
data.hiddenBar ¬ FALSE;
data.scrollBar ¬ XTkScroller.CreateScroller[
widgetSpec: [
geometry: [
pos: [0, 0],
size: [12, data.main.actual.size.height]]
]];
XTkScroller.InteractiveRegistrations[data.scrollBar, ScrollProc, data];
XTk.PutWidgetProp[data.scrollBar, sampleScrollableContainerData, data];
XTkWidgets.AppendChild[data.main, data.scrollBar];
XTk.NoteAndStartReconfigure[data.container];
XTk.ShallowInternalEnumerateChildren[data.container, ExposeSend];
IF data.redrawProc #
NIL
THEN
data.redrawProc[data.redrawData];
};
IF data.scrollBar #
NIL
THEN
XTkScroller.SetState[data.scrollBar, newState];
};
ExposeSend: XTk.EachChild ~ {
PROC [parent: Widget, child: Widget, data: REF] RETURNS [stop: BOOL ← FALSE]
event:
REF Xl.EventRep.expose ¬
NEW[Xl.EventRep.expose];
event.originalCodeByte ¬ ORD[Xl.EventCode[expose]];
event.dispatchDrawable ¬ parent.window.drawable;
event.connection ¬ parent.connection;
event.seq ¬ 0;
event.window ¬ parent.window;
event.pos ¬ [0, 0];
event.size ¬ parent.actual.size;
event.count ¬ 1;
Xl.SendEvent[parent.connection, parent.window, TRUE, [exposure: TRUE], event];
};
SetHeight:
PUBLIC
PROCEDURE [widget: ContainerWidget, height:
INT] ~ {
g: Xl.Geometry;
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[widget, sampleScrollableContainerData];
IF d = NIL THEN RETURN;
data ¬ NARROW[d];
g ¬ data.container.actual;
height ¬
IF height < data.containerContainer.actual.size.height
THEN data.containerContainer.actual.size.height
ELSE height;
g.size.height ¬ height;
data.container.s.geometry.size.height ¬ height;
data.height ¬ height;
FixState[data];
XTk.NoteAndStartReconfigure[data.container];
XTk.StartReconfigureChildren[data.container];
};
ScrollPosition:
PUBLIC
PROCEDURE [widget: ContainerWidget]
RETURNS [position:
INT ¬ -1] ~ {
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[widget, sampleScrollableContainerData];
IF d = NIL THEN RETURN;
data ¬ NARROW[d];
position ¬ data.currentTop;
};
ScrollTo:
PUBLIC
PROCEDURE [widget: ContainerWidget, position:
INT ¬ 0] ~ {
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[widget, sampleScrollableContainerData];
IF d = NIL THEN RETURN;
IF position < 0 THEN position ¬ 0;
data ¬ NARROW[d];
DoScrollTo[data, position];
};
DoScrollTo:
PROCEDURE [data: ScrollableContainerData, to:
INT] ~ {
diff: INT ¬ to - data.currentTop;
mod: INT ¬ diff MOD data.granularity;
diff ¬ diff - (diff MOD data.granularity);
IF
ABS[mod] > (data.granularity / 2)
THEN
diff ¬ diff + (data.granularity * (ABS[mod] / mod));
DoScroll[data, diff];
};
Scroll:
PUBLIC
PROCEDURE [widget: ContainerWidget, offset:
INT ¬ 0] ~ {
data: ScrollableContainerData;
d: REF ANY ¬ XTk.GetWidgetProp[widget, sampleScrollableContainerData];
IF d = NIL THEN RETURN;
data ¬ NARROW[d];
DoScrollTo[data, data.currentTop + offset];
};
DoScroll:
PROCEDURE [data: ScrollableContainerData, deltaY:
INT] ~ {
g: Xl.Geometry ¬ data.container.actual;
state: XTkScroller.State;
newTop: INT;
IF data.scrollBar = NIL THEN RETURN;
state ¬ XTkScroller.GetState[data.scrollBar];
IF data.currentTop + deltaY < 0
THEN
deltaY ¬ -data.currentTop;
IF data.currentTop + data.containerContainer.actual.size.height + deltaY > data.height
THEN
deltaY ¬ (data.height - data.containerContainer.actual.size.height) - data.currentTop;
newTop ¬ data.currentTop + deltaY;
IF newTop = data.currentTop THEN RETURN;
g.pos.y ¬ g.pos.y - deltaY;
data.currentTop ¬ newTop;
XTk.NoteAndStartReconfigure[data.container, g];
FixState[data];
};
ScrollProc: XTkScroller.ScrollProc ~ {
ScrollProc: TYPE = PROC [scroller: Scroller, action: Action, value: REAL, event: XTk.Event, clientData: REF];
data: ScrollableContainerData ¬ NARROW[clientData];
SELECT action
FROM
configure => {
FixState[data];
RETURN;
};
none => {RETURN};
backward, forward, thumb =>
WITH event
SELECT
FROM
br: Xl.ButtonReleaseEvent => {
p: Xl.Point;
p ¬ br.pos;
IF (p.y < 0
OR p.y > data.scrollBar.actual.size.height)
THEN RETURN;
SELECT action
FROM
backward => DoScroll[data, -data.granularity * CARD[p.y / data.granularity]];
forward => DoScroll[data, data.granularity * CARD[p.y / data.granularity]];
thumb => ScrollTo[data.container, CARD[(data.container.actual.size.height * p.y) / data.scrollBar.actual.size.height]];
ENDCASE => ERROR;
};
ENDCASE => {};
ENDCASE => RETURN;
};
}.