PopUpSelectionImpl.mesa
Copyright © 1983, 1986 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, November 9, 1983 12:14 pm
Last Edited by: Christian Jacobi, August 26, 1986 10:31:27 am PDT
Last Edited by: Pier, June 23, 1986 11:39:21 am PDT
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
DebugProcess: PROC = {
DO -- forever
Process.Pause[Process.MsecToTicks[1000]];
IF Terminal.GetKeys[vt][ESC]=down THEN SetDone[];
ENDLOOP;
};
--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�LSE]
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 x<mX+mWidth-blackBorderW
THEN {
IF y<=mY+borderW
THEN {
IF y>mY-lineHeight THEN {gHelpMode ← TRUE; HelpMessage[0]}
}
ELSE
IF y<mY+mHeight-borderW
THEN
sel ← (1-gTitleLines)+(y-borderW-mY)/lineHeight;
};
IF gSelection#sel
THEN {
context.SetColor[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 = {
--made sequential 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 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]<CedarChest6.1>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"];
TRUSTED {Process.Detach[FORK DebugProcess[]]};
END.