
<<PLSupImpl.Mesa>>
<<Copyright (c) Xerox Corporation, 1983.  All rights reserved>>
<<last edit by Schmidt August 22, 1982 1:47 pm>>
<<last edit by Satterthwaite, April 18, 1986 5:04:46 pm PST>>

<<used to be Sup.Mesa>>

DIRECTORY
PL: TYPE USING [BlessLST, BlessString, GetSpecialNodes, Insert, LengthList,
LSTNode, LSTNodeRecord, Map, NewNail, Node, NodeRecord, RErr, rLST, rSTR, Z],
PString: TYPE USING [Item, NewStream, Stream],
Rope: TYPE USING [Equal, ROPE],
SafeStorage: TYPE USING [GetSystemZone--NewZone--];

PLSupImpl: CEDAR PROGRAM IMPORTS P:PL, S: PString, SafeStorage, Rope EXPORTS PL  = {
OPEN P;
<<>>
N: ZONE = P.Z;
PrefixedZone: ZONE;

LSTNode: TYPE = PL.LSTNode;
LSTNodeRecord: TYPE = PL.LSTNodeRecord;
NodeRecord: TYPE = PL.NodeRecord;
Node: TYPE = PL.Node;
ROPE: TYPE = Rope.ROPE;
<<>>
PBug: PUBLIC SIGNAL[ROPE] = CODE;
SErr: PUBLIC SIGNAL[est: ROPE] = CODE;
RErr: PUBLIC SIGNAL[est: ROPE] = CODE;
EndDisplay: PUBLIC SIGNAL = CODE;
Interrupt: PUBLIC SIGNAL = CODE;
<<>>

ListRecord: TYPE = RECORD[old: Node, new: ROPE, pref: INT, number: BOOL];
List: REF L;
L: TYPE = RECORD[e:SEQUENCE length: NAT OF ListRecord];
lin: CARDINAL;
ascii: BOOL;
Nail: LSTNode;

SortRoutine: PROC[input: Node] RETURNS[Node] = {
ascii _ FALSE;
WITH input SELECT FROM
l: rLST => RETURN[sort[l]];
ENDCASE => ERROR P.RErr["sort requires a list"];
};

ASortRoutine: PROC[input: Node] RETURNS[Node] = {
ascii _ TRUE;
WITH input SELECT FROM
l: rLST => RETURN[sort[l]];
ENDCASE => ERROR P.RErr["asort requires a list"];
};

sort: PROC[input: LSTNode] RETURNS[j:LSTNode] = {
i,m: CARDINAL;
j _ NIL;
i _ P.LengthList[input];
IF i <= 1 THEN j _ input
ELSE {
List _ PrefixedZone.NEW[L[i]];
lin _ 0;
FOR m IN [0..i) DO
List[m].number _ FALSE;
ENDLOOP;
P.Map[input,SR];
<<setting up simple random number generaor>>
TreeSort[lin];                -- sort the list
j _ N.NEW[LSTNodeRecord_[TRUE,LST[List[lin-1].old,Nail]]];
IF lin > 1 THEN FOR i DECREASING IN [0.. (lin-2)] DO
j _ N.NEW[LSTNodeRecord_[TRUE,LST[List[i].old,j]]];
ENDLOOP;
};
RETURN[j];
};

SR: PROC[n: Node] = {
ns: PString.Stream;
List[lin].old _ n;
WITH n SELECT FROM
l: rLST =>  n _ l.listhead;
t: rSTR => List[lin].new _ t.str; 
ENDCASE => P.RErr["sort expects a list of strings"];
ns _ S.NewStream[List[lin].new];
List[lin].number _ FALSE;
IF ~ascii THEN
{
c: CHAR;
neg: BOOL _ FALSE;
n: INT _ 0;
[c,ns] _ S.Item[ns];
IF c = '- THEN { neg _ TRUE; [c, ns] _ S.Item[ns] };
IF c=0C THEN GOTO NotNum;
UNTIL c=0C DO
IF c NOT IN ['0..'9] THEN GOTO NotNum;
n _ n*10+ (c-'0);
[c, ns] _ S.Item[ns];
ENDLOOP;
IF neg THEN n _ -n;
List[lin].number _ TRUE;
List[lin].pref _ n
EXITS
NotNum => NULL;
};
IF ~List[lin].number  THEN
{
<<this is just to get the first four characters into the long integer place so that they form a good hint>>
FunnyINT: TYPE =  PACKED ARRAY [0..4) OF CHAR;
ns _ S.NewStream[List[lin].new];
[LOOPHOLE[List[lin].pref, FunnyINT][2], ns] _ S.Item[ns];
[LOOPHOLE[List[lin].pref, FunnyINT][3], ns] _ S.Item[ns];
[LOOPHOLE[List[lin].pref, FunnyINT][0], ns] _ S.Item[ns];
[LOOPHOLE[List[lin].pref, FunnyINT][1], ns] _ S.Item[ns];
};
lin _ lin + 1;
};

TreeSort: PROC[N: INTEGER] = {
t: ListRecord;
siftUp: PROC[low, high: INTEGER] =
{ k, son: INTEGER;
k _ low;
DO
IF 2*k>high THEN EXIT;
IF 2*k+1>high OR LessThan[2*k+1-1, 2*k-1] THEN son _ 2*k ELSE son _ 2*k+1;
IF LessThan[son-1, k-1] THEN EXIT;
t _ List[son-1]; List[son-1] _ List[k-1]; List[k-1] _ t;
k _ son;
ENDLOOP;
};
i: INTEGER;
FOR i DECREASING IN [1..N/2] DO siftUp[i,N] ENDLOOP;
FOR i DECREASING IN [1..N) DO
t _ List[1-1]; List[1-1] _ List[i+1-1]; List[i+1-1] _ t;
siftUp[1,i]
ENDLOOP;
};

LessThan: PROC[i,j: INTEGER] RETURNS[BOOL] = {
res: INTEGER;
n1, n2: PString.Stream;
c1,c2: CHAR;
IF List[i].number AND List[j].number THEN {
IF List[i].pref < List[j].pref THEN RETURN[TRUE]
ELSE RETURN[FALSE];
};
IF ~List[i].number AND ~List[j].number THEN {
res _ USC[List[i].pref,List[j].pref];
IF res ~= 0 THEN RETURN[res=-1];
};
n1 _ S.NewStream[List[i].new];
n2 _ S.NewStream[List[j].new];
DO
[c1, n1] _ S.Item[n1];
[c2, n2] _ S.Item[n2];
IF c1 > c2 THEN {
res _ 1;
EXIT;
};
IF c1 < c2 THEN {
res _ -1;
EXIT;
};
IF c1 = 0C THEN {
res _ 0;
EXIT;
};
ENDLOOP;
RETURN[res=-1];
};

USC: PROC[a,b: INT] RETURNS[INTEGER] = {
<<unsigned compare, treat a and b as LONG CARDINALS>>
<<return -1 if a<b, 0 if a=b, 1 if a>b>>
i: LONG CARDINAL _ LOOPHOLE[a];
j: LONG CARDINAL _ LOOPHOLE[b];
IF i>j THEN RETURN[1];
IF i<j THEN RETURN[-1];
RETURN[0];
};

USortRoutine: PROC[input: Node] RETURNS[ans:Node] = 
<<unary>>
{n: LSTNode _ P.BlessLST[ASortRoutine[input]];
ans _ n;
IF n.listhead#NIL THEN 
WHILE n.listtail.listhead # NIL DO
IF (P.BlessString[n.listhead]).Equal[P.BlessString[n.listtail.listhead]] THEN 
{ --n.listhead _ n.listtail.listhead;
<<n.listtail _ n.listtail.listtail;>>
n^ _ n.listtail^
}
ELSE n _ n.listtail
ENDLOOP;
};

FactorRoutine: PROC[ninput: Node] RETURNS[ans:Node] = {
<<unary>>
input: LSTNode = P.BlessLST[ninput];
Ch: PROC[n: Node] =
{WITH n SELECT FROM l: rLST =>
WITH l.listhead SELECT FROM s: rSTR => RETURN;
ENDCASE => P.RErr["Illegal input to factor"];
ENDCASE => P.RErr["Illegal input to factor"]};
ans _ NIL;
P.Map[input,Ch];
{n: LSTNode _ sort[input];
m: LSTNode _ P.NewNail[];
ans _ m;
UNTIL n.listhead=NIL DO
key: Node _ P.BlessLST[n.listhead].listhead;
target: LSTNode _ P.NewNail[];
m^ _ [TRUE, LST[
N.NEW[NodeRecord_[TRUE,LST[key,target]]],
P.NewNail[]]];
m _ m.listtail;
WHILE n.listhead#NIL
AND (P.BlessString[key]).Equal[P.BlessString[P.BlessLST[n.listhead].listhead]] DO
target^ _ [TRUE,LST[
P.BlessLST[n.listhead].listtail,
P.NewNail[]]];
target _ target.listtail;
n _ n.listtail
ENDLOOP;
ENDLOOP;
}};

SupSetup: PUBLIC PROC = {
[] _ P.Insert["sort",[,,ZARY[SortRoutine]]];
[] _ P.Insert["usort",[,,ZARY[USortRoutine]]];
[] _ P.Insert["asort",[,,ZARY[ASortRoutine]]];
[] _ P.Insert["factor",[,,ZARY[FactorRoutine]]];
};

<<PrefixedZone _ SafeStorage.NewZone[];>>
PrefixedZone _ SafeStorage.GetSystemZone[];

[,,Nail] _ P.GetSpecialNodes[];

}.

