XTkSliderImpl.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, October 18, 1988 11:22:01 am PDT
Christian Jacobi, April 19, 1993 11:09 am PDT
DIRECTORY
ForkOps,
Process,
Real,
Xl,
XlCursor,
XlPerDepth,
XTk,
XTkPrivate,
XTkSlider,
XTkFriends;
XTkSliderImpl:
CEDAR
MONITOR
IMPORTS ForkOps, Process, Real, XlCursor, XlPerDepth, Xl, XTk, XTkFriends, XTkPrivate
EXPORTS XTkSlider =
BEGIN OPEN XTkSlider;
DepthData:
TYPE =
RECORD [
activeCursor: Xl.Cursor ¬ Xl.nullCursor,
inertCursor: Xl.Cursor ¬ Xl.nullCursor,
greyPixmap: Xl.Pixmap,
gc: Xl.GContext
];
perDHandle: XlPerDepth.Handle ¬ XlPerDepth.InstallHandle[InitDepthData];
GetDepthData:
PROC [sd: Xl.ScreenDepth]
RETURNS [dd:
REF DepthData] = {
dd ¬ NARROW[XlPerDepth.InlineGetData[perDHandle, sd]];
};
InitDepthData: XlPerDepth.InitProc = {
dd: REF DepthData ¬ NEW[DepthData];
screen: Xl.Screen ~ sd.screen;
c: Xl.Connection ~ screen.connection;
gc: Xl.GContext ¬ dd.gc ¬ Xl.MakeGContext[c, screen.root.drawable];
stippleSpace:
REF
ARRAY [0..3]
OF
CARD32 =
NEW[ARRAY [0..3] OF CARD32 ¬ [088888888H, 044444444H, 022222222H, 0]];
dd.inertCursor ¬ XlCursor.SharedStandardCursor[c, crosshair];
dd.activeCursor ¬ XlCursor.SharedStandardCursor[c, cross];
Xl.SetGCGrounds[gc: gc, foreground: screen.blackPixel, background: screen.whitePixel];
dd.greyPixmap ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth];
TRUSTED {
Xl.PutImage[c: c, drawable: dd.greyPixmap.drawable, gc: gc, size: [4, 4], dest: [0, 0], base: LOOPHOLE[stippleSpace], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1];
};
Xl.SetGCTile[gc: gc, tile: dd.greyPixmap];
Xl.SetGCFillStyle[gc: gc, fillStyle: tiled];
RETURN [dd]
};
------------------------------------------------------
defaultWidth: INT = 12;
SliderState: TYPE = {init, time, set, abort};
eventMask: Xl.SetOfEvent ~ [structureNotify: TRUE, buttonMotion: TRUE, exposure: TRUE, buttonPress: TRUE, buttonRelease: TRUE];
sliderClass: XTk.ImplementorClass ¬ XTkFriends.CreateClass[[
key: $slider, classNameHint: $Slider, wDataNum: 1,
configureLR: SliderConfigureLR,
initInstPart: SliderInitInstPart,
forgetScreenLR: SliderForgetScreenLR,
fullStopFastAccessLR: SliderFullStopFastAccessLR,
eventMask: eventMask,
backgroundKey: $white
]];
SliderData: TYPE = REF SliderRec;
SliderRec:
TYPE =
RECORD [
direction: Direction,
clientValue: NormalizedSliderValue, --returned by GetContents, reset by abort
displayValue: NormalizedSliderValue, --value to be used by painter
setValue: NormalizedSliderValue, --newest mouse position; unfiltered
mousedValue: NormalizedSliderValue, --newest mouse position; unfiltered
changeOrTimeout: CONDITION,
myProcessRunning: BOOL ¬ FALSE,
myButtonActive: BOOL ¬ FALSE,
activeCursor: Xl.Cursor ¬ Xl.illegalCursor,
inertCursor: Xl.Cursor ¬ Xl.illegalCursor,
tq: Xl.TQ,
state: SliderState ¬ init,
gc: Xl.GContext ¬ NIL,
event: Xl.Event ¬ NIL,
procs: REF Procs ¬ NIL
];
Procs:
TYPE =
RECORD [
sliderProc: SliderProc ¬ NIL,
filterProc: FilterProc ¬ NIL,
clientData: REF ¬ NIL
];
GetInstData:
PROC [w: Widget]
RETURNS [SliderData] =
INLINE {
RETURN [NARROW[XTkFriends.InstPart[w, sliderClass]]];
};
SliderConfigureLR: XTk.ConfigureProc = {
existW: BOOL ~ widget.actualMapping<unconfigured;
createW: BOOL ~ mapping<unconfigured AND ~existW;
IF createW
THEN {
dd: REF DepthData = GetDepthData[widget.screenDepth];
sd: SliderData ~ GetInstData[widget];
IF sd.gc=NIL THEN sd.gc ¬ dd.gc;
IF Xl.IllegalCursor[sd.activeCursor] THEN sd.activeCursor ¬ dd.activeCursor;
IF Xl.IllegalCursor[widget.attributes.cursor]
THEN widget.attributes.cursor ¬ sd.inertCursor ¬ dd.inertCursor
ELSE sd.inertCursor ¬ widget.attributes.cursor;
sd.displayValue ¬ sd.clientValue;
XTk.AddTemporaryMatch[widget, [proc: SliderEventProc, handles: sliderEvents, tq: sd.tq, data: widget], eventMask];
};
XTkFriends.SimpleConfigureOneLevelLR[widget, geometry, mapping, reConsiderChildren];
};
IsSlider:
PUBLIC
PROC [widget: XTk.Widget]
RETURNS [
BOOL] = {
RETURN [widget#NIL AND widget.s.class=sliderClass]
};
CreateSlider:
PUBLIC
PROC [widgetSpec: WidgetSpec ¬ [], direction: Direction, contents: NormalizedSliderValue, clientData:
REF, filterProc: FilterProc, sliderProc: SliderProc, gc: Xl.GContext]
RETURNS [slider: Slider] = {
sd: SliderData;
SELECT direction
FROM
right, left => IF widgetSpec.geometry.size.width<=0 THEN widgetSpec.geometry.size.width ¬ defaultWidth;
up, down => IF widgetSpec.geometry.size.height<=0 THEN widgetSpec.geometry.size.height ¬ defaultWidth;
ENDCASE;
slider ¬ XTk.CreateWidget[widgetSpec, sliderClass];
sd ¬ GetInstData[slider];
sd.gc ¬ gc; sd.direction ¬ direction;
sd.displayValue ¬ sd.clientValue ¬ contents;
sd.tq ¬ Xl.CreateTQ[];
SetFilter[slider, filterProc, sliderProc, clientData];
TRUSTED {Process.SetTimeout[@sd.changeOrTimeout, Process.MsecToTicks[50]]};
};
SliderInitInstPart: XTk.InitInstancePartProc = {
XTkFriends.AssignInstPart[widget, sliderClass, NEW[SliderRec]];
};
SliderForgetScreenLR: XTk.TerminateProc = {
sd: SliderData ~ GetInstData[widget];
sd.gc ¬ NIL;
sd.activeCursor ¬ sd.inertCursor ¬ Xl.illegalCursor;
};
SliderFullStopFastAccessLR: XTk.FullStopFastAccessProc = {
sd: SliderData ~ GetInstData[widget];
protectTQLR[sd.tq];
SetAbort[sd, NIL];
};
GetContents:
PUBLIC
PROC [slider: Slider]
RETURNS [contents: NormalizedSliderValue] = {
sd: SliderData ~ GetInstData[slider];
contents ¬ sd.clientValue;
};
ForkedRepaint:
PROC [slider: Slider, sd: SliderData] = {
Xl.Enqueue[sd.tq, SliderEventProc, slider, NIL--repaint--];
};
Filter:
PROC [sd: SliderData, slider: Slider, contents: NormalizedSliderValue, event: Xl.Event, reason: Reason]
RETURNS [
REAL] = {
procs: REF Procs ¬ sd.procs;
IF procs#
NIL
AND procs.filterProc#
NIL
THEN
contents ¬ procs.filterProc[slider, procs.clientData, contents, event, reason ! ABORTED => CONTINUE];
IF contents>1.0 THEN contents ¬ 1.0;
RETURN [contents];
};
sliderSetKey: PUBLIC ATOM ¬ $sliderSet;
callKeys: ARRAY Reason OF ATOM ¬ [$temporary, $client, $set, $abort];
Report:
PROC [sd: SliderData, slider: Slider, reason: Reason, contents: NormalizedSliderValue, event: Xl.Event ¬
NIL] = {
ENABLE ABORTED => GOTO Oops;
procs: REF Procs ¬ sd.procs;
ForkedRepaint[slider, sd];
IF procs#
NIL
AND procs.sliderProc#
NIL
THEN
procs.sliderProc[slider, procs.clientData, contents, event, reason];
XTkFriends.CallNotifiers[slider, sliderSetKey, callKeys[reason], event];
EXITS Oops => {}
};
SetContents:
PUBLIC
PROC [slider: Slider, contents: NormalizedSliderValue, event: Xl.Event] = {
sd: SliderData ~ GetInstData[slider];
val: REAL ¬ Filter[sd, slider, contents, event, client];
IF val<0 THEN RETURN;
InternalSetContents[slider, val, event, client];
};
InternalSetContents:
PUBLIC
PROC [slider: Slider, contents: NormalizedSliderValue, event: Xl.Event, reason: Reason ¬ client] = {
sd: SliderData ~ GetInstData[slider];
EntrySetContents:
ENTRY
PROC [sd: SliderData, contents: NormalizedSliderValue]
RETURNS [change:
BOOL] =
INLINE {
change ¬ sd.clientValue#contents;
sd.clientValue ¬ contents;
IF ~sd.myButtonActive THEN sd.displayValue ¬ contents;
};
SELECT contents
FROM
<0 => RETURN;
>1 => RETURN;
ENDCASE => {};
SELECT reason
FROM
client => {
change: BOOL ¬ EntrySetContents[sd, contents];
IF change
THEN {
Report[sd, slider, client, sd.clientValue, event];
};
};
set => {
sd.clientValue ¬ sd.displayValue ¬ contents;
Report[sd, slider, set, sd.clientValue, sd.event];
};
abort => {
sd.displayValue ¬ sd.clientValue;
Report[sd, slider, abort, sd.clientValue, sd.event];
};
temporary => {
IF sd.displayValue = contents THEN RETURN;
sd.displayValue ¬ contents;
Report[sd, slider, temporary, contents, sd.event];
};
ENDCASE => {};
};
SetFilter:
PUBLIC
PROC [slider: Slider, filterProc: FilterProc ¬
NIL, sliderProc: SliderProc ¬
NIL, clientData:
REF ¬
NIL] = {
sd: SliderData ~ GetInstData[slider];
procs: REF Procs ¬ NIL;
IF filterProc#
NIL
OR sliderProc#
NIL
THEN
procs ¬ NEW[Procs ¬ [filterProc: filterProc, sliderProc: sliderProc, clientData: clientData]];
sd.procs ¬ procs
};
SetGC:
PUBLIC
PROC [slider: Slider, gc: Xl.GContext] = {
sd: SliderData ~ GetInstData[slider];
IF gc=
NIL
AND slider.state=realized
THEN {
dd: REF DepthData = GetDepthData[slider.screenDepth];
gc ¬ dd.gc;
};
IF gc=NIL THEN ERROR;
sd.gc ¬ gc;
IF slider.state=realized THEN ForkedRepaint[slider, sd];
};
ValueFromPos:
PROC [sd: SliderData, pos: Xl.Point, sz: Xl.Size]
RETURNS [val: NormalizedSliderValue ¬ 0] = {
p, s: INT;
SELECT sd.direction
FROM
right => {p ¬ pos.x; s ¬ sz.width};
down => {p ¬ pos.y; s ¬ sz.height};
left => {p ¬ sz.width-pos.x; s ¬ sz.width};
up => {p ¬ sz.height-pos.y; s ¬ sz.height};
ENDCASE;
SELECT
TRUE
FROM
p<=0 => val ¬ 0.0;
p>=s => val ¬ 1.0;
<<note: now s#0>>
ENDCASE => {val ¬ p; val ¬ val / s};
};
sliderEvents: Xl.EventFilter = Xl.FullCreateEventFilter[LIST[expose, buttonPress, buttonRelease, motionNotify, destroyNotify]];
SliderEventProc: Xl.EventProcType = {
slider: Widget ~ NARROW[clientData];
sd: SliderData ~ GetInstData[slider];
IF event=NIL THEN {SliderRepaint[slider, sd]; RETURN};
SELECT event.type
FROM
Xl.EventCode.motionNotify => {
--Worth while to fork. This way painting can be done slower then accepting motions by simply discarding intermediate paints.
IF sd.myButtonActive
THEN {
motion: Xl.MotionNotifyEvent ~ NARROW[event];
IF Inside[slider, motion.pos]
AND motion.sameScreen
THEN {
value: NormalizedSliderValue ~ ValueFromPos[sd, motion.pos, slider.actual.size];
SetMousedValue[sd, value, event];
}
};
};
Xl.EventCode.buttonPress => {
bp: Xl.ButtonPressEvent ~ NARROW[event];
IF sd.myButtonActive THEN RETURN;
IF Xl.SetButtonGrabOwner[bp.connection, bp.timeStamp, sd]=succeeded
THEN {
value: NormalizedSliderValue;
IF sd.myProcessRunning THEN RETURN; --avoid having two processes sharing data; not atomic as missing a mouse click isn't that horrible a race condition
sd.myProcessRunning ¬ TRUE;
sd.myButtonActive ¬ TRUE;
SetCursor[slider, sd.activeCursor];
value ¬ ValueFromPos[sd, bp.pos, slider.actual.size];
SetMousedValue[sd, value, event];
sd.state ¬ init;
ForkOps.Fork[SliderProcess, slider, Process.priorityForeground];
};
};
Xl.EventCode.buttonRelease =>
IF sd.myButtonActive
THEN {
br: Xl.ButtonReleaseEvent ~ NARROW[event];
IF br.sameScreen
AND (Inside[slider, br.pos]
OR Extents[slider, br.pos, sd.direction])
THEN {
value: NormalizedSliderValue ~ ValueFromPos[sd, br.pos, slider.actual.size];
SetValue[sd, value, event];
}
ELSE {SetAbort[sd, event]};
SetCursor[slider, sd.inertCursor];
};
Xl.EventCode.expose => {
expose: Xl.ExposeEvent ~ NARROW[event];
IF expose.count<=0 THEN SliderRepaint[slider, sd];
};
Xl.EventCode.configureNotify => SliderRepaint[slider, sd];
Xl.EventCode.unmapNotify => SetAbort[sd, event];
Xl.EventCode.destroyNotify => SetAbort[sd, NIL];
ENDCASE => {};
};
WaitForAction:
ENTRY
PROC [sd: SliderData]
RETURNS [reason: SliderState] = {
IF sd.state=time THEN WAIT sd.changeOrTimeout;
reason ¬ sd.state; sd.state ¬ time
};
SetAbort:
ENTRY
PROC [sd: SliderData, event: Xl.Event] = {
sd.state ¬ abort; sd.myButtonActive ¬ FALSE;
sd.displayValue ¬ sd.clientValue; sd.event ¬ event;
NOTIFY sd.changeOrTimeout;
};
SetValue:
ENTRY
PROC [sd: SliderData, value: NormalizedSliderValue, event: Xl.Event] = {
sd.setValue ¬ value; sd.event ¬ event;
sd.state ¬ set; sd.myButtonActive ¬ FALSE;
NOTIFY sd.changeOrTimeout;
};
SetMousedValue:
ENTRY
PROC [sd: SliderData, value: NormalizedSliderValue, e: Xl.Event] = {
sd.mousedValue ¬ value; sd.event ¬ e;
NOTIFY sd.changeOrTimeout;
};
SliderProcess:
PROC [x:
REF] = {
Started when a button down is received running while button is down
slider: XTk.Widget ~ NARROW[x];
sd: SliderData ~ GetInstData[slider];
DO
SELECT WaitForAction[sd]
FROM
init, time => {
IF sd.mousedValue#sd.displayValue
THEN {
newValue: REAL ¬ Filter[sd, slider, sd.mousedValue, sd.event, temporary];
IF newValue>=0
AND sd.displayValue#newValue
THEN
InternalSetContents[slider, newValue, sd.event, temporary]
};
};
set => {
newValue: REAL ¬ Filter[sd, slider, sd.setValue, sd.event, set];
IF newValue>=0
THEN {
InternalSetContents[slider, newValue, sd.event, set];
EXIT;
}
ELSE {
--A filter ought not deny a set...
IF sd.myProcessRunning
THEN
InternalSetContents[slider, sd.clientValue, sd.event, abort];
EXIT;
};
};
abort => {
oldValue: REAL ¬ Filter[sd, slider, sd.clientValue, sd.event, abort];
InternalSetContents[slider, oldValue, sd.event, abort];
EXIT;
};
ENDCASE --init-- => {};
ENDLOOP;
sd.myProcessRunning ¬ FALSE;
};
noErrors: Xl.Details ~ XTkPrivate.detailsForNoErrors;
SliderRepaint:
PROC [slider: Widget, sd: SliderData] = {
c: Xl.Connection ~ slider.connection;
w: Xl.Window ~ slider.window;
sz: Xl.Size ~ slider.actual.size;
IF slider.fastAccessAllowed#ok OR slider.state#realized THEN RETURN;
IF sz.height<=0 OR sz.width<=0 THEN RETURN;
SELECT sd.direction
FROM
right => {
x: INT ~ Real.Round[sz.width*sd.displayValue];
IF x>0 THEN Xl.FillRectangle[c, w, sd.gc, [0, 0], [x, sz.height], noErrors];
IF sz.width>x THEN Xl.ClearArea[c, w, [x, 0], [sz.width-x, sz.height], FALSE, noErrors];
};
left => {
x: INT ~ Real.Round[sz.width*(1.0-sd.displayValue)];
IF x>0 THEN Xl.ClearArea[c, w, [0, 0], [x, sz.height], FALSE, noErrors];
IF sz.width>x THEN Xl.FillRectangle[c, w, sd.gc, [x, 0], [sz.width-x, sz.height], noErrors];
};
down => {
y: INT ~ Real.Round[sz.height*sd.displayValue];
IF y>0 THEN Xl.FillRectangle[c, w, sd.gc, [0, 0], [sz.width, y], noErrors];
IF sz.height>y THEN Xl.ClearArea[c, w, [0, y], [sz.width, sz.height-y], FALSE, noErrors];
};
up => {
y: INT ~ Real.Round[sz.height*(1.0-sd.displayValue)];
IF y>0 THEN Xl.ClearArea[c, w, [0, 0], [sz.width, y], FALSE, noErrors];
IF sz.height>y THEN Xl.FillRectangle[c, w, sd.gc, [0, y], [sz.width, sz.height-y], noErrors];
};
ENDCASE;
Xl.Flush[c];
};
Inside:
PROC [w: Widget, p: Xl.Point]
RETURNS [
BOOL] = {
RETURN [p.x>=0 AND p.x<=w.actual.size.width AND p.y>=0 AND p.y<=w.actual.size.height]
};
Extents:
PROC [w: Widget, p: Xl.Point, direction: Direction]
RETURNS [
BOOL] = {
SELECT direction
FROM
right, left => RETURN[p.x<=0 OR p.x>=w.actual.size.width];
down, up => RETURN[p.y<=0 OR p.y>=w.actual.size.height];
ENDCASE => ERROR;
};
SetCursor:
PROC [widget: Widget, cursor: Xl.Cursor] = {
attributes: Xl.Attributes;
c: Xl.Connection ~ widget.connection;
IF widget.fastAccessAllowed=ok
AND Xl.Alive[c]
THEN {
attributes.cursor ¬ cursor;
Xl.ChangeWindowAttributes[c, widget.window, attributes, XTkPrivate.detailsForFlushNoErrors];
};
};
XTkFriends.AliasNotifierKey[sliderSetKey];
END.