
<<ExtractKids.mesa; >>
<<Last Edited by: Sweet, September 27, 1985 9:13:54 am PDT>>
DIRECTORY
Ascii,
Basics,
Buttons,
Commander USING [CommandProc, Register],
CommandTool,
Containers USING [ChildXBound, ChildYBound, Container, Create],
FS,
IO,
MessageWindow,
RefText,
Rope,
Rules USING [Create, Rule],
OldSortDirDefs,
TypeScript,
VFonts,
ViewerClasses USING [Viewer, ViewerClassRec],
ViewerIO USING [CreateViewerStreams],
ViewerOps USING [PaintViewer],
ViewerTools USING [GetContents, MakeNewTextViewer, SetSelection];
ExtractKids: CEDAR PROGRAM                
IMPORTS Buttons, Commander, CommandTool, Containers, FS, IO, MessageWindow, RefText, Rope, Rules, TypeScript, VFonts, ViewerIO, 
ViewerOps, ViewerTools =
BEGIN OPEN OldSortDirDefs;
<<The Containers interface is used to create an outer envelope or "container" for the different sections below.  For uniformity, we 
define some standard distances between entries in the tool.>>
entryHeight: CARDINAL = 15;    -- how tall to make each line of items
entryVSpace: CARDINAL = 8;     -- vertical leading space between lines
entryHSpace: CARDINAL = 10;     -- horizontal space between items in a line
ROPE: TYPE = Rope.ROPE;
STREAM: TYPE = IO.STREAM;
dash: CHAR = Ascii.ControlV;


PromptRec: TYPE = RECORD [
handle: Handle, viewer: ViewerClasses.Viewer _ NIL];
PromptHandle: TYPE = REF PromptRec;
MakeTool: Commander.CommandProc = BEGIN
rule: Rules.Rule;
my: Handle _ NEW[MyRec];
my.outer _ Containers.Create[[-- construct the outer container
name: "Kid extractor",    -- name displayed in the caption
iconic: TRUE,            -- so tool will be iconic (small) when first created
column: left,                -- initially in the left column
scrollable: FALSE ]];        -- inhibit user from scrolling contents
MakeCommands[my];        -- build each (sub)viewer in turn
rule _ Rules.Create [[parent: my.outer, wy: my.height, ww: my.outer.cw, wh: 2]];
Containers.ChildXBound[my.outer, rule];
my.height _ my.height + entryHeight + 2;    -- interline spacing
MakeTypescript[my];
ViewerOps.PaintViewer[my.outer, all];                -- reflect above change
END;

MakeTypescript: PROC [handle: Handle] = BEGIN    
handle.height _ handle.height + entryVSpace;    -- space down from the top of the viewer
handle.ts _ TypeScript.Create[
info: [name: "ExtKids.ts", wy: handle.height, parent: handle.outer, border: FALSE ]];
[handle.tsIn, handle.tsOut] _ ViewerIO.CreateViewerStreams [
name: "ExtKids.ts", viewer: handle.ts, backingFile: "ExtKids.ts", editedStream: FALSE];
Containers.ChildXBound[handle.outer, handle.ts];
Containers.ChildYBound[handle.outer, handle.ts];
END;
MakeCommands: PROC [handle: Handle] = BEGIN    
initialData: Rope.ROPE = NIL;
wx: INT _ 0;
NewLine: PROC = {handle.height _ handle.height + entryHeight + entryVSpace; wx _ 0};
LabeledItem: PROC [label: ROPE, width: INT, data: ROPE _ NIL] 
RETURNS [v: ViewerClasses.Viewer] = {
ph: PromptHandle _ NEW [PromptRec _ [handle: handle]];
t: Buttons.Button _ Buttons.Create[
info: [
name: Rope.Concat[label, ":"], 
wy: handle.height,
<<default the width so that it will be computed for us -->>
wh: entryHeight,    -- specify rather than defaulting so line is uniform
wx: wx,
parent: handle.outer,
border: FALSE ],
proc: Prompt,
clientData: ph];    -- this will be passed to our button proc
wx _ wx + t.ww + entryHSpace;
v _ ViewerTools.MakeNewTextViewer[ [
parent: handle.outer,
wx: wx,
wy: handle.height,
ww: width*VFonts.CharWidth['0],
wh: entryHeight,
data: data,
scrollable: FALSE,
border: FALSE]];
ph.viewer _ v;
wx _ wx + v.ww + entryHSpace};
Bool: PROC [label: ROPE, initial: BOOL] RETURNS [flag: REF BOOL] = {
t: Buttons.Button;
flag _ NEW[BOOL _ initial];
t _ Buttons.Create[
info: [
name: label, 
wx: wx,
wy: handle.height,
<<default the width so that it will be computed for us -->>
wh: entryHeight,    -- specify rather than defaulting so line is uniform
parent: handle.outer,
border: TRUE ],
proc: ToggleBool,
clientData: flag];    -- this will be passed to our button proc
Buttons.SetDisplayStyle[
 button: t, style: IF initial THEN $WhiteOnBlack ELSE $BlackOnWhite, paint: FALSE];
wx _ wx + t.ww + entryHSpace};
Cmd: PROC [label: ROPE, proc: Buttons.ButtonProc] = {
t: Buttons.Button _ Buttons.Create[
info: [
name: label, 
wx: wx,
wy: handle.height,
<<default the width so that it will be computed for us -->>
wh: entryHeight,    -- specify rather than defaulting so line is uniform
parent: handle.outer,
border: TRUE ],
proc: proc,
clientData: handle];    -- this will be passed to our button proc
wx _ wx + t.ww + entryHSpace};

NewLine[];
Cmd["Sort", DoIt];
NewLine[];

handle.cmd.workingDir _ LabeledItem["working directory", 50, CommandTool.CurrentWorkingDirectory[]];
NewLine[];

handle.cmd.inputFile _ LabeledItem["input", 50];
NewLine[];

handle.cmd.outputFile _ LabeledItem["output", 50];
NewLine[];

END;

ToggleBool: Buttons.ButtonProc  = {
switch: REF BOOL _ NARROW [clientData]; 
switch^ _ ~switch^;
Buttons.SetDisplayStyle[
 button: NARROW[parent], 
 style: IF switch^ THEN $WhiteOnBlack ELSE $BlackOnWhite];
};

Prompt: Buttons.ButtonProc -- [parent: REF ANY, clientData: REF ANY _ NIL, mouseButton: Menus.MouseButton _ red, shift: BOOL _ 
FALSE, control: BOOL _ FALSE] --   = BEGIN
<<force the selection into the user input field>>
ph: PromptHandle _ NARROW[clientData];
ViewerTools.SetSelection[ph.viewer];        -- force the selection
END;

DoIt: Buttons.ButtonProc -- [parent: REF ANY, clientData: REF ANY _ NIL, mouseButton: Menus.MouseButton _ red, shift: BOOL _ FALSE, 
control: BOOL _ FALSE] --   = BEGIN
<<force the selection into the user input field>>
handle: Handle _ NARROW[clientData];    -- get our data
BEGIN
ENABLE {
UNWIND => {IF handle.in # NIL THEN handle.in.Close[]; handle.in _ NIL};
Problem, ABORTED => {handle.tsOut.PutText[" aborted"]; GO TO done}};
iName: ROPE _ ViewerTools.GetContents[handle.cmd.inputFile];
oName: ROPE _ ViewerTools.GetContents[handle.cmd.outputFile];
    wDir: ROPE = ViewerTools.GetContents[handle.cmd.workingDir];

<<various initializations>>
handle.item _ NEW[EntrySeqBody[1000]];

<<do the work>>
IF iName = NIL OR oName = NIL THEN {
handle.tsOut.Put[[rope["specify file names"]], [character['\n]]];
RETURN};
    iName _ FS.ExpandName[iName, wDir ! 
        FS.Error => Quit[handle, "bad input file"]].fullFName;
handle.in _ OpenFile[iName];
IF handle.in # NIL THEN handle.eof _ FALSE
ELSE handle.eof _ TRUE;
    oName _ FS.ExpandName[oName, wDir ! 
        FS.Error => Quit[handle, "bad text output file"]].fullFName;
handle.out _ FS.StreamOpen[fileName: oName, accessOptions: $create];
handle.tsOut.PutText["Reading:"];
WHILE ~handle.eof DO
ProcessItem[handle];
IF handle.item.count MOD 50 = 0 THEN handle.tsOut.PutChar['.];
ENDLOOP;
handle.item _ NIL;
EXITS
done => NULL;
END; -- of Enable
IF handle.in # NIL THEN {handle.in.Close[]; handle.in _ NIL};
IF handle.out # NIL THEN {handle.out.Close[]; handle.out _ NIL};
handle.tsOut.Put[[character['\n]], [rope["done"]], [character['\n]]];
END;

LastName: PROC [name: ROPE] RETURNS [cf: ROPE] = {
cName: REF TEXT _ NEW[TEXT[Rope.Length[name]]]; -- plenty long
state: {last, pretitle, finished, mrsXm, mrsXr, mrsXs, dot, space, drXd, drXr} _ last; 
FOR i: INT IN [0..Rope.Length[name]) DO
c: CHAR _ Rope.Fetch[name, i];
SELECT c FROM
'*, '+ => LOOP;
', => EXIT;
ENDCASE => {cName[cName.length] _ c; cName.length _ cName.length + 1};
ENDLOOP;
RETURN[Rope.FromRefText[cName]]};

Problem: ERROR = CODE;

MyBreak: IO.BreakProc -- [char: CHAR] RETURNS [IO.CharClass] --  = {
RETURN [SELECT char FROM
'\\, '|, '}, '\n => break,
'\t, ', ' => sepr,
ENDCASE => other];
};

OpenFile: PROC [name: ROPE] RETURNS [st: STREAM] = {
st _ FS.StreamOpen[name, $read
! FS.Error => IF error.group # bug THEN CONTINUE]};

ProcessItem: PROC [handle: Handle] = {
e: REF Entry;
ns: STREAM _ NIL;
NameBreak: IO.BreakProc = {
RETURN [SELECT char FROM
'&, ', => break,
'\t => sepr, -- blanks are allowed in names
ENDCASE => other]};
GetName: PROC RETURNS [r: ROPE, uninteresting: BOOLEAN] = {
uninteresting _ FALSE;
[] _ ns.SkipWhitespace[];
IF ns.EndOf[] THEN RETURN [NIL, FALSE];
SELECT ns.PeekChar[] FROM
'+ => {uninteresting _ TRUE; [] _ ns.GetChar[]};
'* => {uninteresting _ TRUE; [] _ ns.GetChar[]};
ENDCASE;
r _ GetTokenRope[ns, NameBreak].token;
IF ~ns.EndOf[] THEN [] _ ns.GetChar[]};
num: LONG CARDINAL _ 0;
ninedigit: BOOL _ FALSE;
st: STREAM = handle.in;
IF handle.eof THEN RETURN;
IF handle.in = NIL THEN {
MessageWindow.Append[
message: "Please open a file first",
clearFirst: TRUE];
MessageWindow.Blink[ ];
ERROR ABORTED};
[] _ st.SkipWhitespace[];
IF st.EndOf[] THEN {handle.eof _ TRUE; GO TO done};
e _ ReadEntry[handle];
<<see if likely to be kids>>
    IF e.name[1] # NIL THEN {
        names: ARRAY SmallCount OF ROPE _ e.name;
        last: ROPE _ LastName[names[0]];
        e.name _ ALL[NIL];
        e.name[0] _ Rope.Cat[last, ", ", e.name[1]];
        FOR i: CARDINAL IN [1..SmallCount.LAST] DO
            ns _ IO.RIS[names[i]];
            DO
                firstName: ROPE;
                tooYoung: BOOL;
                [firstName, tooYoung] _ GetName[];
                IF firstName = NIL THEN EXIT;
                IF ~tooYoung THEN {
                    e.name[0] _ Rope.Cat[last, ", ", firstName];
                    WriteEntry[handle, e];
                    handle.out.PutRope["\n"];
                    };
                ENDLOOP;
            ENDLOOP;
        };
EXITS
done => NULL;
};

GrowItemRec: PROC [h: Handle] = {
n: CARDINAL;
new: EntrySeq;
IF h.item = NIL THEN n _ 1000 ELSE n _ h.item.max + 100;
new _ NEW[EntrySeqBody[n]];
IF h.item # NIL THEN {
FOR i: CARDINAL IN [0..h.item.count) DO
new[i] _ h.item[i];
ENDLOOP;
new.count _ h.item.count};
h.item _ new};

ReadEntry: PROC [handle: Handle] RETURNS [e: REF Entry] = {
<<one should SkipWhitespace before calling (and check for eof)>>
ENABLE IO.EndOfStream => {handle.eof _ TRUE; Quit[handle, "Syntax error "]};
st: STREAM _ handle.in;
ch: CHAR;
i: CARDINAL;
e _ NEW [Entry];
IF (ch _ st.GetChar[]) # '{ THEN Quit[handle, "Syntax error "];
i _ 0;
DO
e.phone[i] _ GetTokenRope[st, MyBreak].token;
SELECT (ch _ st.GetChar[]) FROM
'\\ => IF i = nLines-1 THEN Quit[handle, "Syntax error "];
'| => EXIT;
'} => RETURN;
ENDCASE => Quit[handle, "Syntax error "];
i _ i + 1;
ENDLOOP;
i _ 0;
DO
e.name[i] _ GetTokenRope[st, MyBreak].token;
SELECT (ch _ st.GetChar[]) FROM
'\\ => IF i = nLines-1 THEN Quit[handle, "Syntax error "];
'| => EXIT;
'} => RETURN;
ENDCASE => Quit[handle, "Syntax error "];
i _ i + 1;
ENDLOOP;
i _ 0;
DO
e.addr[i] _ GetTokenRope[st, MyBreak].token;
SELECT (ch _ st.GetChar[]) FROM
'\\ => IF i = nLines-1 THEN Quit[handle, "Syntax error "];
'| => EXIT;
'} => RETURN;
ENDCASE => GO TO badsyntax;
i _ i + 1;
ENDLOOP;
e.town _ GetTokenRope[st, MyBreak].token;
IF st.GetChar[] = '} THEN RETURN;
e.zip _ GetTokenRope[st, MyBreak].token;
IF st.GetChar[] = '} THEN RETURN;
GO TO badsyntax;
EXITS
badsyntax => Quit[handle, "Syntax error "];
};

WriteEntry: PROC [handle: Handle, e: REF Entry] = {
st: STREAM _ handle.out;
i: CARDINAL;
st.PutChar['{];
FOR i IN SmallCount WHILE e.phone[i] # NIL DO
IF i # 0 THEN st.PutChar['\\];
st.PutRope[e.phone[i]];
ENDLOOP;
st.PutRope["|\t"];
IF e.phone[0] = NIL THEN st.PutRope["\t\t\t\t"];
FOR i IN SmallCount WHILE e.name[i] # NIL DO
IF i # 0 THEN st.PutChar['\\];
st.PutRope[e.name[i]];
ENDLOOP;
IF e.addr[0] = NIL AND e.town = NIL AND e.zip = NIL THEN {
st.PutChar['}]; RETURN};
st.PutRope["|\t"];
FOR i IN SmallCount WHILE e.addr[i] # NIL DO
IF i # 0 THEN st.PutChar['\\];
st.PutRope[e.addr[i]];
ENDLOOP;
IF e.town = NIL AND e.zip = NIL THEN {st.PutChar['}]; RETURN};
st.PutRope["|\t"];
IF e.town # NIL THEN st.PutRope[e.town];
IF e.zip = NIL THEN {st.PutChar['}]; RETURN};
st.PutRope["|\t"];
st.PutRope[e.zip];
st.PutChar['}];
};

Quit: PROC [handle: Handle, reason: ROPE _ NIL] = {
    loc: INT _ 0;
    IF handle.in # NIL THEN {
        loc _ handle.in.GetIndex[];
    handle.in.Close[]; handle.in _ NIL;
        }; 
    handle.eof _ TRUE;
handle.tsOut.Put[[rope[reason]], [integer[loc]], [character['\n]]];
ERROR Problem};

<<copied from IOSearchImpl because it didn't handle empty tokens properly>>
GetToken: PROC [stream: STREAM, breakProc: IO.BreakProc, buffer: REF TEXT]
RETURNS[token: REF TEXT, charsSkipped: INT] = {
quit, include: BOOL _ FALSE;
anySeen: BOOL _ FALSE;
charsSkipped _ 0;
buffer.length _ 0;
DO
char: CHAR _
stream.GetChar[ ! IO.EndOfStream => IF buffer.length > 0 THEN EXIT ELSE REJECT];
SELECT breakProc[char] FROM
break => {include _ FALSE; quit _ TRUE};
sepr => {include _ FALSE; quit _ anySeen };
other => {include _ TRUE; quit _ FALSE; anySeen _ TRUE};
ENDCASE => ERROR;
IF include THEN buffer _ RefText.InlineAppendChar[buffer, char]
ELSE
IF quit THEN stream.Backup[char] ELSE charsSkipped _ charsSkipped + 1;
IF quit THEN EXIT;
ENDLOOP;
RETURN[buffer, charsSkipped];
};
GetTokenRope: PUBLIC PROC [stream: STREAM, breakProc: IO.BreakProc]
RETURNS [token: ROPE, charsSkipped: INT] = {
buffer: REF TEXT = RefText.ObtainScratch[100];
{ ENABLE UNWIND => RefText.ReleaseScratch[buffer];
tokenText: REF TEXT;
[tokenText, charsSkipped] _ GetToken[stream, breakProc, buffer];
token _ IF tokenText.length = 0 THEN NIL ELSE Rope.FromRefText[tokenText];
};
RefText.ReleaseScratch[buffer];
RETURN [token, charsSkipped];
};

<<Sort by various keys>>
<<>>

Commander.Register[key: "ExtractKids", proc: MakeTool,
doc: "Make cut at kids file" ];
[ ] _ MakeTool[NIL];    -- and create an instance
END.