<> <> <> <> <> DIRECTORY Basics USING [bitsPerWord, LongMult, RawWords], BasicTime USING [GMT, Now, Period, Update], CedarProcess USING [Priority, SetPriority], Commander USING [CommandProc, Register], Cursors USING [SetCursor], Cursory USING [SetMousePosition], Imager USING [black, ClipRectangleI, Context, DoSave, Font, MaskRectangleI, SetColor, SetFont, SetXY, SetXYI, ShowRope, TranslateT, white], ImagerBackdoor USING [invert], ImagerFont USING [Extents, RopeBoundingBox, RopeWidth], ImagerTerminal USING [BWContext], InputFocus USING [CaptureButtons, PopInputFocus, PushInputFocus, ReleaseButtons], Interminal USING [GetMousePosition, MousePosition], PopUpSelection USING [], PrincOps USING [BBptr, BBTable, BBTableSpace, BitAddress, BitBltFlags, SrcDesc], PrincOpsUtils USING [AlignedBBTable, BITBLT], Process USING [Detach, MsecToTicks, Pause], Real USING [FixI, RoundI], Rope USING [InlineIsEmpty, ROPE], RuntimeError USING [UNCAUGHT], Terminal USING [ColorMode, Current, FrameBuffer, GetBWFrameBuffer, GetColorFrameBufferA, GetColorFrameBufferB, GetColorMode, ModifyColorFrame, Virtual], TIPUser USING [InstantiateNewTIPTable, TIPScreenCoords, TIPTable], UserProfile USING [Boolean, CallWhenProfileChanges, Number, ProfileChangedProc, Token], VFonts USING [EstablishFont, FontHeight], ViewerClasses USING [NotifyProc], ViewerLocks USING [CallUnderColumnLock, CallUnderViewerTreeLock], ViewerPrivate USING [CreateContext]; PopUpSelectionImpl: CEDAR MONITOR IMPORTS Basics, BasicTime, CedarProcess, Commander, Cursors, Cursory, Imager, ImagerBackdoor, ImagerFont, ImagerTerminal, InputFocus, Interminal, PrincOpsUtils, Process, Real, Rope, RuntimeError, Terminal, TIPUser, UserProfile, VFonts, ViewerLocks, ViewerPrivate EXPORTS PopUpSelection = BEGIN <<>> <<--global variables are protected with MONITOR Enter and Leave>> sHeight, sWidth: INTEGER; -- size of screen, in pixels; [screen containing menu] mHeight, mWidth: INTEGER; -- size of menu, in pixels mX, mY: INTEGER; -- menu position, in screen coordinates context: Imager.Context; -- menu context mOnColor: BOOL; -- menu [NOT cursor] on color screen lastRemoved: BasicTime.GMT _ BasicTime.Now[]; --for crazy heuristics lastMouse: Interminal.MousePosition; -- at start; remember between calls is creature comfort reCheck: CONDITION _ [timeout: Process.MsecToTicks[1000]]; allDone: BOOL _ TRUE; --monitored moduleFree: BOOL _ FALSE; --monitored; initializations frees module escaped: BOOL _ FALSE; blackBorderW: INTEGER = 2; whiteBorderW: INTEGER = 2; borderW: INTEGER = blackBorderW+whiteBorderW; border2W: INTEGER = borderW+borderW; gSelection: NAT _ 0; gTitleLines: NAT; -- 0 or 1 header lines gLabel: Rope.ROPE; gChoice: LIST OF Rope.ROPE _ NIL; gDefault: NAT; gMouse: REF _ NIL; gHelp: LIST OF Rope.ROPE; gHelpOn: INTEGER _ -1; gHelpMode: BOOL _ FALSE; vt: Terminal.Virtual _ Terminal.Current[]; --always use this terminal tipTable: TIPUser.TIPTable; font: Imager.Font _ NIL; lineHeight: INTEGER; --in pixels <> <> <> <> <> <<};>> <<>> <<>> <<--SetDone and Wait for scheduling interaction menu>> SetDone: ENTRY PROC [] = { allDone _ TRUE; BROADCAST reCheck }; SetTimeOut: ENTRY PROC [key: REF] = { IF timeOutKey=key AND ~moduleFree THEN allDone _ timedOut _ TRUE; BROADCAST reCheck }; Wait: ENTRY PROC [] = { allDone _ FALSE; WHILE ~allDone DO WAIT reCheck ENDLOOP; }; <<>> <<--Enter and Leave for scheduling module entrance>> Enter: ENTRY PROC [] = { WHILE ~moduleFree DO WAIT reCheck ENDLOOP; moduleFree _ FALSE }; Leave: ENTRY PROC [] = { moduleFree _ TRUE; BROADCAST reCheck }; <<>> <<-- saving and restoring screen contents>> <<>> SavedRec: TYPE = RECORD [ col: BOOL, x, y, w, h: INTEGER, fb1: Terminal.FrameBuffer_NIL, buffer1: REF_NIL, fb2: Terminal.FrameBuffer_NIL, buffer2: REF_NIL ]; bpWm1: NAT = Basics.bitsPerWord-1; bBFlags: PrincOps.BitBltFlags ~ PrincOps.BitBltFlags[ direction: forward, disjoint: TRUE, disjointItems: TRUE, gray: FALSE, srcFunc: null, dstFunc: null, reserved: 0 ]; PixToWords: PROC [n: INTEGER, bpp: NAT] RETURNS [INTEGER] = INLINE { RETURN [(n*bpp+bpWm1)/Basics.bitsPerWord] }; Save: PROC [x, y, w, h: INTEGER, col: BOOL_FALSE] RETURNS [s: REF SavedRec] = TRUSTED { <<--x, y, w, h in pixels>> blit: PrincOps.BBptr; AllocateBitmap: PROC [wW, hL: CARDINAL] RETURNS [REF] = TRUSTED INLINE { <<--wW: width in words; hL: height in lines>> c: CARD _ Basics.LongMult[wW, hL]; IF c>=LAST[CARDINAL] THEN { <<--in this case we cant allocate the words>> <<--we don't care about uglyness, but please don't wedge!>> s.h _ hL _ (LAST[CARDINAL]-1)/wW; c _ Basics.LongMult[wW, hL]; }; RETURN [NEW[Basics.RawWords[c]]]; }; Blit: PROC [fb: Terminal.FrameBuffer, buffer: REF] = TRUSTED INLINE { blit.flags _ bBFlags; blit.src _ PrincOps.BitAddress[ word: fb.base + Basics.LongMult[s.y, fb.wordsPerLine] + s.x*fb.bitsPerPixel/Basics.bitsPerWord, reserved: 0, bit: s.x*fb.bitsPerPixel MOD Basics.bitsPerWord ]; blit.srcDesc.srcBpl _ fb.bitsPerPixel*fb.width; blit.dst _ PrincOps.BitAddress[LOOPHOLE[buffer], 0, 0]; blit.dstBpl _ PixToWords[s.w, fb.bitsPerPixel]*Basics.bitsPerWord; blit.width _ s.w*fb.bitsPerPixel; blit.height _ s.h; PrincOpsUtils.BITBLT[blit]; }; DoWithFrame: PROC [] = TRUSTED { Blit[s.fb1, s.buffer1]; IF s.buffer2#NIL THEN Blit[s.fb2, s.buffer2]; }; bitBlitTable: PrincOps.BBTableSpace; blit _ PrincOpsUtils.AlignedBBTable[@bitBlitTable]; s _ NEW[SavedRec_[ col: col, x: x, y: y, w: w, h: h ]]; IF s.col THEN { s.fb1 _ Terminal.GetColorFrameBufferA[vt]; IF s.fb1=NIL THEN s.fb1 _ Terminal.GetBWFrameBuffer[vt];--bad color mode change s.buffer1 _ AllocateBitmap[PixToWords[s.w, s.fb1.bitsPerPixel], s.h]; IF Terminal.GetColorMode[vt].full THEN { s.fb2 _ Terminal.GetColorFrameBufferB[vt]; IF s.fb2#NIL THEN s.buffer2 _ AllocateBitmap[PixToWords[s.w, s.fb2.bitsPerPixel], s.h]; }; Terminal.ModifyColorFrame[vt, DoWithFrame]; } ELSE { s.fb1 _ Terminal.GetBWFrameBuffer[vt]; s.buffer1 _ AllocateBitmap[PixToWords[s.w, s.fb1.bitsPerPixel], s.h]; Blit[s.fb1, s.buffer1]; } }; Restore: PROC [s: REF SavedRec] = TRUSTED { blit: PrincOps.BBptr; Blit: PROC [fb: Terminal.FrameBuffer, buffer: REF] = TRUSTED INLINE { blit.flags _ bBFlags; blit.src _ PrincOps.BitAddress[LOOPHOLE[buffer], 0, 0]; blit.srcDesc.srcBpl _ PixToWords[s.w, fb.bitsPerPixel]*Basics.bitsPerWord; blit.dst _ PrincOps.BitAddress[ word: fb.base + Basics.LongMult[s.y, fb.wordsPerLine] + s.x*fb.bitsPerPixel/Basics.bitsPerWord, reserved: 0, bit: s.x*fb.bitsPerPixel MOD Basics.bitsPerWord ]; blit.dstBpl _ fb.bitsPerPixel*fb.width; blit.width _ s.w*fb.bitsPerPixel; blit.height _ s.h; PrincOpsUtils.BITBLT[blit]; }; DoWithFrame: PROC [] = TRUSTED { Blit[s.fb1, s.buffer1]; IF s.buffer2#NIL THEN Blit[s.fb2, s.buffer2]; }; bitBlitTable: PrincOps.BBTableSpace; blit _ PrincOpsUtils.AlignedBBTable[@bitBlitTable]; IF s.col THEN Terminal.ModifyColorFrame[vt, DoWithFrame] ELSE Blit[s.fb1, s.buffer1]; }; <<>> <<>> <<--timeout nonsense>> SetUpTimeOutWatcher: PROC [i: NAT] = { <<--monitored call only>> timedOut _ FALSE; IF i<=0 OR i>10000 THEN timeOutKey _ NIL --upper limit to prevent overflow ELSE { timeOutKey _ NEW[BasicTime.GMT _ BasicTime.Update[BasicTime.Now[], i]]; TRUSTED {Process.Detach[FORK TimeOutWatcherProcess[key: timeOutKey]]}; } }; timedOut: BOOL; timeOutKey: REF BasicTime.GMT _ NIL; --NIL means no time out expected; SetUpTimeOutWatcher is only writer TimeOutWatcherProcess: PROC [key: REF BasicTime.GMT] = { <<--does not modify timeOutKey>> <<--never called with key=NIL>> <<--TimeOutWatcherProcess is NOT monitored>> CedarProcess.SetPriority[excited]; DO Process.Pause[Process.MsecToTicks[500]]; IF timeOutKey#key THEN RETURN; --invalid invocation of TimeOutWatcherProcess IF moduleFree THEN RETURN; --not timed out IF BasicTime.Period[from: key^, to: BasicTime.Now[]]>0 THEN { --time out SetTimeOut[key]; }; ENDLOOP; }; <<>> <<--help and move >> helpSave: REF SavedRec _ NIL; NthRestFirstRope: PROC [list: LIST OF Rope.ROPE, n: INTEGER] RETURNS [r: Rope.ROPE_NIL] = INLINE { FOR l: LIST OF Rope.ROPE _ list, l.rest WHILE l#NIL DO IF n<=0 THEN {r _ l.first; EXIT}; n _ n-1; ENDLOOP; }; Box: PROC [x, y, w, h, border: INTEGER] = { Imager.SetColor[context, Imager.white]; Imager.MaskRectangleI[context, x, y, w, h]; Imager.SetColor[context, Imager.black]; Imager.MaskRectangleI[context, x, y, border, h]; Imager.MaskRectangleI[context, x+w-border, y, border, h]; Imager.MaskRectangleI[context, x, y, w, border]; Imager.MaskRectangleI[context, x, y+h-border, w, border]; }; HelpMessage: PROC [n: INTEGER] = { msg: Rope.ROPE _ NIL; Draw: PROC [] = { border: NAT ~ 2; below: NAT ~ 2; y: INTEGER; e: ImagerFont.Extents _ ImagerFont.RopeBoundingBox[font, msg]; h: INTEGER _ Real.FixI[MIN[e.descent+e.ascent+2*border]]; --text height w: INTEGER _ Real.FixI[MIN[e.rightExtent-e.leftExtent+2*border+1, sWidth]]; --text width ty: INTEGER _ mY+mHeight+below; --text boxes upper y in screen coordinates tx: INTEGER _ MIN[mX, sWidth-w]; --text boxes left x in screen coordinates IF ty+h>=sHeight THEN { ty _ mY-h-below; IF ty<0 THEN RETURN; }; helpSave _ Save[tx, ty, w, h, mOnColor]; y _ sHeight-ty-h; Box[tx, y, w, h, 1]; Imager.SetColor[context, Imager.black]; Imager.SetXY[context, [(tx+border)-e.leftExtent, y+border+e.descent]]; Imager.ShowRope[context, msg]; }; IF n#gHelpOn THEN { gHelpOn _ n; IF helpSave#NIL THEN {Restore[helpSave]; helpSave _ NIL}; msg _ NthRestFirstRope[gHelp, n]; IF ~Rope.InlineIsEmpty[msg] THEN Imager.DoSave[context, Draw]; } }; MoveCursor: ENTRY PROC [x, y: INTEGER, col: BOOL] = { ENABLE UNWIND => NULL; InvertPictureLine: PROC [pos: NAT] = INLINE { Imager.MaskRectangleI[context, mX+borderW, sHeight-mY-borderW-lineHeight*pos, mWidth-border2W, lineHeight]; }; sel: NAT _ 0; <<--Cursors.GetCursorInfo[].hotX.. is already included in x, y by window package...>> IF allDone THEN RETURN; IF col=mOnColor THEN IF x>mX+blackBorderW AND xmY-lineHeight THEN {gHelpMode _ TRUE; HelpMessage[0]} } ELSE IF y> ProtectedNotify: PROC [input: LIST OF REF ANY] = { IF allDone THEN SetDone[] ELSE { FOR list: LIST OF REF ANY _ input, list.rest WHILE list#NIL DO WITH input.first SELECT FROM coords: TIPUser.TIPScreenCoords => MoveCursor[coords^.mouseX, sHeight-coords^.mouseY, coords^.color]; atom: ATOM => IF atom=$Done THEN SetDone[] ELSE IF atom=$Escaped THEN { escaped _ TRUE; SetDone[]; }; ENDCASE => NULL; ENDLOOP }; }; ProtectedNotify[input ! RuntimeError.UNCAUGHT => GOTO failed]; EXITS failed => {gSelection _ 0; SetDone[]}; }; <<>> <<-- the main stuff>> Request: PUBLIC PROC [ header: Rope.ROPE, choice: LIST OF Rope.ROPE, headerDoc: Rope.ROPE, choiceDoc: LIST OF Rope.ROPE, default: NAT _ 0, timeOut: NAT _ 0, position: REF _ NIL ] RETURNS [selection: INT _ 0] = { ENABLE UNWIND => Leave[]; ComputeMenuPosition: PROC [] = INLINE { <<-- sets variables lastMouse and mOnColor>> <<-- Only use real cursor coordinates if interval since last popup menu call is big enough>> <<-- Reuse same position if call is immediately following, and is using a different menu;>> <<-- In doupt change position, to make it possible to visualize area below pop up menu. >> DefaultPos: PROC [] = INLINE{ <<--default: use position position or last position according of time>> IF BasicTime.Period[from: lastRemoved, to: BasicTime.Now[]]>0 THEN { h: INTEGER ~ mHeight/3; lastMouse _ Interminal.GetMousePosition[]; <<--offset menu [creature comfort]>> IF lastMouse.mouseX>mWidth THEN lastMouse.mouseX _ lastMouse.mouseX-mWidth; IF lastMouse.mouseY>h THEN lastMouse.mouseY _ lastMouse.mouseY-h; }; <<--else reuse last position position>> }; IF gMouse=NIL THEN DefaultPos[] ELSE WITH gMouse SELECT FROM m: TIPUser.TIPScreenCoords => { frame: Terminal.FrameBuffer _ IF m.color THEN Terminal.GetColorFrameBufferA[vt] ELSE Terminal.GetBWFrameBuffer[vt]; lastMouse _ [mouseX: m.mouseX, mouseY: frame.height-m.mouseY, color: m.color]; }; m: REF Interminal.MousePosition => lastMouse _ m^; ENDCASE => lastMouse _ Interminal.GetMousePosition[]; mOnColor _ lastMouse.color; }; WithViewerLock: PROC [] = { saved: REF SavedRec _ PrepareMenu[]; escaped _ gHelpMode _ FALSE; gHelpOn _ -1; Imager.DoSave[context, PaintMenu]; CheatDefaultMousePos[]; SetUpTimeOutWatcher[timeOut]; Wait[]; RemoveMenu[saved]; }; Enter[]; InputFocus.PushInputFocus[]; InputFocus.CaptureButtons[PopUpNotify, tipTable]; Cursors.SetCursor[menu]; gDefault _ default; gLabel _ header; gChoice _ choice; gMouse _ position; gHelp _ CONS[headerDoc, choiceDoc]; MenuSizeInPixels[header, choice]; DO ComputeMenuPosition[]; gSelection _ 0; IF mOnColor THEN ViewerLocks.CallUnderColumnLock[WithViewerLock, color] ELSE ViewerLocks.CallUnderViewerTreeLock[WithViewerLock]; IF ~escaped THEN EXIT; gMouse _ $Escaped ENDLOOP; InputFocus.ReleaseButtons[]; InputFocus.PopInputFocus[]; IF timedOut THEN selection _ -1 ELSE selection _ gSelection; gMouse _ NIL; Leave[]; }; MenuSizeInPixels: PROC [header: Rope.ROPE, gChoice: LIST OF Rope.ROPE] = INLINE { <<--computes lines and width (in pixels) of menu and save area>> <<--sets variables mWidth, mHeight>> lines, width: NAT _ 0; IF header#NIL THEN { lines _ 1; width _ Real.RoundI[ImagerFont.RopeWidth[font, header].x]; }; gTitleLines _ lines; FOR l: LIST OF Rope.ROPE _ gChoice, l.rest WHILE l#NIL DO lines _ lines+1; width _ MAX[width, Real.RoundI[ImagerFont.RopeWidth[font, l.first].x]]; IF lines>25 THEN EXIT; ENDLOOP; mWidth _ width + border2W; mHeight _ lines*lineHeight + border2W; }; PrepareMenu: PROC [] RETURNS [saved: REF SavedRec] = INLINE { frameBuffer: Terminal.FrameBuffer_NIL; IF mOnColor THEN { frameBuffer _ Terminal.GetColorFrameBufferA[vt]; context _ ViewerPrivate.CreateContext[color]; }; IF ~mOnColor OR frameBuffer=NIL THEN { mOnColor _ FALSE; frameBuffer _ Terminal.GetBWFrameBuffer[vt]; context _ ImagerTerminal.BWContext[vt: vt, pixelUnits: TRUE]; }; sHeight _ frameBuffer.height; sWidth _ frameBuffer.width; mWidth _ MIN[mWidth, sWidth]; mHeight _ MIN[mHeight, frameBuffer.height]; mX _ MIN[MAX[0, lastMouse.mouseX], sWidth-mWidth]; mY _ MIN[MAX[0, lastMouse.mouseY], sHeight-mHeight]; saved _ Save[mX, mY, mWidth, mHeight, mOnColor]; context.SetFont[font]; }; RemoveMenu: PROC [saved: REF SavedRec] = INLINE { IF helpSave#NIL THEN { Restore[helpSave]; helpSave _ NIL }; Restore[saved]; lastRemoved _ BasicTime.Now[]; }; PaintMenu: PROC [] = { <<--must be called with DoSave; changes state>> tidleAdd: NAT ~ 3; baseLine: NAT ~ 4; h: INTEGER _ mHeight-borderW+baseLine; Imager.TranslateT[context, [mX, sHeight-mY-mHeight]]; Imager.ClipRectangleI[context, 0, 0, mWidth, mHeight]; Box[0, 0, mWidth, mHeight, blackBorderW]; IF gLabel#NIL THEN { h _ h-lineHeight; Imager.SetXYI[context, borderW, h+tidleAdd]; Imager.ShowRope[context, gLabel]; }; FOR list: LIST OF Rope.ROPE _ gChoice, list.rest WHILE list#NIL DO h _ h-lineHeight; --clipped if to large Imager.SetXYI[context, borderW, h]; Imager.ShowRope[context, list.first]; ENDLOOP; Imager.SetColor[context, ImagerBackdoor.invert]; IF gTitleLines=1 THEN Imager.MaskRectangleI[context, blackBorderW, mHeight-borderW-lineHeight+1, mWidth-2*blackBorderW, lineHeight+1 ] }; CheatDefaultMousePos: PROC [] = INLINE { <<--sets the cursor such that it points into the default field>> IF gDefault#0 THEN { Cursory.SetMousePosition[vt, [ --ignores color bit mX+mWidth/2, ((gDefault-(1-gTitleLines))*lineHeight+mY+lineHeight/2) ]]; }; }; InitFontGlobals: UserProfile.ProfileChangedProc = { change: INT _ MAX[-whiteBorderW, MIN[30, UserProfile.Number["PopUpSelection.LineHeightChange", 0]] ]; font _ VFonts.EstablishFont[ family: UserProfile.Token["PopUpSelection.FontFamily", "Helvetica"], size: UserProfile.Number["PopUpSelection.FontSize", 10], bold: UserProfile.Boolean["PopUpSelection.FontBold", FALSE], italic: UserProfile.Boolean["PopUpSelection.FontItalic", FALSE], defaultOnFailure: TRUE ]; lineHeight _ VFonts.FontHeight[font]+whiteBorderW+change; <<--to bad, if font and lineHeight are not changed atomic... >> }; InitTipTable: PROC [] = { tipTable _ TIPUser.InstantiateNewTIPTable["PopUpSelection.tip" ! RuntimeError.UNCAUGHT => CONTINUE]; IF tipTable=NIL THEN tipTable _ TIPUser.InstantiateNewTIPTable["[Cedar]PopUpMenus>PopUpSelection.tip"]; <<--do not catch errors again; land in debugger>> }; KeepQuiet: Commander.CommandProc = { }; UserProfile.CallWhenProfileChanges[InitFontGlobals]; InitTipTable[]; Leave[]; --initializes monitor locks Commander.Register["///Commands/PopUpMenu", KeepQuiet, "Loads PopUpMenu module"]; <> END.