<<>> <> <> <> <> <<>> DIRECTORY Real, Xl, XlCursor, XTk, XTkFriends, XTkScroller; XTkScrollerImpl: CEDAR MONITOR IMPORTS Real, XlCursor, Xl, XTk, XTkFriends EXPORTS XTkScroller = BEGIN OPEN XTkScroller; setStateCalled: PUBLIC ATOM ¬ $ScrollerSetStateCalled; myPropKey: REF ATOM ~ NEW[ATOM ¬ $scroller]; cdCache: ConnectionData ¬ NEW[ConnectionDataRec[0]]; --must never be NIL GetConnectionData: PROC [c: Xl.Connection] RETURNS [cd: ConnectionData] = { cd ¬ cdCache; IF cd.connection = c THEN RETURN; cdCache ¬ cd ¬ NARROW[Xl.GetConnectionPropAndInit[c, myPropKey, InitConnection]]; }; ConnectionData: TYPE = REF ConnectionDataRec; ConnectionDataRec: TYPE = RECORD [ connection: Xl.Connection ¬ NIL, inertCursor: Xl.Cursor ¬ Xl.nullCursor, exposeTQ: Xl.TQ ¬ NIL, --share tq, limit parallelism up, down, left, right, leftRight, upDown: Xl.Cursor ¬ Xl.nullCursor, perDepth: SEQUENCE num: NAT OF PerDepthRec ]; PerDepthRec: TYPE = RECORD [ grey1, grey2, grey3: Xl.Pixmap, gc1, gc2, gc3: Xl.GContext ]; InitConnection: Xl.InitializeProcType = { stippleSpace1: REF ARRAY [0..3] OF CARD32 = NEW[ARRAY [0..3] OF CARD32 ¬ [088888888H, 044444444H, 022222222H, 0]]; stippleSpace2: REF ARRAY [0..3] OF CARD32 = NEW[ARRAY [0..3] OF CARD32 ¬ [0AAAAAAAAH, 055555555H, 0AAAAAAAAH, 055555555H]]; stippleSpace3: REF ARRAY [0..3] OF CARD32 = NEW[ARRAY [0..3] OF CARD32 ¬ [022222222H, 044444444H, 088888888H, 0]]; cd: ConnectionData ¬ NEW[ConnectionDataRec[Xl.ScreenDepthCount[c]]]; cd.exposeTQ ¬ Xl.CreateTQ[]; cd.inertCursor ¬ XlCursor.SharedStandardCursor[c, tcross]; cd.up ¬ XlCursor.SharedStandardCursor[c, sbUpArrow]; cd.down ¬ XlCursor.SharedStandardCursor[c, sbDownArrow]; cd.left ¬ XlCursor.SharedStandardCursor[c, sbLeftArrow]; cd.right ¬ XlCursor.SharedStandardCursor[c, sbRightArrow]; cd.leftRight ¬ XlCursor.SharedStandardCursor[c, sbHDoubleArrow]; cd.upDown ¬ XlCursor.SharedStandardCursor[c, sbVDoubleArrow]; FOR d: NAT IN [0..cd.num) DO sd: Xl.ScreenDepth ¬ Xl.NthScreenDepth[c, d]; screen: Xl.Screen ¬ sd.screen; gc1: Xl.GContext ¬ Xl.MakeGContext[c, screen.root.drawable]; gc2: Xl.GContext ¬ Xl.MakeGContext[c, screen.root.drawable]; gc3: Xl.GContext ¬ Xl.MakeGContext[c, screen.root.drawable]; Xl.SetGCGrounds[gc: gc1, foreground: screen.blackPixel, background: screen.whitePixel]; Xl.SetGCGrounds[gc: gc2, foreground: screen.blackPixel, background: screen.whitePixel]; Xl.SetGCGrounds[gc: gc3, foreground: screen.blackPixel, background: screen.whitePixel]; cd.perDepth[d].grey1 ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth]; cd.perDepth[d].grey2 ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth]; cd.perDepth[d].grey3 ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth]; TRUSTED { Xl.PutImage[c: c, drawable: cd.perDepth[d].grey1.drawable, gc: gc1, size: [4, 4], dest: [0, 0], base: LOOPHOLE[stippleSpace1], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1]; Xl.PutImage[c: c, drawable: cd.perDepth[d].grey2.drawable, gc: gc2, size: [4, 4], dest: [0, 0], base: LOOPHOLE[stippleSpace2], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1]; Xl.PutImage[c: c, drawable: cd.perDepth[d].grey3.drawable, gc: gc3, size: [4, 4], dest: [0, 0], base: LOOPHOLE[stippleSpace3], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1]; }; Xl.SetGCTile[gc: gc1, tile: cd.perDepth[d].grey1]; Xl.SetGCTile[gc: gc2, tile: cd.perDepth[d].grey2]; Xl.SetGCTile[gc: gc3, tile: cd.perDepth[d].grey3]; Xl.SetGCFillStyle[gc: gc1, fillStyle: tiled]; Xl.SetGCFillStyle[gc: gc2, fillStyle: tiled]; Xl.SetGCFillStyle[gc: gc3, fillStyle: tiled]; cd.perDepth[d].gc1 ¬ gc1; cd.perDepth[d].gc2 ¬ gc2; cd.perDepth[d].gc3 ¬ gc3; ENDLOOP; RETURN [cd] }; <<------------------------------------------------------>> defaultWidth: INT = 12; eventMask: Xl.SetOfEvent ~ [structureNotify: TRUE, buttonMotion: TRUE, exposure: TRUE, buttonPress: TRUE, buttonRelease: TRUE]; scrollerClass: PUBLIC XTk.Class ¬ XTkFriends.CreateClass[[ key: $scroller, classNameHint: $Scrollbar, wDataNum: 1, configureLR: ScrollerConfigureLR, initInstPart: ScrollerInitInstPart, forgetScreenLR: ScrollerForgetScreenLR, eventMask: eventMask, backgroundKey: $white ]]; CallRegRec: TYPE = RECORD [ scroller: Scroller, scrollerProc: ScrollProc, clientData: REF ¬ NIL, tq: Xl.TQ ¬ NIL --NIL for rootTQ ]; CallData: TYPE = RECORD [ crrl: LIST OF CallRegRec, action: XTkScroller.Action, value: REAL ]; ScrollerData: TYPE = REF ScrollerRec; ScrollerRec: TYPE = RECORD [ state: State, --monitored direction: Direction, iOwnButton: BOOL ¬ FALSE, initiatedAction: Action ¬ none, leftMouseCursor: Xl.Cursor ¬ Xl.illegalCursor, middleMouseCursor: Xl.Cursor ¬ Xl.illegalCursor, rightMouseCursor: Xl.Cursor ¬ Xl.illegalCursor, inertCursor: Xl.Cursor ¬ Xl.illegalCursor, gc1: Xl.GContext ¬ NIL, gc2: Xl.GContext ¬ NIL, gc3: Xl.GContext ¬ NIL, reportedLength: INT ¬ 99999, --never zero; initiated with an impossible value. crrList: LIST OF CallRegRec ¬ NIL ]; GetInstData: PROC [scroller: Scroller] RETURNS [ScrollerData] = INLINE { RETURN [NARROW[XTkFriends.InstPart[scroller, scrollerClass]]]; }; SetState: PUBLIC PROC [scroller: Scroller, state: State, propagate: BOOL] = { sd: ScrollerData ~ GetInstData[scroller]; EntrySetState[sd, state]; IF propagate THEN XTkFriends.CallNotifiers[scroller, setStateCalled, sd]; ScrollerRepaint[scroller, sd]; }; GetDirection: PUBLIC PROC [scroller: Scroller] RETURNS [direction: Direction] = { sd: ScrollerData ~ GetInstData[scroller]; RETURN [sd.direction] }; GetState: PUBLIC PROC [scroller: Scroller] RETURNS [state: State] = { sd: ScrollerData ~ GetInstData[scroller]; state ¬ EntryGetState[sd]; }; EntrySetState: ENTRY PROC [sd: ScrollerData, state: State] = { sd.state ¬ state }; EntryGetState: ENTRY PROC [sd: ScrollerData] RETURNS [state: State] = { state ¬ sd.state }; ScrollerConfigureLR: XTk.ConfigureProc = { existW: BOOL ¬ widget.actualMapping { sd.leftMouseCursor ¬ cd.up; sd.middleMouseCursor ¬ cd.upDown; sd.rightMouseCursor ¬ cd.down; SELECT TRUE FROM geometry.size.height>0 => sd.reportedLength ¬ geometry.size.height; widget.actual.size.height>0 => sd.reportedLength ¬ widget.actual.size.height; ENDCASE => sd.reportedLength ¬ 1; }; horizontal => { sd.leftMouseCursor ¬ cd.left; sd.middleMouseCursor ¬ cd.leftRight; sd.rightMouseCursor ¬ cd.right; SELECT TRUE FROM geometry.size.width>0 => sd.reportedLength ¬ geometry.size.width; widget.actual.size.width>0 => sd.reportedLength ¬ widget.actual.size.width; ENDCASE => sd.reportedLength ¬ 1; }; ENDCASE; IF Xl.IllegalCursor[widget.attributes.cursor] THEN widget.attributes.cursor ¬ sd.inertCursor ¬ cd.inertCursor ELSE sd.inertCursor ¬ widget.attributes.cursor; XTk.AddTemporaryMatch[widget, [proc: ScrollerEventProc, handles: scrollerEventSet, tq: cd.exposeTQ, data: widget], eventMask]; ForwardCallScrollerProcs[sd, configure, sd.reportedLength, NIL]; --because window creation does not make configure events... }; XTkFriends.SimpleConfigureOneLevelLR[widget, geometry, mapping, reConsiderChildren]; }; CreateScroller: PUBLIC PROC [widgetSpec: XTk.WidgetSpec ¬ [], direction: Direction, state: State] RETURNS [scroller: Scroller] = { sd: ScrollerData; SELECT direction FROM vertical => IF widgetSpec.geometry.size.width<=0 THEN widgetSpec.geometry.size.width ¬ defaultWidth; horizontal => IF widgetSpec.geometry.size.height<=0 THEN widgetSpec.geometry.size.height ¬ defaultWidth; ENDCASE; scroller ¬ XTk.CreateWidget[widgetSpec, scrollerClass]; sd ¬ GetInstData[scroller]; sd.direction ¬ direction; sd.state ¬ state; }; InteractiveRegistrations: PUBLIC PROC [scroller: Scroller, scrollerProc: ScrollProc, clientData: REF ¬ NIL, tq: Xl.TQ ¬ NIL] = { Protected: ENTRY PROC [sd: ScrollerData, crr: CallRegRec] = { sd.crrList ¬ CONS[crr, sd.crrList] }; sd: ScrollerData ~ GetInstData[scroller]; crr: CallRegRec ~ [scrollerProc: scrollerProc, clientData: clientData, scroller: scroller]; IF sd=NIL OR scrollerProc=NIL THEN ERROR; Protected[sd, crr]; }; ForwardCallScrollerProcs: PROC [sd: ScrollerData, action: XTkScroller.Action, value: REAL, event: Xl.Event ¬ NIL] = { <<--propagate actions onto right threads>> FOR rl: LIST OF CallRegRec ¬ sd.crrList, rl.rest WHILE rl#NIL DO cd: REF CallData ~ NEW[CallData ¬ [crrl: rl, action: action, value: value]]; tq: Xl.TQ ¬ rl.first.tq; IF tq=NIL THEN {tq ¬ rl.first.scroller.rootTQ; IF tq=NIL THEN EXIT}; Xl.Enqueue[tq: tq, proc: SynchCallScrollerProc, data: cd, event: event]; ENDLOOP }; SynchCallScrollerProc: Xl.EventProcType = { cd: REF CallData ~ NARROW[clientData]; cd.crrl.first.scrollerProc[scroller: cd.crrl.first.scroller, action: cd.action, value: cd.value, event: event, clientData: cd.crrl.first.clientData]; }; ScrollerInitInstPart: XTk.InitInstancePartProc = { XTkFriends.AssignInstPart[widget, scrollerClass, NEW[ScrollerRec]]; }; ScrollerForgetScreenLR: XTk.TerminateProc = { sd: ScrollerData ~ GetInstData[widget]; sd.gc1 ¬ sd.gc2 ¬ sd.gc3 ¬ NIL; sd.leftMouseCursor ¬ sd.middleMouseCursor ¬ sd.rightMouseCursor ¬ sd.inertCursor ¬ Xl.illegalCursor; sd.iOwnButton ¬ FALSE; sd.initiatedAction ¬ none; }; scrollerEventSet: Xl.EventFilter ~ Xl.CreateEventFilter[expose, buttonPress, buttonRelease, configureNotify]; ScrollerEventProc: Xl.EventProcType = { ENABLE Xl.XError => GOTO oops; scroller: Scroller ~ NARROW[clientData]; sd: ScrollerData ~ GetInstData[scroller]; SELECT event.type FROM Xl.EventCode.buttonPress => { bp: Xl.ButtonPressEvent ~ NARROW[event]; IF ~sd.iOwnButton AND Xl.SetButtonGrabOwner[bp.connection, bp.timeStamp, sd]=succeeded THEN { sd.iOwnButton ¬ TRUE; SELECT bp.button FROM 1 => {sd.initiatedAction ¬ forward; SetCursor[scroller, sd.leftMouseCursor]}; 2 => {sd.initiatedAction ¬ thumb; SetCursor[scroller, sd.middleMouseCursor]}; 3 => {sd.initiatedAction ¬ backward; SetCursor[scroller, sd.rightMouseCursor]}; ENDCASE => {}; }; }; Xl.EventCode.buttonRelease => { IF sd.iOwnButton THEN { br: Xl.ButtonReleaseEvent ~ NARROW[event]; IF br.sameScreen AND (Inside[scroller, br.pos] OR Extents[scroller, br.pos, sd.direction]) THEN { leng: REAL ~ sd.reportedLength; value: REAL ~ ValueFromPos[sd, br.pos]; ForwardCallScrollerProcs[sd, sd.initiatedAction, value/leng, event]; }; SetCursor[scroller, sd.inertCursor]; sd.iOwnButton ¬ FALSE; }; }; Xl.EventCode.configureNotify => { cne: Xl.ConfigureNotifyEvent ~ NARROW[event]; value: INT ~ SELECT sd.direction FROM horizontal => cne.geometry.size.width, vertical => cne.geometry.size.height, ENDCASE => ERROR; IF value#sd.reportedLength THEN { sd.reportedLength ¬ MAX[value, 1]; ForwardCallScrollerProcs[sd, configure, value, event]; } }; Xl.EventCode.expose => { expose: Xl.ExposeEvent = NARROW[event]; IF expose.count<=0 THEN ScrollerRepaint[scroller, sd]; }; ENDCASE => {}; EXITS oops => {}; }; ValueFromPos: PROC [sd: ScrollerData, pos: Xl.Point] RETURNS [p: INT] = INLINE { SELECT sd.direction FROM horizontal => {p ¬ pos.x}; vertical => {p ¬ pos.y}; ENDCASE; }; Inside: PROC [w: XTk.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: XTk.Widget, p: Xl.Point, direction: Direction] RETURNS [BOOL] = { SELECT direction FROM horizontal => RETURN[p.x<=0 OR p.x>=w.actual.size.width]; vertical => RETURN[p.y<=0 OR p.y>=w.actual.size.height]; ENDCASE => ERROR; }; SetCursor: PROC [widget: XTk.Widget, cursor: Xl.Cursor] = { attributes: Xl.Attributes; attributes.cursor ¬ cursor; Xl.ChangeWindowAttributes[widget.connection, widget.window, attributes]; Xl.Flush[widget.connection]; }; ScrollerRepaint: PROC [scroller: Scroller, sd: ScrollerData] = { cheat: INT ~ 3; c: Xl.Connection ~ scroller.connection; w: Xl.Window ~ scroller.window; sz: Xl.Size ~ scroller.actual.size; state: State ¬ sd.state; IF scroller.fastAccessAllowed#ok OR scroller.state#realized THEN RETURN; IF sz.height<=0 OR sz.width<=0 THEN RETURN; state.start ¬ MIN[MAX[state.start, 0.0], 1.0]; state.next ¬ MIN[MAX[state.start, state.next], 1.0]; SELECT sd.direction FROM horizontal => { iLength: INT ~ scroller.actual.size.width; iStart: INT ¬ Real.Round[iLength*state.start]; iNext: INT ¬ Real.Round[iLength*state.next]; <<--cheat to keep middle range visible...>> iStart ¬ MAX[MIN[iStart, iLength-cheat], 0]; iNext ¬ MIN[iLength, MAX[iStart+cheat, iNext]]; IF iStart>0 THEN Xl.FillRectangle[c, w, sd.gc1, [0, 0], [iStart, sz.height]]; IF iNext>iStart THEN Xl.FillRectangle[c, w, sd.gc2, [iStart, 0], [iNext-iStart, sz.height]]; IF iLength>iNext THEN Xl.FillRectangle[c, w, sd.gc3, [iNext, 0], [iLength-iNext, sz.height]]; }; vertical => { iLength: INT ~ scroller.actual.size.height; iStart: INT ¬ Real.Round[iLength*state.start]; iNext: INT ¬ Real.Round[iLength*state.next]; <<--cheat to keep middle range visible...>> iStart ¬ MAX[MIN[iStart, iLength-cheat], 0]; iNext ¬ MIN[iLength, MAX[iStart+cheat, iNext]]; IF iStart>0 THEN Xl.FillRectangle[c, w, sd.gc1, [0, 0], [sz.width, iStart]]; IF iNext>iStart THEN Xl.FillRectangle[c, w, sd.gc2, [0, iStart], [sz.width, iNext-iStart]]; IF iLength>iNext THEN Xl.FillRectangle[c, w, sd.gc3, [0, iNext], [sz.width, iLength-iNext]]; }; ENDCASE; Xl.Flush[c, TRUE]; }; END.