<*PRAGMA LL*>

MODULE Palette;

IMPORT VBT, VBTRep, PaintOp, Font, Cursor, Pixmap,
  ScrnPixmap, ScrnCursor, ScrnFont, ScrnPaintOp, Thread;

FROM PlttFrnds IMPORT con, noOp, noFont, noCursor, noPixmap;

VAR
  c := NEW(Thread.Condition);

PROCEDURE FromOpClosure (cl: OpClosure): PaintOp.T =
  VAR
    res: PaintOp.T;
  BEGIN
    LOCK con DO
      res.op := con.nextOp;
      INC(con.nextOp);
      IF con.ops = NIL OR LAST(con.ops^) < res.op THEN
        VAR new := NEW(REF ARRAY OF OpClosure, MAX(2 * res.op, 5));
        BEGIN
          IF con.ops # NIL THEN
            SUBARRAY(new^, 0, NUMBER(con.ops^)) := con.ops^
          END;
          con.ops := new
        END
      END;
      con.ops[res.op] := cl
    END;
    RETURN res
  END FromOpClosure;

PROCEDURE ExtendOps (st: VBT.ScreenType) =
  VAR osz, sz: CARDINAL;
  BEGIN
    IF con.ops # NIL THEN sz := NUMBER(con.ops^) ELSE sz := con.nextOp END;
    IF st.ops = NIL OR sz > NUMBER(st.ops^) THEN
      VAR new := NEW(REF ARRAY OF ScrnPaintOp.T, RoundUp(sz));
      BEGIN
        IF st.ops # NIL THEN
          osz := NUMBER(st.ops^);
          SUBARRAY(new^, 0, osz) := st.ops^
        ELSE
          osz := 0
        END;
        FOR i := osz TO LAST(new^) DO new[i] := NIL END;
        st.ops := new
      END
    END
  END ExtendOps;

PROCEDURE ResolveOp(st: VBT.ScreenType; pop: PaintOp.T): ScrnPaintOp.T =
  VAR res: ScrnPaintOp.T; cl: OpClosure := NIL; op := pop.op;
  BEGIN
    IF op < 0 THEN Crash() END;
    IF st.ops # NIL AND op < NUMBER(st.ops^) THEN
      res := st.ops[op];
      IF res # NIL AND res # noOp THEN RETURN res END
    END;
    LOCK con DO
      IF op >= con.nextOp THEN Crash() END;
      IF st.ops = NIL OR op > LAST(st.ops^) THEN ExtendOps(st) END;
      WHILE st.ops[op] = noOp DO Thread.Wait(con, c) END;
      res := st.ops[op];
      IF res # NIL THEN RETURN res END;
      st.ops[op] := noOp;
      IF op > LAST(PaintOp.Predefined) THEN cl := con.ops[op] END
    END;
    res := st.opApply(cl, pop);
    IF res = NIL THEN res := ResolveOp(st, PaintOp.Transparent) END;
    LOCK con DO st.ops[op] := res END;
    Thread.Broadcast(c);
    RETURN res
  END ResolveOp;

PROCEDURE FromFontClosure(cl: FontClosure): Font.T =
  VAR res: Font.T; BEGIN
    LOCK con DO
      res.fnt := con.nextFont;
      INC(con.nextFont);
      IF con.fonts = NIL OR LAST(con.fonts^) < res.fnt THEN
        VAR new := NEW(REF ARRAY OF FontClosure, MAX(2*res.fnt,5)); BEGIN
          IF con.fonts # NIL THEN
            SUBARRAY(new^, 0, NUMBER(con.fonts^)) := con.fonts^
          END;
          con.fonts := new
        END
      END;
      con.fonts[res.fnt] := cl
    END;
    RETURN res
  END FromFontClosure;

PROCEDURE ExtendFonts (st: VBT.ScreenType) =
  VAR osz, sz: CARDINAL;
  BEGIN
    IF con.fonts # NIL THEN
      sz := NUMBER(con.fonts^)
    ELSE
      sz := con.nextFont
    END;
    IF st.fonts = NIL OR sz > NUMBER(st.fonts^) THEN
      VAR new := NEW(REF ARRAY OF ScrnFont.T, RoundUp(sz));
      BEGIN
        IF st.fonts # NIL THEN
          osz := NUMBER(st.fonts^);
          SUBARRAY(new^, 0, osz) := st.fonts^
        ELSE
          osz := 0
        END;
        FOR i := osz TO LAST(new^) DO new[i] := NIL END;
        st.fonts := new
      END
    END
  END ExtendFonts;

PROCEDURE ResolveFont (st: VBT.ScreenType; pfont: Font.T): ScrnFont.T =
  VAR
    res : ScrnFont.T;
    cl  : FontClosure := NIL;
    font              := pfont.fnt;
  BEGIN
    IF font < 0 THEN Crash() END;
    IF st.fonts # NIL AND font < NUMBER(st.fonts^) THEN
      res := st.fonts[font];
      IF res # NIL AND res # noFont THEN RETURN res END
    END;
    LOCK con DO
      IF font >= con.nextFont THEN Crash() END;
      IF st.fonts = NIL OR font > LAST(st.fonts^) THEN ExtendFonts(st) END;
      WHILE st.fonts[font] = noFont DO Thread.Wait(con, c) END;
      res := st.fonts[font];
      IF res # NIL THEN RETURN res END;
      st.fonts[font] := noFont;
      IF font > LAST(Font.Predefined) THEN cl := con.fonts[font] END
    END;
    res := st.fontApply(cl, pfont);
    IF res = NIL THEN res := ResolveFont(st, Font.BuiltIn) END;
    LOCK con DO st.fonts[font] := res END;
    Thread.Broadcast(c);
    RETURN res
  END ResolveFont;

PROCEDURE FromPixmapClosure(cl: PixmapClosure): Pixmap.T =
  VAR res: Pixmap.T; BEGIN
    LOCK con DO
      res.pm := con.nextPixmap;
      INC(con.nextPixmap);
      IF con.pixmaps = NIL OR LAST(con.pixmaps^) < res.pm THEN
        VAR new := NEW(REF ARRAY OF PixmapClosure, MAX(2*res.pm,5)); BEGIN
          IF con.pixmaps # NIL THEN
            SUBARRAY(new^, 0, NUMBER(con.pixmaps^)) := con.pixmaps^
          END;
          con.pixmaps := new
        END
      END;
      con.pixmaps[res.pm] := cl
    END;
    RETURN res
  END FromPixmapClosure;

PROCEDURE ExtendPixmaps (st: VBT.ScreenType) =
  VAR osz, sz: CARDINAL;
  BEGIN
    IF con.pixmaps # NIL THEN
      sz := NUMBER(con.pixmaps^)
    ELSE
      sz := con.nextPixmap
    END;
    IF st.pixmaps = NIL OR sz > NUMBER(st.pixmaps^) THEN
      VAR new := NEW(REF ARRAY OF ScrnPixmap.T, RoundUp(sz));
      BEGIN
        IF st.pixmaps # NIL THEN
          osz := NUMBER(st.pixmaps^);
          SUBARRAY(new^, 0, osz) := st.pixmaps^
        ELSE
          osz := 0
        END;
        FOR i := osz TO LAST(new^) DO new[i] := NIL END;
        st.pixmaps := new
      END
    END
  END ExtendPixmaps;

PROCEDURE ResolvePixmap (st: VBT.ScreenType; pix: Pixmap.T): ScrnPixmap.T =
  VAR
    res   : ScrnPixmap.T;
    cl    : PixmapClosure := NIL;
    pixmap                := pix.pm;
  BEGIN
    IF pixmap < 0 THEN Crash() END;
    IF st.pixmaps # NIL AND pixmap < NUMBER(st.pixmaps^) THEN
      res := st.pixmaps[pixmap];
      IF res # NIL AND res # noPixmap THEN RETURN res END
    END;
    LOCK con DO
      IF pixmap >= con.nextPixmap THEN Crash() END;
      IF st.pixmaps = NIL OR pixmap > LAST(st.pixmaps^) THEN
        ExtendPixmaps(st)
      END;
      WHILE st.pixmaps[pixmap] = noPixmap DO Thread.Wait(con, c) END;
      res := st.pixmaps[pixmap];
      IF res # NIL THEN RETURN res END;
      st.pixmaps[pixmap] := noPixmap;
      IF pixmap > LAST(Pixmap.Predefined) THEN
        cl := con.pixmaps[pixmap]
      END
    END;
    res := st.pixmapApply(cl, pix);
    IF res = NIL THEN res := ResolvePixmap(st, Pixmap.Empty) END;
    LOCK con DO st.pixmaps[pixmap] := res END;
    Thread.Broadcast(c);
    RETURN res
  END ResolvePixmap;

PROCEDURE FromCursorClosure(cl: CursorClosure): Cursor.T =
  VAR res: Cursor.T; BEGIN
    LOCK con DO
      res.cs := con.nextCursor;
      INC(con.nextCursor);
      IF con.cursors = NIL OR LAST(con.cursors^) < res.cs THEN
        VAR new := NEW(REF ARRAY OF CursorClosure, MAX(2*res.cs,5)); BEGIN
          IF con.cursors # NIL THEN
            SUBARRAY(new^, 0, NUMBER(con.cursors^)) := con.cursors^
          END;
          con.cursors := new
        END
      END;
      con.cursors[res.cs] := cl
    END;
    RETURN res
  END FromCursorClosure;

PROCEDURE ExtendCursors (st: VBT.ScreenType) =
  VAR osz, sz: CARDINAL;
  BEGIN
    IF con.cursors # NIL THEN
      sz := NUMBER(con.cursors^)
    ELSE
      sz := con.nextCursor
    END;
    IF st.cursors = NIL OR sz > NUMBER(st.cursors^) THEN
      VAR new := NEW(REF ARRAY OF ScrnCursor.T, RoundUp(sz));
      BEGIN
        IF st.cursors # NIL THEN
          osz := NUMBER(st.cursors^);
          SUBARRAY(new^, 0, osz) := st.cursors^
        ELSE
          osz := 0
        END;
        FOR i := osz TO LAST(new^) DO new[i] := NIL END;
        st.cursors := new
      END
    END
  END ExtendCursors;

PROCEDURE ResolveCursor (st: VBT.ScreenType; curs: Cursor.T):
  ScrnCursor.T =
  VAR
    res   : ScrnCursor.T;
    cl    : CursorClosure := NIL;
    cursor                := curs.cs;
  BEGIN
    IF cursor < 0 THEN Crash() END;
    IF st.cursors # NIL AND cursor < NUMBER(st.cursors^) THEN
      res := st.cursors[cursor];
      IF res # NIL AND res # noCursor THEN RETURN res END
    END;
    LOCK con DO
      IF cursor >= con.nextCursor THEN Crash() END;
      IF st.cursors = NIL OR cursor > LAST(st.cursors^) THEN
        ExtendCursors(st)
      END;
      WHILE st.cursors[cursor] = noCursor DO Thread.Wait(con, c) END;
      res := st.cursors[cursor];
      IF res # NIL THEN RETURN res END;
      st.cursors[cursor] := noCursor;
      IF cursor > LAST(Cursor.Predefined) THEN
        cl := con.cursors[cursor]
      END
    END;
    res := st.cursorApply(cl, curs);
    IF res = NIL THEN res := ResolveCursor(st, Cursor.DontCare) END;
    LOCK con DO st.cursors[cursor] := res END;
    Thread.Broadcast(c);
    RETURN res
  END ResolveCursor;

PROCEDURE RoundUp(sz: CARDINAL): CARDINAL =
  VAR i := 1; BEGIN
    WHILE i < sz DO INC(i, i) END;
    RETURN i
  END RoundUp;

PROCEDURE Init(st: VBT.ScreenType) =
  BEGIN
    IF st = NIL THEN RETURN END;
    FOR i := FIRST(Font.Predefined) TO LAST(Font.Predefined) DO
      EVAL ResolveFont(st, Font.T{i})
    END;
    FOR i := FIRST(Cursor.Predefined) TO LAST(Cursor.Predefined) DO
      EVAL ResolveCursor(st, Cursor.T{i})
    END;
    FOR i := FIRST(Pixmap.Predefined) TO LAST(Pixmap.Predefined) DO
      EVAL ResolvePixmap(st, Pixmap.T{i})
    END;
    FOR i := FIRST(PaintOp.Predefined) TO LAST(PaintOp.Predefined) DO
      EVAL ResolveOp(st, PaintOp.T{i})
    END;
  END Init;

EXCEPTION FatalError;

PROCEDURE Crash() =
  <*FATAL FatalError*>
  BEGIN
    RAISE FatalError
  END Crash;

BEGIN END Palette.