BiRelsIndirect.Mesa
Last tweaked by Mike Spreitzer on December 14, 1987 9:12:44 pm PST
DIRECTORY AbSets, BiRelBasics, BiRels, IntStuff, List, SetBasics;
BiRelsIndirect:
CEDAR
PROGRAM
IMPORTS AbSets, BiRels, IntStuff, List, SetBasics
EXPORTS BiRels
=
BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets, BiRelBasics, BiRels;
classes1: Function--spaces[left] b (spaces[right] b Classes)-- ~ BiRels.CreateHashFn[spaces: [spaceSpace, refs], invable: FALSE];
Classes: TYPE ~ ARRAY --constant--BOOL OF ARRAY --oneToOne--BOOL OF BiRelClass;
FnFromProc:
PUBLIC
PROC
[
Apply: PROC [data: REF ANY, v: Value] RETURNS [mv: MaybeValue],
spaces: SpacePair ← [refs, refs],
data: REF ANY ← NIL,
constant, oneToOne: BOOL ← FALSE,
ScanInverse: PROC [data: REF ANY, v: Value, Test: Tester] RETURNS [MaybePair] ← NIL
]
RETURNS [Function] ~ {
classes2: Function--spaces[right] b Classes-- ← BiRels.DeRef[classes1.ApplyA[spaces[left]].MDA];
IF classes2 = nilBiRel
THEN {
classes2 ← BiRels.CreateHashFn[spaces: [spaceSpace, refs], invable: FALSE];
classes1.AddNewAA[spaces[left], classes2.Refify]};
{classes3: REF Classes ← NARROW[classes2.ApplyA[spaces[right]].MDA];
IF classes3=
NIL
THEN {
classes3 ← NEW [Classes];
FOR constant:
BOOL
IN
BOOL
DO
FOR oneToOne:
BOOL
IN
BOOL
DO
classes3[constant][oneToOne] ← CreateClass[[Apply: PFApply, Spaces: PFSpaces, functional: [TRUE, FALSE], mutability: readonly]];
ENDLOOP ENDLOOP;
classes2.AddNewAA[spaces[right], classes3]};
RETURN [[
classes3[constant][oneToOne],
NEW [ProcFnPrivate ← [spaces, Apply, ScanInverse, data]]
]]}};
ProcFn: TYPE ~ REF ProcFnPrivate;
ProcFnPrivate:
TYPE ~
RECORD [
spaces: SpacePair,
Apply: PROC [data: REF ANY, v: Value] RETURNS [mv: MaybeValue],
ScanInverse: PROC [data: REF ANY, v: Value, Test: Tester] RETURNS [MaybePair],
data: REF ANY
];
PFApply:
PROC [br: BiRel, v: Value, dir: Direction]
RETURNS [MaybeValue] ~ {
pf: ProcFn ~ NARROW[br.data];
IF dir#leftToRight THEN RETURN DefaultApply[br, v, dir];
RETURN pf.Apply[pf.data, v]};
PFSpaces:
PROC [br: BiRel]
RETURNS [SpacePair] ~ {
pf: ProcFn ~ NARROW[br.data];
RETURN [pf.spaces]};
EnumSeqOfSet:
PUBLIC
PROC [set: Set, ro: Sets.RelOrder ← no]
RETURNS [Sequence] ~ {
es: EnumSeq ~ NEW [EnumSeqPrivate ← [set, ro]];
RETURN [[esClasses[set.MutabilityOf[]=constant], es]]};
esClasses: REF ESClasses ~ NEW [ESClasses];
ESClasses: TYPE ~ ARRAY --const--BOOL OF BiRelClass;
EnumSeq: TYPE ~ REF EnumSeqPrivate;
EnumSeqPrivate: TYPE ~ RECORD [set: Set, ro: Sets.RelOrder];
ESPrimitive:
PROC [br: BiRel, op:
ATOM, arg1, arg2:
REF
ANY]
RETURNS [PrimitiveAnswer] ~ {
es: EnumSeq ~ NARROW[br.data];
SELECT op
FROM
$ScanRestriction => {sets: RefSetPair ~ ToSets[arg1];
IF sets^#ALL[nilSet] THEN RETURN [no];
{ro: RelOrder ~ ToRO[arg2];
roc: ROChoice ~ ChooseRO[ro, es.ro];
RETURN [IF roc.ok AND es.set.GoodImpl[$Scan] THEN yes ELSE no]}};
$GetBounds => RETURN [IF es.ro#no AND es.set.GoodImpl[$Scan] THEN yes ELSE no];
$ValueOf => RETURN [IF es.set.GoodImpl[op] THEN yes ELSE no];
$SetOn => RETURN [IF es.set.Can[$Size] THEN yes ELSE no];
ENDCASE => RETURN [pass]};
ROChoice: TYPE ~ RECORD [sro: Sets.RelOrder, ok, rev: BOOL];
ChooseRO:
PROC [ro: RelOrder, esro: Sets.RelOrder]
RETURNS [ROChoice] ~ {
SELECT ro.first
FROM
left =>
SELECT ro.sub[left]
FROM
fwd => RETURN [[esro, TRUE, FALSE]];
bwd => RETURN [[esro.ReverseRO, esro#no, TRUE]];
no => RETURN [[esro, TRUE, FALSE]];
ENDCASE => ERROR;
right =>
SELECT ro.sub[right]
FROM
fwd => RETURN [[fwd, esro#no, esro#fwd]];
bwd => RETURN [[bwd, esro#no, esro#bwd]];
no => RETURN [[esro, TRUE, FALSE]];
ENDCASE => ERROR;
ENDCASE => ERROR};
ESScanRestriction:
PROC [br: BiRel, sets: SetPair,
Test: Tester, ro: RelOrder]
RETURNS [mp: MaybePair ← noMaybePair] ~ {
IF sets#ALL[nilSet] THEN RETURN br.DefaultScanRestriction[sets, Test, ro];
{es: EnumSeq ~ NARROW[br.data];
roc: ROChoice ~ ChooseRO[ro, es.ro];
i: LNAT ← 0;
Pass:
PROC [right: Value]
RETURNS [
BOOL] ~ {
IF Test[[IV[i], right]] THEN RETURN [(mp ← [TRUE, [IV[i], right]]).found];
i ← IF roc.rev THEN i-1 ELSE i+1;
RETURN [FALSE]};
IF NOT roc.ok THEN RETURN DefaultScanRestriction[br, sets, Test, ro];
IF roc.rev THEN i ← es.set.Size.Pred.EN;
[] ← es.set.Scan[Pass, roc.sro];
RETURN}};
ESGetBounds:
PROC [br: BiRel, want: EndBools, ro: RelOrder]
RETURNS [MaybePairInterval] ~ {
es: EnumSeq ~ NARROW[br.data];
IF es.set.Empty THEN RETURN [[FALSE, []]];
IF es.ro=no THEN RETURN DefaultGetBounds[br, want, ro];
RETURN [[
TRUE, [
min: [IV[0], es.set.AnElt[es.ro].it],
max: [IV[es.set.Size.Pred.EN], es.set.AnElt[es.ro.ReverseRO].it]
]]];
};
ESValueOf:
PROC [br: BiRel]
RETURNS [ConstBiRel] ~ {
es: EnumSeq ~ NARROW[br.data];
RETURN EnumSeqOfSet[es.set.ValueOf, es.ro].AsConst};
ESSetOn:
PROC [br: BiRel, side: Side]
RETURNS [UWSet] ~ {
es: EnumSeq ~ NARROW[br.data];
SELECT side
FROM
left => RETURN [IIAsSet[[0, es.set.Size.Pred.EN]]];
right => RETURN [es.set.Insulate];
ENDCASE => ERROR};
ESSpaces:
PROC [br: BiRel]
RETURNS [SpacePair] ~ {
es: EnumSeq ~ NARROW[br.data];
RETURN [[ints, es.set.SpaceOf]]};
GradeUp:
PUBLIC
PROC [a: IntFn, o: SetBasics.Order]
RETURNS [p: Permutation] ~ {
indices: LORA ← NIL;
i: INT ← 0;
AddIndex: PROC [pair: Pair] ~ {indices ← CONS[NEW[INT ← pair[left].VI], indices]};
Compare:
PROC[ref1, ref2:
REF
ANY]
RETURNS [c: Basics.Comparison] ~ {
i1: REF INT ~ NARROW[ref1];
i2: REF INT ~ NARROW[ref2];
RETURN o.Compare[o.data, a.ApplyI[i1^].Val, a.ApplyI[i2^].Val]};
a.Enumerate[AddIndex];
indices ← List.Sort[indices, Compare];
p ← CreateSimple[oneToOne: TRUE, dense: TRUE, rightSpace: ints];
FOR inds:
LORA ← indices, inds.rest
WHILE inds#
NIL
DO
p.AddNewPair[[IV[i], IV[NARROW[inds.first, REF INT]^]]];
i ← i + 1;
ENDLOOP;
p ← p.Freeze;
RETURN};
TransPermute:
PUBLIC
PROC [from, to: IntFn, p: Permutation] ~ {
PerPair:
PROC [pair: Pair] ~ {
old: INT ~ pair[right].VI;
mv: MaybeValue ~ from.ApplyI[old];
IF mv.found THEN [] ← to.AddPair[[pair[left], mv.it]] ELSE [] ← to.Delete[pair[left]];
RETURN};
p.Enumerate[PerPair];
RETURN};
PermuteInPlace:
PUBLIC
PROC [a: Sequence, p: Permutation] ~ {
done: Set--INT-- ~ CreateHashSet[ints];
PerPair:
PROC [pair: Pair] ~ {
startToI: INT ~ pair[left].VI;
fromI: INT ← pair[right].VI;
IF fromI = startToI THEN RETURN;
IF done.HasMemI[fromI] THEN RETURN;
{startMV: MaybeValue ~ a.ApplyI[startToI];
toI: INT ← startToI;
UNTIL fromI = startToI
DO
moveMV: MaybeValue ~ a.ApplyI[fromI];
IF NOT done.AddI[fromI] THEN ERROR;
IF moveMV.found THEN [] ← a.AddPair[[IV[toI], moveMV.it]] ELSE [] ← a.DeleteI[toI];
toI ← fromI;
fromI ← p.ApplyI[toI].MI;
ENDLOOP;
IF NOT done.AddI[fromI] THEN ERROR;
IF startMV.found THEN [] ← a.AddPair[[IV[toI], startMV.it]] ELSE [] ← a.DeleteI[toI];
RETURN}};
p.Enumerate[PerPair];
RETURN};
Start:
PROC ~ {
FOR const:
BOOL
IN
BOOL
DO
esClasses[const] ← CreateClass[[
Primitive: ESPrimitive,
ScanRestriction: ESScanRestriction,
GetBounds: ESGetBounds,
ValueOf: ESValueOf,
SetOn: ESSetOn,
Spaces: ESSpaces,
functional: ALL[TRUE],
mutability: IF const THEN constant ELSE readonly]];
ENDLOOP;
};
Start[];
END.