MODULE GDPool;

IMPORT Wr, Fmt, Random, Thread;
FROM Stdio IMPORT stderr;

IMPORT NamedColors;

FROM GDGeometry IMPORT INT, BOOL, NAT, SIGN;

<* FATAL Wr.Failure, Thread.Alerted *>

REVEAL 
  T = PublicT BRANDED OBJECT
      ctr: NAT;             (* Counter of insertions. *)
      nC: NAT;              (* Number of scoring criteria. *)
      n: NAT;               (* Number of non-NIL entries. *)
      entry: REF Entries;   (* Items in pool, with rank, insertion time, etc.. *)
      rnd: Random.T;        (* Coin bag. *)
      ppt: REF Plots;       (* Progress plots for entry lifetimes. *)
      ranksOK: BOOL;        (* TRUE if the ranks of the items are correct. *)
    OVERRIDES  
      init := InitMethod;
      read := ReadMethod;
      store := StoreMethod;
      void := VoidMethod;
    END;

TYPE
  Entry = RECORD
      it: Item;       (* An item. *)
      rank: NAT;      (* Rank in pool (0 = minimal). *)
      seq: NAT;       (* Sequential count. *)
      since: Time;    (* Time when the item was added to pool. *)
    END;
    
  Entries = ARRAY OF Entry;

PROCEDURE InitMethod(pool: T; size: NAT; nC: NAT; ppt: REF Plots): T =
  BEGIN
    pool.n := 0;
    pool.nC := nC;
    pool.ctr := 0;
    pool.entry := NEW(REF ARRAY OF Entry, size);
    pool.ppt := ppt;
    IF ppt # NIL THEN <* ASSERT NUMBER(ppt^) = nC *> END;
    pool.rnd := NEW(Random.Default).init(fixed := TRUE);
    pool.ranksOK := TRUE;
    RETURN pool
  END InitMethod;

PROCEDURE ReadMethod(pool: T): Item =
  BEGIN
    IF pool.n = 0 THEN
      RETURN NIL
    ELSE
      WITH k = pool.rnd.integer(0, pool.n-1) DO
        Wr.PutText(stderr, "* " & FEntry(pool.entry[k]) & "\n");
        RETURN pool.entry[k].it
      END
    END
  END ReadMethod;

PROCEDURE StoreMethod(pool: T; it: Item; clock: Time) =
  BEGIN
    <* ASSERT pool.ranksOK *>
    IF it = NIL THEN RETURN END;
    IF pool.n >= NUMBER(pool.entry^) THEN
      EVAL DeleteSol(pool, clock)
    END;

    WITH 
      k = pool.n + 0,
      entry = pool.entry^
    DO
      <* ASSERT pool.n < NUMBER(entry) *>
      entry[k] := Entry{it := it, since := clock, seq := pool.ctr, rank := 0};
      INC(pool.ctr);
      INC(pool.n);
      FixRanks(SUBARRAY(entry, 0, pool.n), pool.nC);
      pool.ranksOK := TRUE;
      Wr.PutText(stderr, "+ " & FEntry(entry[k]) & "\n");
    END
  END StoreMethod;
  
PROCEDURE VoidMethod(pool: T; clock: Time): REF ARRAY OF Item =
  BEGIN
    <* ASSERT pool.ranksOK *>
    Wr.PutText(stderr, "writing pool ...\n"); 
    WITH
      n = pool.n + 0, 
      sdR = NEW(REF ARRAY OF Item, n), it = sdR^
    DO
      FOR i := 0 TO n-1 DO
        WITH en = DeleteSol(pool, clock) DO
          it[i] := en.it;
        END
      END;
      pool.ranksOK := TRUE; (* ...vacuously. *)
      RETURN sdR
    END
  END VoidMethod;
  
(* INTERNAL PROCEDURES *)

PROCEDURE DeleteSol(VAR pool: T; clock: Time): Entry =
  (*
    Picks a random solution and deletes it. NOTE: does not change the
    ranks of entrys in pool, which therefore become invalid. *)

  BEGIN
    WITH 
      n = pool.n,
      entry = pool.entry^
    DO

      PROCEDURE Del(k: NAT): Entry =
        (* Deletes entry "k" *)
        VAR e := entry[k];
        BEGIN
          Wr.PutText(stderr, "- " & FEntry(e) & "\n");
          IF pool.ppt # NIL THEN PlotLife(pool.ppt^, e.since, e.it, clock) END;
          FOR i := k TO n-2 DO entry[i] := entry[i+1] END;
          DEC(n);
          pool.ranksOK := FALSE;
          RETURN e
        END Del;

      VAR s: NAT;
      BEGIN
        s := 0;
        FOR i := 0 TO n-1 DO s := s + entry[i].rank END;
        IF s = 0 THEN 
          RETURN Del(pool.rnd.integer(0, n-1))
        ELSE
          WITH toss = pool.rnd.integer(0, s-1) DO
            s := 0;
            FOR i := 0 TO n-1 DO
              s := s + entry[i].rank;
              IF s > toss THEN RETURN Del(i) END
            END;
            <* ASSERT FALSE *>
          END
        END
      END
    END
  END DeleteSol;
  
PROCEDURE PlotLife(READONLY ppt: Plots; since: Time; it: Item; clock: Time) =
  BEGIN
    FOR k := 0 TO LAST(ppt) DO
      WITH f = ppt[k] DO
        IF f # NIL THEN
          f.plotLife(NamedColors.LtGray, since, it.score(k), clock)
        END
      END
    END;
  END PlotLife;

PROCEDURE FixRanks(VAR entry: ARRAY OF Entry; nC: NAT) =
  (*
    Recomputes the relative ranks of the given entrys. *)
  VAR i, j, k: NAT;
  VAR t: Entry;
  BEGIN
    i := 0;
    WHILE i <= LAST(entry) DO
      (* Compute the rank of "entry[i]" relative to the preceding entrys. *)
      (* Assumes the preceding entries are sorted by increasing rank. *)
      entry[i].rank := 0;
      j := i; 
      WHILE j > 0 DO
        DEC(j);
        WITH cmp = CompareScores(entry[j].it, entry[i].it, nC) DO
          IF cmp = -1 THEN 
            entry[i].rank := entry[j].rank + 1; j := 0;
          ELSIF cmp = +1 THEN
            (* Oops, "entry[j]" has wrong rank. Kick it up. *)
            t := entry[j]; k := j; 
            WHILE k < i DO entry[k] := entry[k+1]; INC(k) END;
            entry[i] := t;
            DEC(i)
          END
        END
      END;
      (* Now "entry[i].rank" is correct among "entry[0..i]". *)
      (* and "entry[i]" is not less than "entry[0..i-1]". *)
      (* Bubble it to the right position: *)
      j := i; 
      WHILE j > 0 AND entry[j-1].rank > entry[j].rank DO
        t := entry[j]; entry[j] := entry[j-1]; entry[j-1] := t;
        DEC(j)
      END;
      (* OK, get next entry: *)
      INC(i);      
    END;
    CheckRanks(entry, nC); (* Just for sure... *)
  END FixRanks;

PROCEDURE CheckRanks(READONLY entry: ARRAY OF Entry; nC: NAT) =
  (* 
    Checks whether the ranks are correct by the definition. *)
  VAR r: NAT;
  BEGIN
    FOR i := 0 TO LAST(entry) DO
      r := 0;
      FOR j := 0 TO LAST(entry) DO
        IF i # j AND CompareScores(entry[i].it, entry[j].it, nC) = +1 THEN
          r := MAX(r, entry[j].rank + 1)
        END
      END;
      <* ASSERT entry[i].rank = r *>
    END
  END CheckRanks;

PROCEDURE FEntry(READONLY entry: Entry): TEXT = 
  (*
    Formats a pool entry as a TEXT. *)
  BEGIN
    RETURN 
      "seq = " & FI(entry.seq) & "  " &
      "rank = " & FI(entry.rank) & "  " &
      entry.it.descr
  END FEntry;

PROCEDURE CompareScores(ita, itb: Item; nC: NAT): SIGN =
  VAR na, nb: NAT := 0;
  BEGIN
    FOR k := 0 TO nC-1 DO 
      WITH sa = ita.score(k), sb = itb.score(k) DO
        IF sa > sb THEN 
          INC(na)
        ELSIF sa < sb THEN 
          INC(nb)
        END
      END
    END;
    IF na = 0 AND nb = 0 
    OR na > 0 AND nb > 0 THEN
      RETURN 0
    ELSIF na > 0 THEN
      RETURN +1
    ELSE
      RETURN -1
    END
  END CompareScores;

PROCEDURE FI(x: INT): TEXT = 
  BEGIN RETURN Fmt.Int(x) END FI;

BEGIN
END GDPool.
(* Last edited on 2000-01-13 12:14:35 by stolfi *)