[Cyan]<CedarChest7.0>SetsAndStuff>BiRelsImpl.Mesa!16

BiRelsImpl.Mesa

Last tweaked by Mike Spreitzer on March 4, 1988 5:10:39 pm PST

DIRECTORY AbSets, Atom, BiRelBasics, BiRels, BiRelsPrivate, IntStuff, List, Process, Rope, SetBasics, SharedErrors;

BiRelsImpl: CEDAR MONITOR

LOCKS lp USING lp: LockPtr

IMPORTS AbSets, Atom, BiRelBasics, BiRels, BiRelsPrivate, IntStuff, List, Process, SetBasics, SharedErrors

EXPORTS BiRels

BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets, BiRelBasics, BiRels, BiRelsPrivate;

LockPtr: TYPE ~ LONG POINTER TO MONITORLOCK;

Cant: PUBLIC ERROR [br: BiRel] ~ CODE;

mappingNotSingleton: PUBLIC ROPE ~ R["mapping of %g isn't a singleton"];

fixedSide: PUBLIC ROPE ~ R["%g's %g side can't be varied"];

denseSide: PUBLIC ROPE ~ R["%g's %g side must remain dense"];

notFunctional: PUBLIC ROPE ~ R["%g's must be functional %g"];

badBiRel: PUBLIC BiRel ~ [NIL, R["bad BiRel"]];

provisionKey: ATOM ~ $BiRelsImplProvision;

dirableKey: ATOM ~ $BiRelsImplDirable;

resableKey: ATOM ~ $BiRelsImplRestrictable;

kindKey: ATOM ~ $BiRelsImplKind;

refTwo: REF EINT ~ FromEI[two];

Proc: TYPE ~ PROC ANY RETURNS ANY;

ConsBiRel: PUBLIC PROC [class: BiRelClass, data: REF ANY] RETURNS [BiRel]

~ {RETURN [[class, data]]};

CreateClass: PUBLIC PROC [cp: BiRelClassPrivate, dirable: BoolPair ← [TRUE, FALSE], restrictable: RestrictabilityPair ← ALL[none]] RETURNS [class: BiRelClass] ~ {

provs: Atom.PropList ← NARROW[List.Assoc[key: provisionKey, aList: cp.other]];

Sp: PROC [op: ATOM, proc: Proc] RETURNS [def: BOOL] ~ {

provs ← List.PutAssoc[op, IF (def ← proc=NIL) THEN $Default ELSE $Primitive, provs];

RETURN};

{OPEN cp;

IF Sp[$AsSet, AsSet] THEN AsSet ← DefaultAsSet;

IF Sp[$HasPair, HasPair] THEN HasPair ← DefaultHasPair;

IF Sp[$Image, Image] THEN Image ← DefaultImage;

IF Sp[$Apply, Apply] THEN Apply ← DefaultApply;

IF Sp[$ScanRestriction, ScanRestriction] THEN ScanRestriction ← DefaultScanRestriction;

IF Sp[$GetOne, GetOne] THEN GetOne ← DefaultGetOne;

IF Sp[$Get3, Get3] THEN Get3 ← DefaultGet3;

IF Sp[$Index, Index] THEN Index ← DefaultIndex;

IF Sp[$RestrictionSize, RestrictionSize] THEN RestrictionSize ← DefaultRestrictionSize;

IF Sp[$GetBounds, GetBounds] THEN GetBounds ← DefaultGetBounds;

IF Sp[$Copy, Copy] THEN Copy ← DefaultCopy;

IF Sp[$Insulate, Insulate] THEN Insulate ← DefaultInsulate;

IF Sp[$ValueOf, ValueOf] THEN ValueOf ← DefaultValueOf;

IF Sp[$Freeze, Freeze] THEN Freeze ← DefaultFreeze;

IF Sp[$Thaw, Thaw] THEN Thaw ← DefaultThaw;

IF Sp[$SetOn, SetOn] THEN SetOn ← DefaultSetOn;

IF Sp[$CurSetOn, CurSetOn] THEN CurSetOn ← DefaultCurSetOn;

IF Sp[$AddPair, AddPair] THEN AddPair ← DefaultAddPair;

IF Sp[$AddSet, AddSet] THEN AddSet ← DefaultAddSet;

IF Sp[$Swap, Swap] THEN Swap ← DefaultSwap;

IF Sp[$RemPair, RemPair] THEN RemPair ← DefaultRemPair;

IF Sp[$RemSet, RemSet] THEN RemSet ← DefaultRemSet;

IF Sp[$Update, Update] THEN Update ← DefaultUpdate;

IF Sp[$Delete, Delete] THEN Delete ← DefaultDelete;

IF Sp[$DeleteSet, DeleteSet] THEN DeleteSet ← DefaultDeleteSet;

IF Sp[$ReplaceMe, ReplaceMe] THEN ReplaceMe ← DefaultReplaceMe;

IF Sp[$ShiftAndClipMe, ShiftAndClipMe] THEN ShiftAndClipMe ← DefaultShiftAndClipMe;

IF Sp[$IsDense, IsDense] THEN IsDense ← DefaultIsDense;

IF Sp[$SideFixed, SideFixed] THEN SideFixed ← DefaultSideFixed;

};

cp.other ← List.PutAssoc[provisionKey, provs, cp.other];

cp.other ← List.PutAssoc[dirableKey, NEW [BoolPair ← dirable], cp.other];

cp.other ← List.PutAssoc[resableKey, NEW [RestrictabilityPair ← restrictable], cp.other];

class ← NEW [BiRelClassPrivate ← cp];

RETURN};

Primitive: PUBLIC PROC [br: BiRel, op: ATOM, arg1, arg2: REF ANY ← NIL] RETURNS [BOOL] ~ {

kind: REF ANY ~ Atom.GetProp[op, kindKey];

IF arg1#NIL AND ISTYPE[arg1, LORA] THEN ERROR--somebody called with one LIST of args rather than separate args--;

WITH kind SELECT FROM

a: ATOM => SELECT a FROM

$always => RETURN [TRUE];

$argless => NULL;

$composite => ERROR;

ENDCASE => ERROR;

a: REF ArgTyping => NULL;

ENDCASE => ERROR;

IF br.class.Primitive#NIL THEN SELECT br.class.Primitive[br, op, arg1, arg2] FROM

yes => RETURN [TRUE];

no => RETURN [FALSE];

pass => NULL;

ENDCASE => ERROR;

{provs: Atom.PropList ~ NARROW[List.Assoc[provisionKey, br.class.other]];

prov: REF ANY ~ List.Assoc[op, provs];

SELECT prov FROM

$Default => RETURN [FALSE];

$Primitive => WITH kind SELECT FROM

a: ATOM => SELECT a FROM

$argless => RETURN [TRUE];

$always, $composite => ERROR;

ENDCASE => ERROR;

types: REF ArgTyping => {

args: ARRAY [1 .. 2] OF REF ANY ~ [arg1, arg2];

FOR i: NATURAL IN [1 .. 2] DO

type: ArgType ~ types[i];

SELECT type FROM

$None, $Set, $RelOrder, $RelOrderFN, $Want3, $limit, $When, $Side, $EndBools, $BiRel => NULL;

$Dir => {dir: Direction ~ ToDir[args[i]];

dirable: REF BoolPair ~ NARROW[List.Assoc[dirableKey, br.class.other]];

IF NOT dirable[dir] THEN RETURN [FALSE]};

$SetPair => {rsp: RefSetPair ~ ToSets[args[i]];

resable: REF RestrictabilityPair ~ NARROW[List.Assoc[resableKey, br.class.other]];

FOR side: Side IN Side DO

SELECT resable[From[side]] FROM

none => IF rsp[side]#nilSet THEN RETURN [FALSE];

tiny => IF rsp[side]#nilSet AND NOT (rsp[side].GoodImpl[$Size, refTwo] AND rsp[side].Size[two].Compare[two]<equal) THEN RETURN [FALSE];

any => NULL;

ENDCASE => ERROR;

ENDLOOP;

};

$remove => IF br.MutabilityOf[]#variable AND ToBool[args[i]] THEN RETURN [TRUE];

ENDCASE => ERROR;

ENDLOOP;

RETURN [TRUE]};

ENDCASE => ERROR;

}};

refOne: RefEINT ~ FromEI[one];

refSetAllInts: RefSet ~ Sets.IIAsSet[[]].Refify;

QualityOf: PUBLIC PROC [br: BiRel, op: ATOM, arg1, arg2, arg3, arg4: REF ANY ← NIL] RETURNS [ImplQuality] ~ {

IF arg1#NIL AND ISTYPE[arg1, LORA] THEN ERROR--somebody called with one LIST of args rather than separate args--;

WITH Atom.GetProp[op, kindKey] SELECT FROM

a: ATOM => SELECT a FROM

$always => RETURN [primitive];

$argless => NULL;

$composite => SELECT op FROM

$Mapping => {dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$Image, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir]]};

$HasMapping => {from: Side ~ Source[ToDir[arg1]];

RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[from, Sets.FakeSingleton[br.Spaces[][from]]]]]};

$Enumerate => RETURN br.QualityOf[$Scan, arg1, arg2, arg3, arg4];

$Scan => RETURN br.QualityOf[$ScanRestriction, refNilSets, arg1];

$EnumerateImage => RETURN br.QualityOf[$ScanImage, arg1, arg2, arg3, arg4];

$ScanImage => {

set: RefSet ~ ToSet[arg1];

dir: Direction ~ ToDir[arg2];

ro: Sets.RelOrder ~ Sets.ToRO[arg3];

RETURN br.QualityOf[$ScanHalfRestriction, set, FromSide[Source[dir]], FromRO[ConsRelOrder[Dest[dir], ro]]]};

$EnumerateMapping => {

dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$EnumerateImage, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir], arg2]};

$ScanMapping => {

dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$ScanImage, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir], arg2]};

$EnumerateHalfRestriction => RETURN br.QualityOf[$ScanHalfRestriction, arg1, arg2, arg3, arg4];

$ScanHalfRestriction => RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[ToSide[arg2], ToSet[arg1]^]], arg3];

$APair => RETURN QMin[br.QualityOf[$GetOne, $FALSE, arg1, arg2], goodDefault];

$Pop => RETURN QMin[br.QualityOf[$GetOne, $TRUE, arg1, arg2], goodDefault];

$Next => RETURN br.QualityOf[$Get3, FromRO[ToRO[arg1, [[fwd, no]]]], $FFT];

$Prev => RETURN br.QualityOf[$Get3, FromRO[ToRO[arg1, [[fwd, no]]]], $TFF];

$SkipTo => {

goal: RefSet ~ ToSet[arg1];

bounds: Interval ~ ToInterval[arg2]^;

side: Side ~ ToSide[arg3];

os: Side ~ OtherSide[side];

bwd: BOOL ~ ToBool[arg4];

RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[side, goal^, IntervalAsSet[br.Spaces[][os], bounds]]], FromRO[ConsRelOrder[os, IF bwd THEN bwd ELSE fwd]]]};

$Lookup => {

bounds: RefInterval ~ ToInterval[arg1];

side: Side ~ ToSide[arg2];

RETURN br.QualityOf[$SkipTo, Sets.FakeRefSingleton[br.Spaces[][side]], arg1, arg2, arg3]};

$Size => RETURN br.QualityOf[$RestrictionSize, refNilSets, arg1];

$Empty => RETURN br.QualityOf[$Size, refOne];

$ImageSize => {set: Set ~ ToSet[arg1]^;

limit: RefEINT ~ ToEI[arg3];

easy: BOOL ~ set.GoodImpl[$Size, refTwo] AND set.Size[two].Compare[two]<equal;

IF easy THEN RETURN br.QualityOf[$RestrictionSize, FromSets[ConsSets[Source[ToDir[arg2]], set]], limit];

IF NOT br.Can[$Scan] THEN RETURN [cant];

RETURN [IF limit^.Compare[two]<=equal THEN goodDefault ELSE poorDefault]};

$MappingSize => {

dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$ImageSize, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir], arg2]};

$AddNewPair => RETURN br.QualityOf[$AddPair];

$AddNewSet => RETURN br.QualityOf[$AddSet, arg1];

$Erase => RETURN br.QualityOf[$RemSet, br.Refify];

$Substitute => {side: Side ~ ToSide[arg1];

RETURN QMin[

br.QualityOf[$Mapping, FromDir[From[side]]],

br.QualityOf[$AddSet]]

.QMin[IF br.Functional[][To[side]] THEN primitive ELSE br.QualityOf[$Delete, FromSide[side]]]};

$GetIntDom => RETURN br.QualityOf[$GetBounds, arg1, arg2, arg3, arg4];

ENDCASE => ERROR;

a: REF ArgTyping => NULL;

ENDCASE => ERROR;

IF Primitive[br, op, arg1, arg2] THEN RETURN [primitive];

SELECT op FROM

$AsSet => RETURN [goodDefault];

$HasPair => {spaces: SpacePair ~ br.Spaces[];

RETURN br.QualityOf[$ScanRestriction, FromSets[[Sets.FakeSingleton[spaces[left]], Sets.FakeSingleton[spaces[right]]]]].QMin[goodDefault]};

$Image => {set: RefSet ~ ToSet[arg1];

dir: Direction ~ ToDir[arg2];

RETURN [IF br.GoodImpl[$ScanRestriction, FromSets[ConsSets[Source[dir], set^]]] THEN goodDefault ELSE poorDefault]};

$Apply => {dir: Direction ~ ToDir[arg1];

IF br.Functional[][dir] AND Primitive[br, $Update, arg1] THEN RETURN [goodDefault];

{src: Side ~ Source[dir];

RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[src, Sets.CreateSingleton[noValue, br.Spaces[][src]]]]].QMin[goodDefault]}};

$ScanRestriction => {

sets: RefSetPair ~ ToSets[arg1];

ro: RelOrder ~ ToRO[arg2].CanonizeRelOrder[br.Functional[]];

plan: BiRelsPrivate.Analysis;

can: BOOL;

[can, plan] ← BiRelsPrivate.PlanDefaultScanRestriction[br, sets^, ro];

IF NOT can THEN RETURN [cant];

RETURN [IF plan.cost.sort = ALL[asIs] THEN goodDefault ELSE poorDefault]};

$GetOne => {remove: BOOL ~ ToBool[arg1];

ro: RelOrder ~ ToRO[arg2];

IF remove AND br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF Primitive[br, $ScanRestriction, refNilSets, arg2] THEN RETURN [goodDefault];

RETURN br.QualityOf[$Scan].QMin[

IF remove THEN br.QualityOf[$RemPair].QMin[poorDefault] ELSE poorDefault]};

$Get3 => {

ro: RelOrder ~ ToRO[arg1, [[fwd, no]]].CanonizeRelOrder[br.Functional];

fq, bq, nq: ImplQuality ← br.QualityOf[$Scan, FromRO[ro]];

rro: RelOrder;

IF ro.sub # ALL[no] THEN {

rro ← ro.ReverseRO[];

bq ← br.QualityOf[$Scan, FromRO[rro]];

nq ← br.QualityOf[$Scan]};

{max: ImplQuality ~ QMax[nq, QMax[fq, bq]];

uro: RelOrder ~ IF bq=max AND fq<max THEN rro ELSE IF fq=max THEN ro ELSE [];

RETURN br.QualityOf[$Scan, FromRO[uro]].QMin[goodDefault]}};

$Index => {goal: IntRel ~ ToBiRel[arg1]^;

RETURN QMin[QMin[poorDefault, goal.QualityOf[$GetIntDom]],

QMin[br.QualityOf[$Mapping], goal.QualityOf[$Mapping]]]};

$RestrictionSize => {

sets: RefSetPair ~ ToSets[arg1];

limit: EINT ~ ToEI[arg2]^;

RETURN br.QualityOf[$ScanRestriction, sets].QMin[IF limit.Compare[two]<=equal THEN goodDefault ELSE poorDefault]};

$GetBounds => {

want: EndBools ~ ToEB[arg1];

ro: RelOrder ~ ToRO[arg2, [[fwd, no]]].CanonizeRelOrder[br.Functional];

rro: RelOrder ~ ro.ReverseRO[];

((NOT want[min]) OR Primitive[br, $ScanRestriction, refNilSets, FromRO[ro]]) AND

((NOT want[max]) OR Primitive[br, $ScanRestriction, refNilSets, FromRO[rro]])

THEN {q: ImplQuality ← goodDefault;

FOR e: End IN End DO

IF want[e] THEN {

uro: RelOrder ~ IF e=min THEN ro ELSE rro;

q ← q.QMin[br.QualityOf[$APair, FromRO[uro]]]};

ENDLOOP;

RETURN [q]}

ELSE RETURN br.QualityOf[$Scan].QMin[poorDefault]};

$Copy => RETURN [cant];

$Insulate => RETURN [goodDefault];

$ValueOf => RETURN [IF br.MutabilityOf#constant THEN QMin[br.QualityOf[$Copy], br.QualityOf[$Freeze]].QMin[goodDefault] ELSE goodDefault];

$Freeze, $Thaw => RETURN [IF br.MutabilityOf#variable THEN goodDefault ELSE cant];

$SetOn => RETURN [poorDefault];

$CurSetOn => RETURN [IF br.MutabilityOf=constant THEN poorDefault ELSE cant];

$AddPair => {

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF br.Functional[]#ALL[FALSE] THEN FOR dir: Direction IN Direction DO

IF br.Functional[][dir] AND NOT Primitive[br, $Update, FromDir[dir]] THEN EXIT;

REPEAT FINISHED => RETURN [goodDefault];

ENDLOOP;

RETURN [IF Primitive[br, $AddSet, FakeRefSingleton[br.Spaces[]]] THEN goodDefault ELSE cant];

};

$AddSet => {

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF br.Functional[]#ALL[FALSE] THEN FOR dir: Direction IN Direction DO

IF br.Functional[][dir] AND NOT Primitive[br, $Update, FromDir[dir]] THEN EXIT;

REPEAT FINISHED => RETURN [goodDefault];

ENDLOOP;

RETURN [IF Primitive[br, $AddPair] THEN goodDefault ELSE cant];

};

$Swap => {side: Side ~ ToSide[arg1]; dir: Direction ~ From[side];

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

RETURN QMin[goodDefault, QMin[QMin[

br.QualityOf[$Mapping, FromDir[dir]],

br.QualityOf[$Delete, FromSide[side]]], QMin[

br.QualityOf[$ScanMapping, FromDir[dir]],

br.QualityOf[$AddPair]]]]};

$RemPair => {spaces: SpacePair ~ br.Spaces[];

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF br.Functional[]#ALL[FALSE] THEN FOR dir: Direction IN Direction DO

IF br.Functional[][dir] AND NOT Primitive[br, $Update, FromDir[dir]] THEN EXIT;

REPEAT FINISHED => RETURN [goodDefault];

ENDLOOP;

IF Primitive[br, $RemSet, FakeRefSingleton[spaces]] THEN RETURN [goodDefault];

IF br.Functional[]#ALL[FALSE] THEN {

goodDelete: BoolPair ← ALL[FALSE];

FOR dir: Direction IN Direction DO

src: Side ~ Source[dir];

IF br.Functional[][dir] THEN {

IF br.GoodImpl[$Apply, FromDir[dir]] THEN goodDelete[dir] ← br.Primitive[$Delete, FromSide[src]] OR br.Primitive[$DeleteSet, Sets.FakeRefSingleton[spaces[src]], FromSide[src]]

ELSE EXIT};

REPEAT FINISHED => IF goodDelete#ALL[FALSE] THEN RETURN [goodDefault];

ENDLOOP;

op ← op};

RETURN [cant]};

$RemSet => {

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF br.Primitive[$RemPair] THEN RETURN [goodDefault];

IF br.Functional[]#ALL[FALSE] THEN {

FOR dir: Direction IN Direction DO

IF br.Functional[][dir] AND NOT Primitive[br, $Update, FromDir[dir]] THEN EXIT;

REPEAT FINISHED => RETURN [goodDefault];

ENDLOOP;

{spaces: SpacePair ~ br.Spaces[];

goodDelete: BoolPair ← ALL[FALSE];

FOR dir: Direction IN Direction DO

src: Side ~ Source[dir];

IF br.Functional[][dir] THEN {

IF br.GoodImpl[$Apply, FromDir[dir]] THEN goodDelete[dir] ← br.Primitive[$Delete, FromSide[src]] OR br.Primitive[$DeleteSet, Sets.FakeRefSingleton[spaces[src]], FromSide[src]]

ELSE EXIT};

REPEAT FINISHED => IF goodDelete#ALL[FALSE] THEN RETURN [goodDefault];

ENDLOOP;

op ← op}};

RETURN [cant]};

$Update => RETURN QMin[

QMin[goodDefault, br.QualityOf[$Apply, arg1]],

QMin[br.QualityOf[$AddPair], br.QualityOf[$RemPair]]];

$Delete => {side: Side ~ ToSide[arg1];

dir: Direction ~ From[side];

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF br.Functional[][dir] AND Primitive[br, $Update, FromDir[dir]] THEN RETURN [goodDefault];

RETURN QMin[goodDefault, br.QualityOf[$DeleteSet, Sets.FakeRefSingleton[br.Spaces[][side]], FromSide[side]]]};

$DeleteSet => {set: RefSet ~ ToSet[arg1];

side: Side ~ ToSide[arg2];

dir: Direction ~ From[side];

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

IF Primitive[br, $Delete, FromSide[side]] OR br.Functional[][dir] AND Primitive[br, $Update, FromDir[dir]] THEN RETURN [goodDefault];

RETURN QMin[QMin[

set^.QualityOf[$Scan],

br.QualityOf[$RemPair]], QMin[

br.QualityOf[$ScanMapping, FromDir[dir]],

poorDefault]]};

$ReplaceMe => {with: IntRel ~ ToBiRel[arg1]^;

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

RETURN QMin[QMin[

with.QualityOf[$GetIntDom],

br.QualityOf[$DeleteSet, refSetAllInts]], QMin[

SubShiftQuality[br],

br.QualityOf[$AddSet, with.Refify]]].QMin[

poorDefault]};

$ShiftAndClipMe => {

IF br.MutabilityOf[]#variable THEN RETURN [goodDefault];

RETURN QMin[br.QualityOf[$DeleteSet, refSetAllInts], SubShiftQuality[br]].QMin[poorDefault]};

$IsDense => RETURN [poorDefault];

$SideFixed => RETURN [IF br.MutabilityOf[]=constant THEN goodDefault ELSE poorDefault];

ENDCASE => ERROR;

};

SubShiftQuality: PROC [br: BiRel] RETURNS [ImplQuality] ~ {

RETURN QMin[QMin[

br.QualityOf[$GetIntDom],

br.QualityOf[$ScanMapping]], QMin[

br.QualityOf[$AddPair],

br.QualityOf[$RemPair]]]};

Enumerate: PUBLIC PROC [br: BiRel, Consume: PROC [Pair], ro: RelOrder ← []] ~ {

EnumTest: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair]; RETURN [FALSE]};

IF br.Scan[EnumTest, ro].found THEN ERROR};

EnumAA: PUBLIC PROC [br: BiRel, Consume: PROC [REF ANY, REF ANY], ro: RelOrder ← []] ~ {

EnumAATest: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[left].VA, pair[right].VA]; RETURN [FALSE]};

IF br.Scan[EnumAATest, ro].found THEN ERROR};

EnumIA: PUBLIC PROC [br: BiRel, Consume: PROC [INT, REF ANY], ro: RelOrder ← []] ~ {

EnumIATest: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[left].VI, pair[right].VA]; RETURN [FALSE]};

IF br.Scan[EnumIATest, ro].found THEN ERROR};

EnumII: PUBLIC PROC [br: BiRel, Consume: PROC [INT, INT], ro: RelOrder ← []] ~ {

EnumIITest: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[left].VI, pair[right].VI]; RETURN [FALSE]};

IF br.Scan[EnumIITest, ro].found THEN ERROR};

EnumerateImage: PUBLIC PROC [br: BiRel, set: Set, Consume: PROC [Value], dir: Direction ← leftToRight, ro: Sets.RelOrder ← no] ~ {

dest: Side ~ Dest[dir];

EnumImageTest: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[dest]]; RETURN [FALSE]};

IF br.ScanHalfRestriction[set, EnumImageTest, Source[dir], ConsRelOrder[dest, ro]].found THEN ERROR;

RETURN};

Forked: TYPE ~ REF ForkedPrivate;

ForkedPrivate: TYPE ~ RECORD [

set: ARRAY Which OF BiRel,

ready: ARRAY Which OF BOOL ← ALL[FALSE],

done: BOOL ← FALSE,

change: CONDITION ← [timeout: Process.SecondsToTicks[10]],

val: ARRAY Which OF MaybePair ← ALL[[TRUE, noPair]],

lock: MONITORLOCK ← []

];

InterleavedProduceRestriction: PUBLIC PROC [a, b: BiRel, Consume: InterleavedConsumer, setsA, setsB: SetPair ← [], roA, roB: RelOrder ← []] RETURNS [ans: MaybePair ← noMaybePair] ~ {

fkd: Forked ~ NEW [ForkedPrivate ← [set: [a, b]]];

GenA: PROC ~ {ForkScan[fkd, a, setsA, roA]};

GenB: PROC ~ {ForkScan[fkd, b, setsB, roB]};

TestAB: PROC ~ {

Produce: PROC [w: Which] RETURNS [MaybePair] ~ {

Wait: ENTRY PROC [lp: LockPtr] RETURNS [MaybePair] ~ {

ENABLE UNWIND => NULL;

UNTIL fkd.ready[w] DO WAIT fkd.change ENDLOOP;

RETURN [fkd.val[w]]};

TRUSTED {RETURN Wait[@fkd.lock]}};

Finish: ENTRY PROC [lp: LockPtr] ~ {

ENABLE UNWIND => NULL;

fkd.done ← TRUE;

fkd.ready ← ALL[FALSE];

BROADCAST fkd.change;

RETURN};

ans ← Consume[Produce];

TRUSTED {Finish[@fkd.lock]};

RETURN};

TRUSTED {

Process.EnableAborts[@fkd.change];

SharedErrors.Fork[LIST[GenA, GenB, TestAB]]};

RETURN};

ParallelScanRestriction: PUBLIC PROC [a, b: BiRel, Test: ParallelTester, setsA, setsB: SetPair ← [], roA, roB: RelOrder ← []] RETURNS [pf: ParallelFind ← [FALSE, noMaybePair, noMaybePair]] ~ {

fkd: Forked ~ NEW [ForkedPrivate ← [set: [a, b] ]];

GenA: PROC ~ {ForkScan[fkd, a, setsA, roA]};

GenB: PROC ~ {ForkScan[fkd, b, setsB, roB]};

TestAB: PROC ~ {

WaitForReq: ENTRY PROC [lp: LockPtr] RETURNS [continue: BOOL] ~ {

ENABLE UNWIND => NULL;

IF NOT fkd.ready[a] THEN {WAIT fkd.change; LOOP};

IF NOT fkd.ready[b] THEN {WAIT fkd.change; LOOP};

RETURN [fkd.val[a].found OR fkd.val[b].found];

ENDLOOP;

};

Satisfy: ENTRY PROC [lp: LockPtr] ~ {

ENABLE UNWIND => NULL;

fkd.ready[a] ← fkd.ready[b] ← FALSE;

BROADCAST fkd.change;

RETURN};

TRUSTED {UNTIL fkd.done DO

IF NOT WaitForReq[@fkd.lock]

THEN fkd.done ← TRUE

ELSE {IF (fkd.done ← Test[fkd.val[a], fkd.val[b]]) THEN pf ← [TRUE, fkd.val[a], fkd.val[b]]};

Satisfy[@fkd.lock];

ENDLOOP};

RETURN};

TRUSTED {

Process.EnableAborts[@fkd.change];

SharedErrors.Fork[LIST[GenA, GenB, TestAB]]};

RETURN};

ForkScan: PROC [fkd: Forked, which: Which, sets: SetPair, ro: RelOrder] ~ {

Mediate: PROC [val: Pair] RETURNS [pass: BOOL ← FALSE] ~ {

WithLock: ENTRY PROC [lp: LockPtr] ~ {

ENABLE UNWIND => NULL;

fkd.val[which].it ← val;

fkd.ready[which] ← TRUE;

BROADCAST fkd.change;

UNTIL NOT fkd.ready[which] DO WAIT fkd.change ENDLOOP;

pass ← fkd.done;

RETURN};

TRUSTED {WithLock[@fkd.lock]};

RETURN};

Finish: ENTRY PROC [lp: LockPtr] ~ {

ENABLE UNWIND => NULL;

fkd.val[which] ← noMaybePair;

UNTIL fkd.done DO

fkd.ready[which] ← TRUE;

BROADCAST fkd.change;

UNTIL NOT fkd.ready[which] DO WAIT fkd.change ENDLOOP;

ENDLOOP;

RETURN};

[] ← fkd.set[which].ScanRestriction[sets, Mediate, ro];

TRUSTED {Finish[@fkd.lock]};

RETURN};

EnumerateHalfRestriction: PUBLIC PROC [br: BiRel, set: Set, Consume: PROC [Pair], side: Side ← left, ro: RelOrder ← []] ~ {

EnumHRTest: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair]; RETURN [FALSE]};

IF br.ScanHalfRestriction[set, EnumHRTest, side, ro].found THEN ERROR;

RETURN};

ScanImage: PUBLIC PROC [br: BiRel, set: Set, Test: Sets.Tester, dir: Direction ← leftToRight, ro: Sets.RelOrder ← no] RETURNS [MaybePair] ~ {

dest: Side ~ Dest[dir];

ScanImageTest: PROC [pair: Pair] RETURNS [BOOL] ~ {RETURN Test[pair[dest]]};

RETURN br.ScanHalfRestriction[set, ScanImageTest, Source[dir], ConsRelOrder[dest, ro]]};

Has: PUBLIC PROC [br, other: BiRel, want: BoolPair] RETURNS [hsp: HadSetPair ← []] ~ {

spaces: SpacePair ~ br.Spaces[];

Per: PROC [pair: Pair] RETURNS [BOOL] ~ {

IF want[leftToRight] THEN {

mv: MaybeValue ~ br.Apply[pair[left], leftToRight];

SELECT TRUE FROM

NOT mv.found => hsp[leftToRight][none] ← TRUE;

spaces[right].SEqual[pair[right], mv.it] => hsp[leftToRight][same] ← TRUE;

ENDCASE => hsp[leftToRight][different] ← TRUE};

IF want[rightToLeft] THEN {

mv: MaybeValue ~ br.Apply[pair[right], rightToLeft];

SELECT TRUE FROM

NOT mv.found => hsp[rightToLeft][none] ← TRUE;

spaces[left].SEqual[pair[left], mv.it] => hsp[rightToLeft][same] ← TRUE;

ENDCASE => hsp[rightToLeft][different] ← TRUE};

RETURN [FALSE]};

IF want#ALL[FALSE] AND other.Scan[Per].found THEN ERROR;

RETURN};

AddAA: PUBLIC PROC [br: BiRel, left, right: REF ANY, if: IfHadPair ← alwaysAdd] RETURNS [had: HadPair]

~ {RETURN br.AddPair[[AV[left], AV[right]], if]};

AddIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY, if: IfHadPair ← alwaysAdd] RETURNS [had: HadPair]

~ {RETURN br.AddPair[[IV[left], AV[right]], if]};

AddII: PUBLIC PROC [br: BiRel, left, right: INT, if: IfHadPair ← alwaysAdd] RETURNS [had: HadPair]

~ {RETURN br.AddPair[[IV[left], IV[right]], if]};

AddNewPair: PUBLIC PROC [br: BiRel, pair: Pair] ~ {

had: HadPair ~ br.AddPair[pair, addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

AddNewAA: PUBLIC PROC [br: BiRel, left, right: REF ANY] ~ {

had: HadPair ~ br.AddPair[[AV[left], AV[right]], addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

AddNewIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY] ~ {

had: HadPair ~ br.AddPair[[IV[left], AV[right]], addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

AddNewII: PUBLIC PROC [br: BiRel, left, right: INT] ~ {

had: HadPair ~ br.AddPair[[IV[left], IV[right]], addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

RemAA: PUBLIC PROC [br: BiRel, left, right: REF ANY] RETURNS [had: HadPair]

~ {RETURN br.RemPair[[AV[left], AV[right]]]};

RemIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY] RETURNS [had: HadPair]

~ {RETURN br.RemPair[[IV[left], AV[right]]]};

RemII: PUBLIC PROC [br: BiRel, left, right: INT] RETURNS [had: HadPair]

~ {RETURN br.RemPair[[IV[left], IV[right]]]};

RemOldPair: PUBLIC PROC [br: BiRel, pair: Pair] ~ {

had: HadPair ~ br.RemPair[pair];

IF br.Functional[][leftToRight] AND had[leftToRight]#same THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#same THEN ERROR;

};

RemOldAA: PUBLIC PROC [br: BiRel, left, right: REF ANY] ~ {

had: HadPair ~ br.RemPair[[AV[left], AV[right]]];

IF br.Functional[][leftToRight] AND had[leftToRight]#same THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#same THEN ERROR;

};

RemOldIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY] ~ {

had: HadPair ~ br.RemPair[[IV[left], AV[right]]];

IF br.Functional[][leftToRight] AND had[leftToRight]#same THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#same THEN ERROR;

};

RemOldII: PUBLIC PROC [br: BiRel, left, right: INT] ~ {

had: HadPair ~ br.RemPair[[IV[left], IV[right]]];

IF br.Functional[][leftToRight] AND had[leftToRight]#same THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#same THEN ERROR;

};

Substitute: PUBLIC PROC [br: BiRel, old, new: Value, side: Side] ~ {

image: Set ~ br.Mapping[old, From[side]];

[] ← br.AddSet[CreateProduct[ConsSets[side, Sets.CreateSingleton[new, br.Spaces[][side]], image]]];

IF NOT br.Functional[][To[side]] THEN [] ← br.Delete[old, side];

RETURN};

refNilSets: REF ANY ~ FromSets[ALL[nilSet]];

AddComposite: PROC [op: ATOM] ~ {

Atom.PutProp[prop: kindKey, val: $composite, atom: op];

};

AddAlways: PROC [op: ATOM] ~ {

Atom.PutProp[prop: kindKey, val: $always, atom: op];

};

AddArgless: PROC [op: ATOM] ~ {

Atom.PutProp[prop: kindKey, val: $argless, atom: op];

};

AddArgfull: PROC [op: ATOM, arg1, arg2: ArgType ← None] ~ {

Atom.PutProp[prop: kindKey, val: NEW [ArgTyping ← [arg1, arg2]], atom: op];

};

Start: PROC ~ {

AddComposite[$Mapping];

AddComposite[$Enumerate];

AddComposite[$Scan];

AddComposite[$EnumerateImage];

AddComposite[$ScanImage];

AddComposite[$EnumerateMapping];

AddComposite[$ScanMapping];

AddComposite[$EnumerateHalfRestriction];

AddComposite[$ScanHalfRestriction];

AddComposite[$APair];

AddComposite[$Pop];

AddComposite[$Next];

AddComposite[$Prev];

AddComposite[$SkipTo];

AddComposite[$Lookup];

AddComposite[$Size];

AddComposite[$Empty];

AddComposite[$ImageSize];

AddComposite[$MappingSize];

AddComposite[$AddNewPair];

AddComposite[$AddNewSet];

AddComposite[$Erase];

AddComposite[$Substitute];

AddComposite[$GetIntDom];

AddArgless[$AsSet];

AddArgless[$HasPair];

AddArgfull[$Image, $Set, $Dir];

AddArgfull[$Apply, $Dir];

AddArgfull[$ScanRestriction, $SetPair, $RelOrder];

AddArgfull[$GetOne, $remove, $RelOrder];

AddArgfull[$Get3, $RelOrderFN, $Want3];

AddArgfull[$RestrictionSize, $SetPair, $limit];

AddArgfull[$IsDense, $When, $Side];

AddArgfull[$SideFixed, $Side];

AddArgfull[$GetBounds, $EndBools, $RelOrderFN];

AddArgless[$Copy];

AddArgless[$Insulate];

AddArgless[$ValueOf];

AddArgless[$Freeze];

AddArgless[$Thaw];

AddArgless[$AddPair];

AddArgfull[$AddSet, $BiRel];

AddArgfull[$Swap, $Side];

AddArgless[$RemPair];

AddArgfull[$RemSet, $BiRel];

AddArgfull[$Update, $Dir];

AddArgless[$Delete];

AddArgfull[$DeleteSet, $Set, $Side];

AddArgless[$QuaIntInterval];

AddAlways[$MutabilityOf];

AddAlways[$Spaces];

AddArgfull[$SetOn, $Side];

AddArgfull[$CurSetOn, $Side];

AddAlways[$Functional];

AddAlways[$PreservePair];

RETURN};

FOR l2r: BOOL IN BOOL DO FOR r2l: BOOL IN BOOL DO FOR mut: Mutability IN Mutability DO

classes[l2r][r2l][mut] ← CreateClass[

cp: [

Primitive: PrefixPrimitive,

AsSet: PrefixAsSet,

HasPair: PrefixHasPair,

Image: PrefixImage,

Apply: PrefixApply,

ScanRestriction: PrefixScanRestriction,

GetOne: PrefixGetOne,

Get3: PrefixGet3,

Index: PrefixIndex,

RestrictionSize: PrefixRestrictionSize,

GetBounds: PrefixGetBounds,

Copy: PrefixCopy,

Insulate: IF mut=variable THEN PrefixInsulate ELSE NIL,

ValueOf: IF mut#constant THEN PrefixValueOf ELSE NIL,

Freeze: IF mut=variable THEN PrefixFreeze ELSE NIL,

Thaw: IF mut=variable THEN PrefixThaw ELSE NIL,

SetOn: PrefixSetOn,

CurSetOn: PrefixCurSetOn,

AddPair: IF mut=variable THEN PrefixAddPair ELSE NIL,

AddSet: IF mut=variable THEN PrefixAddSet ELSE NIL,

Swap: IF mut=variable THEN PrefixSwap ELSE NIL,

RemPair: IF mut=variable THEN PrefixRemPair ELSE NIL,

RemSet: IF mut=variable THEN PrefixRemSet ELSE NIL,

Update: PrefixUpdate,

Delete: IF mut=variable THEN PrefixDelete ELSE NIL,

DeleteSet: IF mut=variable THEN PrefixDeleteSet ELSE NIL,

ReplaceMe: IF mut=variable THEN PrefixReplaceMe ELSE NIL,

ShiftAndClipMe: IF mut=variable THEN PrefixShiftAndClipMe ELSE NIL,

Spaces: PrefixSpaces,

IsDense: PrefixIsDense,

SideFixed: PrefixSideFixed,

functional: [l2r, r2l],

mutability: mut],

dirable: ALL[TRUE],

restrictable: [tiny, none]

];

ENDLOOP ENDLOOP ENDLOOP;

Start[];

END.