(* Copyright (C) 1992, Digital Equipment Corporation                         *)
(* All rights reserved.                                                      *)
(* See the file COPYRIGHT for a full description.                            *)
(*                                                                           *)
(* Last modified on Thu Jul 30 23:17:19 PDT 1992 by meehan   *)
(*      modified on Tue Jun 16 13:08:34 PDT 1992 by muller   *)
(*      modified on Sat Jun 13 09:41:01 1992 by mhb      *)


MODULE MultiClass;

IMPORT List, Multi, Split, VBT;

EXCEPTION FatalError; <* FATAL FatalError *>

REVEAL
  T = Public BRANDED "MultiClass.T" OBJECT
      OVERRIDES
        (*
        replace := ReplaceCrash;
        insert  := InsertCrash;
        *)
        move    := MoveDefault;
        succ    := SuccDefault;
        pred    := PredDefault;
        nth     := NthDefault;
        index   := IndexDefault;
      END;

TYPE
  Prop = REF RECORD t: T END;
  ChProp = REF RECORD parents: List.T (* of VBT.T *) END;

PROCEDURE Be (vbt: VBT.T; t: T) =
  BEGIN
    t.vbt := vbt;
    VBT.PutProp (vbt, NEW (Prop, t := t))
  END Be;

PROCEDURE Resolve (vbt: VBT.T): T =
  VAR prop: Prop := VBT.GetProp (vbt, TYPECODE (Prop));
  BEGIN
    IF prop = NIL THEN RETURN NIL ELSE RETURN prop.t END
  END Resolve;

PROCEDURE BeChild (vbt: VBT.T; ch: VBT.T) =
  VAR chProp: ChProp := VBT.GetProp (ch, TYPECODE (ChProp));
  BEGIN
    IF chProp = NIL THEN
      chProp := NEW (ChProp);
      VBT.PutProp (ch, chProp);
    END;
    List.Push (chProp.parents, vbt);
  END BeChild;

PROCEDURE UnChild (vbt: VBT.T; ch: VBT.T) =
  VAR chProp: ChProp := VBT.GetProp (ch, TYPECODE (ChProp));
  BEGIN
    chProp.parents := List.Delete (chProp.parents, vbt)
  END UnChild;

PROCEDURE IsChild (vbt: VBT.T; ch: VBT.T): BOOLEAN =
  BEGIN
    RETURN List.Member(Parents(ch), vbt)
  END IsChild;

PROCEDURE Parents (ch: VBT.T): List.T =
  VAR chProp: ChProp := VBT.GetProp (ch, TYPECODE (ChProp));
  BEGIN
      IF chProp = NIL THEN RETURN NIL ELSE RETURN chProp.parents END
  END Parents;

PROCEDURE MoveDefault (t: T; pred, ch: VBT.T) RAISES {Multi.NotAChild} =
  BEGIN
    Multi.Delete (t.vbt, ch);
    Multi.Insert (t.vbt, pred, ch);
  END MoveDefault;

PROCEDURE SuccDefault (t: T; ch: VBT.T): VBT.T RAISES {Multi.NotAChild} =
  VAR chP, oldP, p: VBT.T;
  BEGIN
    TRY
      chP := ch;
      IF chP = NIL THEN p := t.vbt ELSE p := VBT.Parent (chP) END;
      REPEAT
        chP := Split.Succ (p, chP);
        WHILE (chP = NIL) AND (p # t.vbt) DO
          oldP := p;
          p := VBT.Parent (p);
          chP := Split.Succ (p, oldP);
        END;
        WHILE (chP # NIL) AND (NOT IsChild (t.vbt, chP)) AND HasChild (chP)
          DO
          p := chP;
          chP := Split.Succ (p, NIL);
        END;
      UNTIL (chP = NIL) OR IsChild (t.vbt, chP);
      RETURN chP
    EXCEPT
      Split.NotAChild => RAISE Multi.NotAChild
    END
  END SuccDefault;

PROCEDURE HasChild (v: VBT.T): BOOLEAN =
  <* FATAL Multi.NotAChild *>
  BEGIN
    WITH t = Resolve(v) DO 
      RETURN (t # NIL) AND (t.succ(NIL) # NIL) 
    END
  END HasChild;

PROCEDURE PredDefault (t: T; ch: VBT.T): VBT.T RAISES {Multi.NotAChild} =
  VAR next, res: VBT.T;
  BEGIN
    TRY
      next := t.succ (NIL);
      WHILE next # NIL AND next # ch DO
        res := next;
        next := t.succ (res)
      END;
      IF next = ch THEN RETURN res ELSE RAISE FatalError END
    EXCEPT
      Split.NotAChild => RAISE Multi.NotAChild
    END
  END PredDefault;

PROCEDURE NthDefault (t: T; n: CARDINAL): VBT.T =
  VAR ch: VBT.T;
  BEGIN
    TRY
      ch := t.succ (NIL);
      WHILE ch # NIL AND n # 0 DO DEC (n); ch := t.succ (ch) END;
      RETURN ch
    EXCEPT
      Multi.NotAChild => RAISE FatalError
    END
  END NthDefault;

PROCEDURE IndexDefault (t: T; ch: VBT.T): CARDINAL
  RAISES {Multi.NotAChild} =
  VAR
    res := 0;
    chP := t.succ (NIL);
  BEGIN
    WHILE chP # ch AND chP # NIL DO INC (res); chP := t.succ (chP) END;
    IF chP = ch THEN RETURN res ELSE RAISE FatalError END
  END IndexDefault;

BEGIN
END MultiClass.