<> <> <> <> <> <> <> <> DIRECTORY BasicTime USING [GMT, Now, Period, Update], CedarProcess USING [Priority, SetPriority], Cursors, MultiCursors, Imager USING [black, ClipRectangleI, Context, DoSave, Font, MaskRectangleI, SetColor, SetFont, SetXY, SetXYI, ShowRope, TranslateT, white], ImagerBackdoor USING [DiscardBuffer, invert, RestoreBuffer, SaveBufferRectangle, ViewReset], ImagerFont USING [Extents, RopeBoundingBox, RopeEscapement], InputFocus USING [CaptureButtons, PopInputFocus, PushInputFocus, ReleaseButtons], <> <> PopUpSelection USING [], Process USING [Detach, MsecToTicks, PauseMsec], Real USING [Fix, Round], Rope USING [Concat, IsEmpty, ROPE], RuntimeError USING [UNCAUGHT], SystemNames USING [CedarDir], TIPUser USING [InstantiateNewTIPTable, TIPScreenCoords, TIPTable], <> UserProfile USING [Boolean, CallWhenProfileChanges, Number, ProfileChangedProc, Token], VFonts USING [EstablishFont, FontAscent, FontHeight], ViewerClasses USING [NotifyProc, MouseButton], ViewerLocks USING [CallUnderColumnLock, CallUnderViewerTreeLock], ViewerPrivate USING [CreateContext], ViewerSpecs USING [bwScreenHeight, bwScreenWidth, colorScreenHeight, colorScreenWidth]; PopUpSelectionImpl: CEDAR MONITOR IMPORTS BasicTime, CedarProcess, Cursors, MultiCursors, Imager, ImagerBackdoor, ImagerFont, InputFocus, --PeriodicalFork,-- Process, Real, Rope, RuntimeError, SystemNames, TIPUser, --UserInput,-- UserProfile, VFonts, ViewerLocks, ViewerPrivate, ViewerSpecs EXPORTS PopUpSelection = BEGIN <<>> <<--global variables are protected with MONITOR Enter and Leave>> sHeight, sWidth: INTEGER ¬ 0; -- size of screen, in pixels; [screen containing menu] mHeight, mWidth: INTEGER ¬ 0; -- size of menu, in pixels mx, my: INTEGER ¬ 0; -- menu position, in context coordinates, lower left point context: Imager.Context; -- menu context mOnColor: BOOL ¬ FALSE; -- menu [NOT cursor] on color screen lastRemoved: BasicTime.GMT ¬ BasicTime.Now[]; --for crazy heuristics MousePosition: TYPE ~ RECORD [x, y: INTEGER, display: REF ¬ NIL]; lastMouse: MousePosition ¬ [0, 0, NIL]; -- at start; remember between calls is creature comfort allwaysHelp: BOOL ¬ FALSE; reCheck: CONDITION ¬ [Process.MsecToTicks[2000]]; 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; -- 0 or 1 header lines gLabel: Rope.ROPE; gChoice: LIST OF Rope.ROPE ¬ NIL; gDefault: NAT; gMouse: REF ¬ NIL; gRefMouseButton: REF ViewerClasses.MouseButton ¬ NIL; gHelp: LIST OF Rope.ROPE; gHelpOn: INTEGER ¬ -1; gHelpMode: BOOL ¬ FALSE; tipTable: TIPUser.TIPTable; font: Imager.Font ¬ NIL; lineHeight: INTEGER ¬ 0; descent: INTEGER ¬ 0; <> <> <> <<};>> <<};>> <<>> <<--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 }; <<>> <<--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.PauseMsec[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: ATOM ¬ NIL; NthRestFirstRope: PROC [list: LIST OF Rope.ROPE, n: INTEGER] RETURNS [r: Rope.ROPE¬NIL] = { 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] = { IF n#gHelpOn THEN { msg: Rope.ROPE ¬ NIL; gHelpOn ¬ n; IF helpSave#NIL THEN { ImagerBackdoor.RestoreBuffer[context, helpSave]; ImagerBackdoor.DiscardBuffer[context, helpSave]; helpSave ¬ NIL }; msg ¬ NthRestFirstRope[gHelp, n]; IF ~Rope.IsEmpty[msg] THEN { border: NAT ~ 2; below: NAT ~ 2; e: ImagerFont.Extents ¬ ImagerFont.RopeBoundingBox[font, msg]; h: INTEGER ¬ Real.Fix[MIN[e.descent+e.ascent+2*border]]; --text height w: INTEGER ¬ Real.Fix[MIN[e.rightExtent-e.leftExtent+2*border+1, sWidth]]; --text width ty: INTEGER ¬ my-h-below; --text boxes lower y in context coordinates tx: INTEGER ¬ MIN[mx, sWidth-w]; --text boxes left x in context coordinates IF ty<0 THEN { ty ¬ my+mHeight+below; IF ty>=sHeight THEN RETURN; }; ImagerBackdoor.SaveBufferRectangle[context, helpSave ¬ $Help, [tx, ty, w, h]]; Box[tx, ty, w, h, 1]; Imager.SetColor[context, Imager.black]; Imager.SetXY[context, [(tx+border)-e.leftExtent, ty+border+e.descent]]; Imager.ShowRope[context, msg]; }; } }; MoveCursor: ENTRY PROC [x, y: INTEGER, col: BOOL] = { ENABLE UNWIND => NULL; InvertPictureLine: PROC [pos: NAT] = { Imager.MaskRectangleI[context, mx+borderW, my+mHeight-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+mHeight-borderW THEN { IF ymy+borderW THEN sel ¬ (1-gTitleLines) + (my+mHeight-borderW-y)/lineHeight; }; IF gSelection#sel THEN { Imager.SetColor[context, ImagerBackdoor.invert]; IF gSelection#0 THEN InvertPictureLine[gSelection+gTitleLines]; gSelection ¬ sel; IF gSelection#0 THEN InvertPictureLine[gSelection+gTitleLines]; IF gHelpMode THEN HelpMessage[gSelection]; }; }; PopUpNotify: ViewerClasses.NotifyProc = { <<--called sequentially only by viewer package>> 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 list.first SELECT FROM coords: TIPUser.TIPScreenCoords => MoveCursor[coords­.mouseX, coords­.mouseY, coords­.color]; atom: ATOM => { mb: REF ViewerClasses.MouseButton ¬ gRefMouseButton; SELECT atom FROM $DoneRed => IF mb#NIL THEN mb­ ¬ red; $DoneYellow => IF mb#NIL THEN mb­ ¬ yellow; $DoneBlue => IF mb#NIL THEN mb­ ¬ blue; $Escaped => escaped ¬ TRUE; ENDCASE => LOOP; SetDone[]; }; ENDCASE => {}; ENDLOOP; }; ProtectedNotify[input ! RuntimeError.UNCAUGHT => GOTO failed]; EXITS failed => {gSelection ¬ 0; SetDone[]}; }; 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 [] = { <<-- 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 [] = { <<--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.x, lastMouse.y, lastMouse.display] ¬ MultiCursors.GetAMousePosition[NIL]; <<--offset menu [creature comfort]>> IF lastMouse.x>mWidth THEN lastMouse.x ¬ lastMouse.x-mWidth; IF lastMouse.y>h THEN lastMouse.y ¬ lastMouse.y-h; }; <<--else reuse last position position>> }; IF gMouse=NIL THEN DefaultPos[] ELSE WITH gMouse SELECT FROM m: TIPUser.TIPScreenCoords => lastMouse ¬ [x: m.mouseX, y: m.mouseY, display: IF m.color THEN $color ELSE NIL]; -- display is probably bogus - mfp m: REF MousePosition => lastMouse ¬ m­; -- How could this ever happen?? m: REF ViewerClasses.MouseButton => {gRefMouseButton ¬ m; DefaultPos[]}; ENDCASE => [lastMouse.x, lastMouse.y, lastMouse.display] ¬ MultiCursors.GetAMousePosition[NIL]; <<--sorry but for now only one screen is implemented>> <> mOnColor ¬ FALSE; }; WithViewerLock: PROC [] = { saved: ATOM ¬ PrepareMenu[]; escaped ¬ FALSE; gHelpMode ¬ allwaysHelp; 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; gRefMouseButton ¬ NIL; Leave[]; }; MenuSizeInPixels: PROC [header: Rope.ROPE, gChoice: LIST OF Rope.ROPE] = { <<--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.Round[ImagerFont.RopeEscapement[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.Round[ImagerFont.RopeEscapement[font, l.first].x]]; IF lines>32 THEN EXIT; --prevent menu which does not fit on screen ENDLOOP; mWidth ¬ width + border2W; mHeight ¬ lines*lineHeight + border2W; }; PrepareMenu: PROC [] RETURNS [saved: ATOM] = { IF mOnColor THEN { sHeight ¬ ViewerSpecs.colorScreenHeight; sWidth ¬ ViewerSpecs.colorScreenWidth; context ¬ ViewerPrivate.CreateContext[color]; } ELSE { sHeight ¬ ViewerSpecs.bwScreenHeight; sWidth ¬ ViewerSpecs.bwScreenWidth; context ¬ ViewerPrivate.CreateContext[main]; }; ImagerBackdoor.ViewReset[context]; mWidth ¬ MIN[mWidth, sWidth]; mHeight ¬ MIN[mHeight, sHeight]; mx ¬ lastMouse.x; IF mx<0 THEN mx ¬ 0 ELSE IF mx>sWidth-mWidth THEN mx ¬ sWidth-mWidth; my ¬ lastMouse.y; IF my<0 THEN my ¬ 0 ELSE IF my>sHeight-mHeight THEN my ¬ sHeight-mHeight; ImagerBackdoor.SaveBufferRectangle[context, saved ¬ $Menu, [mx, my, mWidth, mHeight]]; Imager.SetFont[context, font]; }; RemoveMenu: PROC [saved: ATOM] = { IF helpSave#NIL THEN { ImagerBackdoor.RestoreBuffer[context, helpSave]; ImagerBackdoor.DiscardBuffer[context, helpSave]; helpSave ¬ NIL }; ImagerBackdoor.RestoreBuffer[context, saved]; ImagerBackdoor.DiscardBuffer[context, saved]; lastRemoved ¬ BasicTime.Now[]; }; PaintMenu: PROC [] = { <<--must be called with DoSave; does translation>> tidleAdd: NAT ~ 3; y: INTEGER ¬ mHeight-borderW+descent; Imager.TranslateT[context, [mx, my]]; Imager.ClipRectangleI[context, 0, 0, mWidth, mHeight]; Box[0, 0, mWidth, mHeight, blackBorderW]; IF gLabel#NIL THEN { y ¬ y-lineHeight; Imager.SetXYI[context, borderW, y+tidleAdd]; Imager.ShowRope[context, gLabel]; }; FOR list: LIST OF Rope.ROPE ¬ gChoice, list.rest WHILE list#NIL DO y ¬ y-lineHeight; --clipped if to large Imager.SetXYI[context, borderW, y]; 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 [] = { <<--sets the cursor such that it points into the default field>> IF gDefault#0 THEN { yDownFromMenuTop: INTEGER ¬ (gDefault+gTitleLines)*lineHeight-lineHeight/2; MultiCursors.SetAMousePosition[x: mx+mWidth/2, y: my + mHeight - yDownFromMenuTop, cursor: NIL]; }; }; ProfileChanged: UserProfile.ProfileChangedProc = { <<--reset the font globals>> 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; descent ¬ VFonts.FontHeight[font]-VFonts.FontAscent[font]; allwaysHelp ¬ UserProfile.Boolean["PopUpSelection.AllwaysHelp", TRUE] }; InitTipTable: PROC [] = { tipTable ¬ TIPUser.InstantiateNewTIPTable["PopUpSelection.tip" ! RuntimeError.UNCAUGHT => CONTINUE]; IF tipTable=NIL THEN tipTable ¬ TIPUser.InstantiateNewTIPTable[Rope.Concat[SystemNames.CedarDir["PopUpMenus"], "PopUpSelection.tip"]]; <<--do not catch errors again; land in debugger>> }; UserProfile.CallWhenProfileChanges[ProfileChanged]; InitTipTable[]; Leave[]; --initializes monitor locks <> END.