SchemeTendrilsImpl.mesa
Copyright Ó 1988, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, March 10, 1992 11:12 am PST
Last changed by Pavel on September 1, 1988 6:12:33 pm PDT
DIRECTORY
Atom USING [GetPName, MakeAtom],
ColorDisplayManager USING [GetContext],
FS USING [Error, ExpandName],
Imager USING [Context, Error, GetProp, PutProp],
ImagerBackdoor USING [GetT, TransformPoint],
ImagerTransformation USING [Factor],
ImagerViewer USING [ClientDataFromViewer, Erase, EraseProc, FancyCreate, GetViewer, Reset],
IO USING [GetInfo],
Process USING [EnableAborts],
Rope USING [ROPE],
Scheme USING [Any, Complain, Cons, DefinePrimitive, Environment, false, Fixnum, Flonum, LookupVariableValue, MakeFixnum, NumberRep, Port, Primitive, ProperList, RegisterInit, Reverse, RopeFromString, Symbol, ThePort, TheString, true, undefined, unspecified],
StructuredStreams USING [Begin, Bp, ChangeMargin, Create, End, IsAnSS],
TiogaAccess USING [Create, Reset, WriteFile, Writer],
ScreenCoordsTypes USING [TIPScreenCoords, TIPScreenCoordsRec],
UnparserBuffer USING [BreakCondition, Handle, NewInittedHandle],
Vector2 USING [VEC],
ViewerClasses USING [DestroyProc, NotifyProc, Viewer],
ViewerOps USING [OpenIcon],
ViewerPrivate USING [CreateContext];
SchemeTendrilsImpl: CEDAR MONITOR LOCKS queue USING queue: InputQueue
IMPORTS Atom, ColorDisplayManager, FS, Scheme, Imager, ImagerBackdoor, ImagerTransformation, ImagerViewer, IO, Process, StructuredStreams, TiogaAccess, UnparserBuffer, ViewerOps, ViewerPrivate
~ BEGIN OPEN Scheme;
Generally Useful Types and Procedures
ROPE: TYPE ~ Rope.ROPE;
RopeFromSymbol: PROC [Symbol] RETURNS [ROPE] ~ Atom.GetPName;
PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any ¬ NIL];
The Scheme StructuredStreams and TiogaAccess Interfaces
TheWriter: PROC [a: Any] RETURNS [TiogaAccess.Writer] ~ INLINE {
WITH a SELECT FROM
w: REF TiogaAccess.Writer => RETURN [w­];
ENDCASE => Complain[a, "not a TiogaAccess Writer"];
};
TAPrim: PrimitiveProc ~ {
op: ATOM ~ NARROW[self.data];
result ¬ unspecified;
SELECT op FROM
$make => result ¬ NEW[TiogaAccess.Writer ¬ TiogaAccess.Create[]];
$test => result ¬ IF ISTYPE[a, REF TiogaAccess.Writer] THEN true ELSE false;
$writeFile => TiogaAccess.WriteFile[TheWriter[a], RopeFromString[TheString[b]]];
$reset => TiogaAccess.Reset[TheWriter[a]];
ENDCASE => ERROR;
};
RegisterTiogaAccess: PROC [env: Environment] ~ {
DefinePrimitive[name: "make-writer", nArgs: 0, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $make, doc: "create a TiogaAccess Writer"];
DefinePrimitive[name: "writer?", nArgs: 1, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $test, doc: "is this a TiogaAccess Writer?"];
DefinePrimitive[name: "write-file-from-writer", nArgs: 2, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $writeFile, doc: "write the contents of the Writer a to the file named by the string b and reset the Writer to a clean state"];
DefinePrimitive[name: "reset-writer", nArgs: 1, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $reset, doc: "reset the Writer a to a clean state"];
DefinePrimitive[name: "name", nArgs: , optional: , dotted: TRUE|FALSE, proc: TAPrim, env: env, data: $, doc: "string"];
};
TheINTEGER: PROC [a: Any] RETURNS [INTEGER] ~ INLINE {
WITH a SELECT FROM
n: Fixnum => RETURN [n­];
ENDCASE => Complain[a, "not a short integer"];
};
lookLeftSymbol: Symbol ~ Atom.MakeAtom["look-left"];
TheBreakCondition: PROC [a: Any] RETURNS [UnparserBuffer.BreakCondition] ~ INLINE {
WITH a SELECT FROM
sym: Symbol =>
SELECT sym FROM
$width => RETURN [width];
lookLeftSymbol => RETURN [lookLeft];
$united => RETURN [united];
$always => RETURN [always];
ENDCASE => Complain[a, "not a break condition (width look-left united always)"];
ENDCASE => Complain[a, "not a break condition (width look-left united always)"];
};
SSPrim: PrimitiveProc ~ {
op: ATOM ~ NARROW[self.data];
result ¬ unspecified;
SELECT op FROM
$make => {
h: UnparserBuffer.Handle;
WITH a SELECT FROM
writer: REF TiogaAccess.Writer => {
nestWidth: INTEGER ~ IF b = undefined THEN 3 ELSE TheINTEGER[b];
h ← UnparserBuffer.NewInittedHandle[[output: [access[writer^, nestWidth]]]];
};
port: Port => {
IF IO.GetInfo[port].variety = input THEN
Complain[a, "not an output port"];
h ¬ UnparserBuffer.NewInittedHandle[[output: [stream[port]]]];
};
ENDCASE => Complain[a, "not a port or TiogaAccess Writer"];
result ¬ StructuredStreams.Create[h];
};
$test => {
result ¬
WITH a SELECT FROM
port: Port => IF StructuredStreams.IsAnSS[port] THEN true ELSE false
ENDCASE => false;
};
$begin => StructuredStreams.Begin[ThePort[a]];
$end => StructuredStreams.End[ThePort[a]];
$break => {
port: Port ~ ThePort[a];
bc: UnparserBuffer.BreakCondition ~ TheBreakCondition[b];
offset: INTEGER ~ TheINTEGER[c];
sep: ROPE ~ IF rest = NIL THEN NIL ELSE RopeFromString[TheString[rest.car]];
StructuredStreams.Bp[port, bc, offset, sep];
};
$margin => StructuredStreams.ChangeMargin[ThePort[a], TheINTEGER[b]];
ENDCASE => ERROR;
};
RegisterStructuredStreams: PROC [env: Environment] ~ {
DefinePrimitive[name: "make-structured-port", nArgs: 2, optional: 1, dotted: FALSE, proc: SSPrim, env: env, data: $make, doc: "create a structured port backed by the port or TiogaAccess Writer a; b is the nesting-width of the writer"];
DefinePrimitive[name: "structured-port?", nArgs: 1, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $test, doc: "is this a structured port?"];
DefinePrimitive[name: "begin-structure", nArgs: 1, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $begin, doc: "output a Begin marker on the (structured) port a"];
DefinePrimitive[name: "end-structure", nArgs: 1, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $end, doc: "output a End marker on the (structured) port a"];
DefinePrimitive[name: "breakpoint", nArgs: 4, optional: 1, dotted: FALSE, proc: SSPrim, env: env, data: $break, doc: "output a breakpoint with type b, offset c and separator d on the (structured) port d"];
DefinePrimitive[name: "change-margin", nArgs: 2, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $margin, doc: "change the line-length of the (structured) port a to b"];
DefinePrimitive[name: "name", nArgs: , optional: , dotted: TRUE|FALSE, proc: SSPrim, env: env, data: $, doc: "string"];
};
The Scheme ImagerViewer Interface
TheContext: PROC [a: Any] RETURNS [Imager.Context] ~ {
WITH a SELECT FROM
ctx: Imager.Context => RETURN [ctx];
ENDCASE => Complain[a, "not an Imager Context"];
};
Flo: PROC [real: REAL] RETURNS [Flonum] ~ {
RETURN [NEW[NumberRep.flonum ¬ [FALSE, flonum[real]]]]
};
IVData: TYPE ~ REF IVDataRep;
IVDataRep: TYPE ~ RECORD [op: ATOM, env: Environment];
defaultContextName: Symbol ~ Atom.MakeAtom["*default-context*"];
ImagerPrim: PrimitiveProc ~ {
Inner: PROC RETURNS [result: Any ¬ unspecified] ~ {
iData: IVData ~ NARROW[self.data];
DefaultContext: PROC RETURNS [Imager.Context] ~ INLINE {
RETURN [TheContext[Scheme.LookupVariableValue[variable: defaultContextName, env: iData.env]]];
};
SELECT iData.op FROM
$colorcontext => { result ¬ ColorDisplayManager.GetContext[] };
$viewercontext => {
result ¬ MakeImagerViewerContext[RopeFromString[TheString[a]]];
};
$openViewer => {
context: Imager.Context ¬ IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[context];
ViewerOps.OpenIcon[viewer];
};
$viewerOpenP => {
context: Imager.Context ¬ IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[context];
result ¬ IF viewer.iconic THEN false ELSE true;
};
$resetViewer => {
context: Imager.Context ¬ IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
ImagerViewer.Reset[context];
};
$eraseViewer => {
context: Imager.Context ¬ IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
ImagerViewer.Erase[context];
};
$viewerread => {
context: Imager.Context ¬ IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
WITH Imager.GetProp[context: context, key: $SchemeViewerInput] SELECT FROM
queue: InputQueue => {
event: InputEvent ~ Dequeue[queue];
result ¬ event.args;
IF event.button # NIL THEN
result ¬ Cons[event.button, result];
IF event.action # $destroyed THEN {
point: Vector2.VEC;
IF event.action = $erased THEN {
Only scale the coordinates; they're a height and width.
scale: Vector2.VEC ~ ImagerTransformation.Factor[ImagerBackdoor.GetT[context]].s;
point ¬ [event.mx * scale.x, event.my * scale.y];
}
ELSE
point ¬ ImagerBackdoor.TransformPoint[context: context, p: [event.mx, event.my], from: view, to: client];
result ¬ Cons[Flo[point.y], result];
result ¬ Cons[Flo[point.x], result];
};
result ¬ Cons[event.action, result];
};
ENDCASE => { result ¬ false };
};
$viewerinputready => {
context: Imager.Context ¬ IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
WITH Imager.GetProp[context: context, key: $SchemeViewerInput] SELECT FROM
queue: InputQueue => {
result ¬ IF InputAvailable[queue] THEN true ELSE false;
};
ENDCASE => { result ¬ false };
};
$bwdisplaycontext => {
result ¬ ViewerPrivate.CreateContext[main];
};
$displayscreentopixelmap => {
result ← ImagerPixel.MakePixelMap[ImagerSample.MapFromFrameBuffer[Terminal.GetBWFrameBuffer[InterminalBackdoor.terminal]]];
};
ENDCASE => ERROR;
};
result ¬ Inner[ !
Imager.Error => { Complain[$ImagerError, error.explanation] };
FS.Error => { IF error.group = user THEN Complain[error.code, error.explanation] };
];
};
tipTableName: ROPE ~ FS.ExpandName["Scheme.tip"].fullFName;
MakeImagerViewerContext: PROC [name: ROPE] RETURNS [Imager.Context] ~ {
queue: InputQueue ~ MakeInputQueue[];
context: Imager.Context ~ ImagerViewer.FancyCreate[
info: [name: name],
units: pixels,
v: NIL,
notify: InputNotify,
destroy: InputDestroy,
erase: InputErase,
tipTable: tipTableName,
clientData: queue];
viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[context]; -- may want this someday
Imager.PutProp[context: context, key: $SchemeViewerInput, val: queue];
RETURN [context]
};
InputEvent: TYPE ~ RECORD [action: ATOM ¬ NIL, button: ATOM ¬ NIL, mx, my: INT ¬ 0, args: Any ¬ NIL];
InputQueue: TYPE ~ REF InputQueueRep;
InputQueueRep: TYPE ~ MONITORED RECORD [
ready: CONDITION,
count: CARD,
head: LIST OF InputEvent,
last: LIST OF InputEvent
];
MakeInputQueue: PROC RETURNS [InputQueue] ~ {
head: LIST OF InputEvent ~ LIST[[]];
queue: InputQueue ~ NEW[InputQueueRep ¬ [count: 0, head: head, last: head]];
TRUSTED { Process.EnableAborts[@queue.ready] };
RETURN [queue]
};
Enqueue: ENTRY PROC [queue: InputQueue, a: InputEvent] ~ {
queue.last ¬ queue.last.rest ¬ LIST[a];
IF queue.count = 0 THEN BROADCAST queue.ready;
queue.count ¬ queue.count + 1;
};
InputAvailable: ENTRY PROC [queue: InputQueue] RETURNS [BOOL] ~ {
RETURN [queue.count # 0]
};
Dequeue: ENTRY PROC [queue: InputQueue] RETURNS [a: InputEvent] ~ {
ENABLE UNWIND => NULL;
t: LIST OF InputEvent ¬ NIL;
WHILE queue.count = 0 DO WAIT queue.ready ENDLOOP;
t ¬ queue.head;
queue.head ¬ t.rest;
t.rest ¬ NIL;
a ¬ queue.head.first;
queue.count ¬ queue.count - 1;
};
InputDestroy: ViewerClasses.DestroyProc = {
[self: ViewerClasses.Viewer]
InputNotify[self, CONS[$destroyed, NIL]];
};
InputErase: ImagerViewer.EraseProc = {
[self: Imager.Context]
viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[self];
dimensions: ScreenCoordsTypes.TIPScreenCoords ~
NEW[ScreenCoordsTypes.TIPScreenCoordsRec ¬ [viewer.cw, viewer.ch, FALSE]];
InputNotify[viewer, CONS[$erased, CONS[dimensions, NIL]]];
};
InputNotify: ViewerClasses.NotifyProc = {
[self: ViewerClasses.Viewer, input: LIST OF REF ANY]
queue: InputQueue ~ NARROW[ImagerViewer.ClientDataFromViewer[self]];
mx: INT ¬ 0;
my: INT ¬ 0;
ctrlshift: INT ¬ 0;
includeCtrlShift: BOOL ¬ FALSE;
button: ATOM ¬ NIL;
Button: PROC [atom: ATOM] ~ { IF button = NIL THEN button ¬ atom ELSE bogus ¬ TRUE };
action: ATOM ¬ NIL;
Action: PROC [atom: ATOM] ~ { IF action = NIL THEN action ¬ atom ELSE bogus ¬ TRUE };
bogus: BOOL ¬ FALSE;
FOR tail: LIST OF REF ¬ input, tail.rest UNTIL tail = NIL DO
WITH tail.first SELECT FROM
z: ScreenCoordsTypes.TIPScreenCoords => {
mx ¬ z.mouseX;
my ¬ z.mouseY;
};
atom: ATOM => {
SELECT atom FROM
$Ctrl => { ctrlshift ¬ ctrlshift + 2 };
$Shift => { ctrlshift ¬ ctrlshift + 1 };
$Red => { Button[$left] };
$Yellow => { Button[$middle] };
$Blue => { Button[$right] };
$Track => {
Action[$mouseto];
includeCtrlShift ¬ TRUE;
};
$Down => {
Action[$buttondown];
includeCtrlShift ¬ TRUE;
};
$Up => {
Action[$buttonup];
includeCtrlShift ¬ TRUE;
};
ENDCASE => { Action[atom] };
};
ENDCASE => { bogus ¬ TRUE };
ENDLOOP;
IF action = NIL THEN bogus ¬ TRUE;
IF bogus THEN
Enqueue[queue, [action: $bogus, args: Reverse[Reverse[input]]]]
ELSE
Enqueue[queue, [action: action, button: button, mx: mx, my: my,
args: IF includeCtrlShift THEN Cons[MakeFixnum[ctrlshift], NIL] ELSE NIL]];
};
D: PROC [op: ATOM, env: Environment ¬ NIL] RETURNS [IVData] ~ {
RETURN [NEW [IVDataRep ¬ [op, env]]]
};
RegisterImagerViewers: PROC [env: Environment] ~ {
DefinePrimitive[name: "color-context", nArgs: 0, optional: 0, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$colorcontext], doc: "get an Imager context for the color display"];
DefinePrimitive[name: "viewer-context", nArgs: 1, optional: 0, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewercontext], doc: "make an ImagerViewer named a"];
DefinePrimitive[name: "open-viewer", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$openViewer, env], doc: "([context]) Open the viewer associated with this context"];
DefinePrimitive[name: "viewer-open?", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewerOpenP, env], doc: "([context]) Is the viewer associated with this context open?"];
DefinePrimitive[name: "reset-viewer", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$resetViewer, env], doc: "([context]) Reset this context to its inital state"];
DefinePrimitive[name: "erase-viewer", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$eraseViewer, env], doc: "([context]) Clear the viewer associated with this context"];
DefinePrimitive[name: "viewer-read", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewerread, env], doc: "([context]) get mouse input associated with an ImagerViewer"];
DefinePrimitive[name: "viewer-input-ready?", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewerinputready, env], doc: "([context]) test to see if ImagerViewer mouse input is available"];
DefinePrimitive[name: "bw-display-context", nArgs: 0, optional: 0, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$bwdisplaycontext, env], doc: "make an Imager context for the entire bw display (bypassing the window system)"];
DefinePrimitive[name: "display-screen->pixelmap", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, doc: "Make a pixelmap from the display screen of the machine", env: env, data: D[$displayscreentopixelmap, env]];
};
SchemeTendrils Initialization
RegisterInit[RegisterImagerViewers];
RegisterInit[RegisterStructuredStreams];
RegisterInit[RegisterTiogaAccess];
END.