Topspeed_JPI/TS/GRAPHIX/COLORPAL.MOD

(******************************************************************************)
(*                              COLORPAL.MOD                                  *)
(*                                                                            *)
(*    MetaWINDOW HOWTO: program series.  Demonstrates usage of Read / Write / *)
(*    LoadPalette.                                                            *)
(* Transcribed from COLORPAL.C METAGRAPHICS SOFTWARE CORPORATION (c) 1987-1989*)
(*                                                                            *)
(*  PSW 06/28/91 08:30am                                                      *)
(******************************************************************************)

MODULE ColorPal;
(*
 *  Graphix
 *  Release 3.7
 *  (c) Copyright 1986-1992 PMI
 *  Green Bay, Wisconsin
 *  (414) 468-6040
 *  All rights reserved
 *
 *)

  IMPORT GrConst;
  IMPORT GrPorts;
  IMPORT GrFonts;
  IMPORT Meta;
  IMPORT GrQry;
  IMPORT IO;
  IMPORT Str;
  IMPORT Lib;

  FROM GrConst IMPORT rect, point, event, palData;
  FROM GrPorts IMPORT adsPort;
  FROM GrFonts IMPORT adsFont;
  FROM Storage IMPORT ALLOCATE, DEALLOCATE;

  CONST
    MOUSE_RIGHT = 0100H;
    MOUSE_LEFT  = 0400H;
    EGAADJUST   = 4000H;


  VAR
    GrafixCard,
    CommPort:     INTEGER;
    control:      ARRAY [0..3] OF LONGINT;
    paltype:      INTEGER;
    palColors:    ARRAY[0..1] OF palData;
    max_colors,
    colors:       INTEGER;
    OK:           BOOLEAN;
    i,
    selPalEntry,
    curs, buttons,
    x, y, speed:  INTEGER;
    scrnR:        rect;
    myevent:      event;
    cursor_pt:    point;
    thePort:      adsPort;   (* pointer to default MetaWINDOW port     *)
    buf, fntpath: ARRAY [0..25] OF CHAR;
    val:          ARRAY[0..10] OF CHAR;
    fontbuf:      adsFont;

    (* default EGA style palette *)

    palette:    ARRAY [0..15] OF WORD;

(*** Draw a screen full of boxes, one for each color combination.           ***)

  PROCEDURE draw_palette();
    VAR
      color:  INTEGER;
      r:      rect;
  BEGIN

    Meta.MoveTo(0, 0);

    IF max_colors > 16 THEN
      Meta.SetRect(r, 0, 0, 30, 40);

      FOR color := 0 TO max_colors DO
        Meta.PenColor(color);
        Meta.PaintRect(r);
        Meta.PenColor(GrConst.White);
        Meta.FrameRect(r);

        Meta.OffsetRect(r, 40, 0);

        IF r.Xmax > 640 THEN
            r.Xmin := 0;
            r.Xmax := 30;
            Meta.OffsetRect(r, 0, 50);
        END;
      END;
    ELSE
      Meta.SetRect(r, 0, 0, 100, 100);

      FOR color := 0 TO max_colors DO
        Meta.PenColor(color);
        Meta.PaintRect(r);
        Meta.PenColor(GrConst.White);
        Meta.FrameRect(r);

        Meta.MoveTo(r.Xmin + 49, r.Ymax + 35);
        Str.IntToStr(LONGINT(color), val, 10, OK);
        Meta.DrawString(val);

        Meta.OffsetRect(r, 150, 0);

        IF r.Xmax > 599 THEN
          r.Xmin := 0;
          r.Xmax := 100;
          Meta.OffsetRect(r, 0, 200);
        END
      END
    END
  END draw_palette;


(*** Check to see if thepoint is in one of the palette display boxes.       ***)
(*** Returns the palette entry corresponding to that box, or -1 if not      ***)
(*** in any box                                                             ***)

  PROCEDURE check_palette(VAR thepoint: point): INTEGER;
    VAR
      color: INTEGER;
      r: rect;
  BEGIN

    Meta.MoveTo(0, 0);

    IF max_colors > 16 THEN
      Meta.SetRect(r, 0, 0, 30, 40);

      FOR color := 0 TO max_colors DO
        IF Meta.PtInRect(thepoint,  r) THEN
           RETURN color;
        END;

        Meta.OffsetRect(r, 40, 0);

        IF r.Xmax > 640 THEN
          r.Xmin := 0;
          r.Xmax := 30;
          Meta.OffsetRect(r, 0, 50);
        END
      END
    ELSE
      Meta.SetRect(r, 0, 0, 100, 100);

      FOR color := 0 TO max_colors DO
        IF Meta.PtInRect(thepoint,  r) THEN
           RETURN color;
        END;

        Meta.OffsetRect(r, 150, 0);
        IF r.Xmax > 599 THEN
            r.Xmin := 0;
            r.Xmax := 100;
            Meta.OffsetRect(r, 0, 200);
        END
      END
    END;

    RETURN -1;
  END check_palette;


  PROCEDURE Insert(VAR S1: ARRAY OF CHAR; S2: ARRAY OF CHAR; Pos, Width: CARDINAL);
    VAR
      L1, L2, i: CARDINAL;
  BEGIN
    L1 := HIGH(S1);
    L2 := Str.Length(S2);

    IF (Pos + Width) > L1 THEN
      RETURN
    END;

    IF L2 > Width THEN
      RETURN
    END;

    FOR i := 0 TO L2 DO
      S1[Pos + i] := S2[i];
    END;

    FOR i := Pos + L2 TO Pos + Width DO
      S1[i] := ' ';
    END;
  END Insert;

(*** Fill the color mixing rectangle with color 'palval'.                   ***)

  PROCEDURE draw_clr_rect(palval: CARDINAL);
    VAR
      color_rect: rect;
  BEGIN
    Meta.SetRect(color_rect, 0, 0, 100, 100);
    Meta.OffsetRect(color_rect, 725, 100);
    Meta.PenColor(palval);
    Meta.ProtectRect(color_rect);
    Meta.PaintRect(color_rect);
    Meta.PenColor(GrConst.White);
    Meta.FrameRect(color_rect);
    Meta.ProtectOff();

    Str.IntToStr(LONGINT(palval), val, 16, OK);
    Str.Append(val, ':');
    Insert(buf, val, 0, 24);

    IF paltype = 1 THEN  (* analog palette *)
      Str.IntToStr(LONGINT(palColors[0].palRed), val, 16, OK);
      Insert(buf, val, 6, 6);
      Str.IntToStr(LONGINT(palColors[0].palGreen), val, 16, OK);
      Insert(buf, val, 12, 6);
      Str.IntToStr(LONGINT(palColors[0].palBlue), val, 16, OK);
      Insert(buf, val, 18, 6);
    ELSE
      Insert(buf, val, 0, 6);
      Str.IntToStr(LONGINT(palette[palval]), val, 16, OK);
      Insert(buf, val, 6, 6);
    END;

    buf[24] := CHR(0);

    Meta.MoveTo(650, 100 - 40);
    Meta.DrawString(buf);
  END draw_clr_rect;


  PROCEDURE draw_control(num:INTEGER);
    VAR
      r: rect;
      i, x, y: INTEGER;
      color: CHAR;
  BEGIN

    CASE num OF
    | 0: x := 670; color := 'R';
    | 1: x := 770; color := 'G';
    | 2: x := 870; color := 'B';
    ELSE
      RETURN;
    END;

    y := 300;

    (* draw scale *)
    Meta.PenColor(GrConst.White);
    Meta.MoveTo(x, y);
    Meta.LineRel(0, 500);

    Meta.MoveTo(x, y);
    Meta.LineTo(x - 20, y);

    Meta.MoveTo(x, y + 500);
    Meta.LineTo(x - 20, y + 500);

    FOR i := y TO y + 500 BY 20 DO
      Meta.MoveTo(x, i);
      Meta.LineTo(x - 10, i);
    END;

    (* draw 'R' 'G' or 'B' *)
    Meta.MoveTo(x, y - 30);
    Meta.DrawChar(color);

    (* draw '+/-' control *)
    INC(y, 520);
    Meta.SetRect(r, x - 30, y, x + 30, y + 50);
    Meta.FrameRect(r);
    Meta.MoveTo(x, y);
    Meta.LineTo(x, y + 50);

    Meta.MoveTo(r.Xmin + 5, y + 40);
    Meta.DrawChar('+');

    Meta.MoveTo(x + 5, y + 40);
    Meta.DrawChar('-');
  END draw_control;

(*** Draw the control panel ***)

  PROCEDURE draw_panel();
  BEGIN
    Meta.PenColor(GrConst.White);

    draw_control(0);
    draw_control(1);
    draw_control(2);
    draw_clr_rect(0);
  END draw_panel;


(*** Draw a thermometer type indicator bar for control 'num'.               ***)

  PROCEDURE draw_indicator(num: CARDINAL);
    VAR
      x, y, i: CARDINAL;
      r: rect;
  BEGIN

    x := 670 + 100 * num;
    y := 300;

    (* compute scale factor *)
    i := CARDINAL(control[num] DIV 131);   (* 0xFFFF / 500 appx := 131 *)

    (* fill on part *)
    Meta.SetRect(r, x + 1, y + 500 - i, x + 10, y + 500);
    Meta.ProtectRect(r);
    Meta.PaintRect(r);
    Meta.ProtectOff();

    (* erase off part *)
    Meta.SetRect(r, x + 1, y, x + 10, y + 500 - i);
    Meta.ProtectRect(r);
    Meta.EraseRect(r);
    Meta.ProtectOff();
  END draw_indicator;

(*** Check to see if thepoint is in one of the control knobs. Returns knob  ***)
(*** number or -1 if not in any knob.                                       ***)

  PROCEDURE check_panel(VAR thepoint: point): INTEGER;
    VAR
      knob, x, y: INTEGER;
      r: rect;
  BEGIN
    y := 300 + 520;

    FOR knob := 0 TO 2 DO
      x := 670 + 100 * knob;

      Meta.SetRect(r, x - 30, y, x + 30, y + 50);

      IF (Meta.PtInRect(thepoint, r)) THEN
        r.Xmin := (r.Xmax + r.Xmin) DIV 2;

        IF Meta.PtInRect(thepoint, r) THEN
          RETURN (knob * 2 + 1);
        END;

        RETURN (knob * 2);
      END;
    END;

    RETURN -1;
  END check_panel;

(*** Analog palette version ***)

(*** For color number entry 'palval' change color register entry.           ***)

  PROCEDURE ANmix_color(palval: CARDINAL);
    VAR
  BEGIN
    palColors[0].palRed   := WORD(control[0]);
    palColors[0].palGreen := WORD(control[1]);
    palColors[0].palBlue  := WORD(control[2]);

    Meta.WritePalette(0, palval, palval, palColors);

    Str.IntToStr(LONGINT(palval), val, 16, OK);
    Str.Append(val, ':');
    Insert(buf, val, 0, 24);
    Str.IntToStr(LONGINT(palColors[0].palRed), val, 16, OK);
    Insert(buf, val, 6, 6);
    Str.IntToStr(LONGINT(palColors[0].palGreen), val, 16, OK);
    Insert(buf, val, 12, 6);
    Str.IntToStr(LONGINT(palColors[0].palBlue), val, 16, OK);
    Insert(buf, val, 18, 6);
    buf[24] := CHR(0);

    Meta.MoveTo(650, 100 - 40);
    Meta.DrawString(buf);
  END ANmix_color;

(*** Get color value of palval and set controls.                            ***)

  PROCEDURE ANunmix_color(palval: CARDINAL);
  BEGIN
    Meta.ReadPalette(0, palval, palval, palColors);
    control[0] := LONGINT(palColors[0].palRed);
    control[1] := LONGINT(palColors[0].palGreen);
    control[2] := LONGINT(palColors[0].palBlue);
  END ANunmix_color;

(* digital palette version *)

(*** For palette entry 'palval', mix the current control values per EGA,    ***)
(*** store in palette array, and change hardware palette entry.             ***)

  PROCEDURE EGAmix_color(palval: CARDINAL);
    VAR
      red, green, blue, mix: WORD;
      paletteVals:           ARRAY [0..0] OF WORD;
  BEGIN
    red      := WORD(control[0] DIV EGAADJUST);
    green    := WORD(control[1] DIV EGAADJUST);
    blue     := WORD(control[2] DIV EGAADJUST);

    mix := 0;

    IF INTEGER(BITSET(blue) * BITSET(0001H)) # 0 THEN
      mix := BITSET(mix) + BITSET(0008H);
    END;
    IF INTEGER(BITSET(blue) * BITSET(0002H)) # 0 THEN
      mix := BITSET(mix) + BITSET(0001H);
    END;

    IF INTEGER(BITSET(green) * BITSET(0001H)) # 0 THEN
      mix := BITSET(mix) + BITSET(0010H);
    END;
    IF INTEGER(BITSET(green) * BITSET(0002H)) # 0 THEN
      mix := BITSET(mix) + BITSET(0002H);
    END;

    IF INTEGER(BITSET(red) * BITSET(0001H)) # 0 THEN
      mix := BITSET(mix) + BITSET(0020H);
    END;
    IF INTEGER(BITSET(red) * BITSET(0002H)) # 0 THEN
      mix := BITSET(mix) + BITSET(0004H);
    END;

    Str.IntToStr(LONGINT(palval), val, 16, OK);
    Str.Append(val, ':');
    Insert(buf, val, 0, 24);
    Str.IntToStr(LONGINT(mix), val, 16, OK);
    Insert(buf, val, 6, 6);
    buf[24] := CHR(0);

    Meta.MoveTo(650, 100 - 40);
    Meta.DrawString(buf);

    paletteVals[0] := mix;
    Meta.LoadPalette(palval, palval, paletteVals);
  END EGAmix_color;

(*** Take color value  of palval apart per EGA and set global control array ***)
(*** to its components.                                                     ***)

  PROCEDURE EGAunmix_color(palval: CARDINAL);
    VAR
      red, green, blue, mix: WORD;
  BEGIN

    red   := 0;
    green := 0;
    blue  := 0;

    mix   := WORD(palette[palval]);

    IF INTEGER(BITSET(mix) * BITSET(0008H)) # 0 THEN
      blue := BITSET(blue) + BITSET(0001H);
    END;
    IF INTEGER(BITSET(mix) * BITSET(0001H)) # 0 THEN
      blue := BITSET(blue) + BITSET(0002H);
    END;

    IF INTEGER(BITSET(mix) * BITSET(0010H)) # 0 THEN
      green := BITSET(green) + BITSET(0001H);
    END;
    IF INTEGER(BITSET(mix) * BITSET(0002H)) # 0 THEN
      green := BITSET(green) + BITSET(0002H);
    END;

    IF INTEGER(BITSET(mix) * BITSET(0020H)) # 0 THEN
      red := BITSET(red) + BITSET(0001H);
    END;
    IF INTEGER(BITSET(mix) * BITSET(0004H)) # 0 THEN
      red := BITSET(red) + BITSET(0002H);
    END;

    control[0] := LONGINT(red)   * EGAADJUST;
    control[1] := LONGINT(green) * EGAADJUST;
    control[2] := LONGINT(blue)  * EGAADJUST;
  END EGAunmix_color;


  PROCEDURE mix_color(palval: CARDINAL);
  BEGIN
    CASE paltype OF
    | 1: ANmix_color(palval);
    | 2: EGAmix_color(palval);
    ELSE
      GrQry.GrQuit('Device does not support a changeable color set', 1);
    END;
  END mix_color;


  PROCEDURE unmix_color(palval: CARDINAL);
  BEGIN
    CASE paltype OF
    | 1: ANunmix_color(palval);
    | 2: EGAunmix_color(palval);
    ELSE
      GrQry.GrQuit('Device does not support a changeable color set', 1);
    END;
  END unmix_color;

(*** Load the specified font. ***)

  PROCEDURE LoadFont(VAR fontName: ARRAY OF CHAR);
    VAR
      Dir:      GrConst.dirRec;
      qErr,
      loadErr:  INTEGER;
      path:     ARRAY[0..80] OF CHAR;
      fontBuf:  GrFonts.adsFont;
  BEGIN
    Str.Copy(path, fontName);
    loadErr := -1;                             (* Preempt Error *)
    qErr    := Meta.FileQuery(path, Dir, 1);

    IF (qErr # 1) THEN
      (* No font file in default dir, try environment variable *)
      Lib.EnvironmentFind("METAPATH", path);

      IF (path[0] # CHR(0)) THEN
        (* found the env parm, try using the path listed there *)

        IF (path[Str.Length(path)] # '\') THEN
          (* If no trailing slash, add one *)
          Str.Append(path, '\');
        END;

        Str.Append(path, fontName);
        qErr := Meta.FileQuery(path, Dir, 1);
      END;
    END;

    IF (qErr = 1) THEN
      (* we got our file *)
      ALLOCATE(ADDRESS(fontBuf), VAL(CARDINAL, Dir.fileSize + 1));

      IF (fontBuf # NIL) THEN
        (* We got our memory *)
        loadErr := Meta.FileLoad(path, ADDRESS(fontBuf), VAL(CARDINAL, Dir.fileSize+1));
        IF loadErr <= 0 THEN
          DEALLOCATE(ADDRESS(fontBuf), VAL(CARDINAL, Dir.fileSize + 1));
        END;
        Meta.SetFont(ADDRESS(fontBuf));
      END;
    END;

    IF (loadErr > 0) THEN
      (* clear out system load error *)
      qErr := Meta.QueryError();
    ELSE
      (* beep if font load probs *)
      IO.WrChar(CHR(7));
      Str.Copy(fontName, 'Using internal SYSTEM08.FNT');
    END;
  END LoadFont;


BEGIN

  (* init the system *)

  GrQry.GrQuery(GrafixCard, CommPort);

  i := Meta.InitGrafix(-GrafixCard);

  IF (i # 0) THEN
    (* Display reason for no go *)
    GrQry.GrInitErr(GrafixCard, CommPort, i);
  END;

  (* Default EGA palette. *)

  palette[0]  := 0;
  palette[1]  := 1;
  palette[2]  := 2;
  palette[3]  := 3;
  palette[4]  := 4;
  palette[5]  := 5;
  palette[6]  := 14H;
  palette[7]  := 7;
  palette[8]  := 38H;
  palette[9]  := 39H;
  palette[10] := 3AH;
  palette[11] := 3BH;
  palette[12] := 3CH;
  palette[13] := 3DH;
  palette[14] := 3EH;
  palette[15] := 3FH;

  Meta.SetDisplay(GrConst.GrafPg0);
  Meta.InitMouse(CommPort);
  Meta.ScreenRect(scrnR);
  Meta.LimitMouse(scrnR.Xmin, scrnR.Ymin, scrnR.Xmax, scrnR.Ymax);

  Meta.SetRect(scrnR, 0, 0, 1000, 1000);
  Meta.VirtualRect(scrnR);
  Meta.EraseRect(scrnR);

  (* load the font *)
  Meta.GetPort(thePort);
  i := thePort^.portBMap^.devClass;

  IF thePort^.portBMap^.pixPlanes > 1 THEN
    i := INTEGER(BITSET(i) * BITSET(0FFF8H));
  END;

  Str.Copy(fntpath, 'SYSTEM');
  Str.IntToStr(LONGINT(i), val, 10, OK);
  Str.Append(fntpath, val);
  Str.Append(fntpath, '.FNT');

  LoadFont(fntpath);

  max_colors := Meta.QueryColors();

  paltype := 0;

  IF max_colors = 255 THEN
     paltype := 1;                                  (* Use analog palette routines *)
  ELSIF GrafixCard = GrConst.EGA640x480 THEN        (* this is a vga in 16 color modes *)
                                                    (* Use VGA 640x480 in analog mode *)
    FOR i := 0 TO 15 DO
      palette[i] := i;                              (* set array for vga stuff *)
    END;

    Meta.LoadPalette(0, 15, palette);             (* set digital palette *)

    palColors[0].palRed   := 0FFFFH;
    palColors[0].palGreen := 0FFFFH;
    palColors[0].palBlue  := 0FFFFH;

    Meta.WritePalette(0, 0FH, 0FH, palColors[0]); (* make sure white is set *)
    paltype := 1; (* Use anlog palette routines *)
  ELSIF thePort^.portBMap^.devType = 1 THEN   (* EGA ?, not 640x480 *)
    paltype := 2; (* Use EGA palette routines *)
  END;

  (* draw the palette *)
  draw_palette();

  (* draw the control panel *)
  draw_panel();

  (* turn on cursor tracking *)
  Meta.TrackCursor(TRUE);
  Meta.ShowCursor();

  (* turn on event system *)
  Meta.EventQueue(TRUE);

  (* start with palette entry 0 *)
  selPalEntry := 0;
  unmix_color(selPalEntry);
  draw_indicator(0);
  draw_indicator(1);
  draw_indicator(2);
  draw_clr_rect(selPalEntry);

  speed := 1;   (* initialize the control speed *)
  (* process events *)
  LOOP
    (* get an event *)
    OK := Meta.KeyEvent(FALSE, myevent);
    cursor_pt.X := myevent.CursorX;
    cursor_pt.Y := myevent.CursorY;

    (* if we had a mouse event *)
    IF OK & (myevent.ASCII = CHR(0)) & (myevent.ScanCode = BYTE(0)) THEN
      (* right button is exit *)
      IF INTEGER(BITSET(myevent.State) * BITSET(MOUSE_RIGHT)) # 0 THEN
        EXIT;
      END;

      (* left button is select *)
      IF INTEGER(BITSET(myevent.State) * BITSET(MOUSE_LEFT)) # 0 THEN
        (* clicked a palette box ? *)
        i := check_palette(cursor_pt);
        IF (i >= 0) THEN
            (* select palette entry for editing *)
            selPalEntry := i;
            unmix_color(selPalEntry);
            draw_indicator(0);
            draw_indicator(1);
            draw_indicator(2);
            draw_clr_rect(selPalEntry);
        ELSE
          (* clicked a control ? *)
          buttons := 1;

          LOOP
            i := check_panel(cursor_pt);

            IF (i < 0) OR (buttons = 0) THEN
              EXIT;
            END;
            (* adjust selected control *)
            CASE i OF
            | 0: INC(control[0], LONGINT(speed)); i := 0;
            | 1: DEC(control[0], LONGINT(speed)); i := 0;
            | 2: INC(control[1], LONGINT(speed)); i := 1;
            | 3: DEC(control[1], LONGINT(speed)); i := 1;
            | 4: INC(control[2], LONGINT(speed)); i := 2;
            | 5: DEC(control[2], LONGINT(speed)); i := 2;
            ELSE
              i := 0;
            END;

            (* move fast or slow *)
            IF speed < 7FFH THEN
              INC(speed, 3FH);
            ELSE
              speed := 7FFH;  (* fast slow move *)
            END;

            (* keep in range *)
            IF (control[i] > 0FFFFH) THEN
              control[i] := 0FFFFH;
            END;
            IF (control[i] < 0) THEN
              control[i] := 0H;
            END;

            (* update control indicator *)
            draw_indicator(i);

            (* update the palette *)
            mix_color(selPalEntry);

            (* read current cursor position *)
            Meta.QueryCursor(x, y, curs, buttons);
            cursor_pt.X := x;
            cursor_pt.Y := y;
          END; (* end of while on a control *)
        END;
      END;  (* end of if left button *)
    END;  (* end of if mouse event *)
    IF (speed > 80H) THEN
      DEC(speed, 7FH);
    ELSE
      speed := 1;  (* slow move *)
    END;
  END;  (* end of while(True) *)

  GrQry.GrQuit('', 0);
END ColorPal.