ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/GRAPHICS/PLOT/SURFUTI3.ZIP/PLAYPAL.PAS

Pascal/Delphi Source File | 1991-11-20 | 18.8 KB | 614 lines

{ PLAYPAL.PAS: Program to allow the user to play with the graphics
  palette for SURFMODL material definitions.
}
{$I defines.inc }
{$ifdef BIGMEM}
{$undef BIGMEM}
{$endif}
{$define PLAYPAL}   { Short-circuits some code in INITIAL.INC }

program PLAYPAL;
uses
{$IFDEF ANSICRT}
     ansicrt,
{$ELSE}
     crt,
{$ENDIF}
     dos,
     SURFGRAF,       { Graphics Routines }
     SHAREDEC,
     graph;

{$IFDEF USE8087}
type
  REAL = single;
{$ENDIF}

const MAXNODES = 1024;      { maximum # of nodes in the entire solid }
      MAXCONNECT = 4096;    { maximum # of connections in entire solid }
      MAXSURF = 1365;       { maximum # of surfaces in entire solid }
                            { (MAXSURF = MAXCONNECT / 3) }

{ Watch out for MAXMATL - This constant is repeated in SURFGRAF.PAS, so change
  it there too if you change it here: }
      MAXMATL = 50;         { maximum # of materials in entire solid }
      MAXPTS = 600;         { maximum # of line points (in fillsurf) }
      MAXVAR = 20;          { maximum # of numeric inputs on a line }
      MAXLITE = 20;         { maximum # of light sources }

      NSURF_MAT = 16;       { # surfaces to draw per material in PLAYPAL }
      SugTol = 0.05;        { suggestion tolerance is 5% }

      MAXFILES = 150;       { maximum # of files to select from }


type  points = array[1..MAXPTS] of integer;
      realpts = array[1..MAXPTS] of real;
      text80 = string[80];
      text255 = string[255];
      vartype = array[1..MAXVAR] of real;
      surfaces = array[1..MAXSURF] of real;
      vector = array[1..3] of real;
      nodearray= array[1..MAXNODES] of real;
      matlarray = array[1..MAXMATL] of integer;
      filename = string[12];
      filelist = array[1..MAXFILES] of filename;


type prim_color = ( Red, Grn, Blu );

var   Xworld, Yworld, Zworld: nodearray;
        { world coordinates of each node }
      Xtran, Ytran, Ztran: nodearray;
        { transformed coordinates of each node }
      Connect: array[1..MAXCONNECT] of integer;
        { surface connectivity data }
      Nvert: array[1..MAXSURF] of integer;
        { # vertices per surface }
      Matl: array[1..MAXSURF] of integer;
        { material number of each surface }
      { NOTE: The Shades, Surfmin, Surfmax, Nshades and Sshade arrays are
        defined in the individual procedures that require them, to save
        global variable space. }
      R1, R2, R3: array[1..MAXMATL] of real;
        { material reflectivity constants }
      Color: array[1..MAXMATL] of integer;
        { material color number }
      Ambient: array[1..MAXMATL] of real;
        { ambient light intensity for each material }
      Xlite, Ylite, Zlite: array[1..MAXLITE] of real;
        { coords of light sources }
      Intensity: array[1..MAXLITE] of real;
        { light source intensities }
      Matchanged: array[1..MAXMATL] of boolean;
        { has this material's colors been changed? }

      Xeye, Yeye, Zeye: real;              { coords of eye }
      Xfocal, Yfocal, Zfocal: real;        { coords of focal point }
      Maxvert: integer;                    { max # vertices per surface }
      Nsurf: integer;                      { # surfaces }
      Nnodes: integer;                     { # nodes }
      Nlite: integer;                      { # light sources }
      Magnify: real;                       { magnification factor }
      Viewtype: integer;                   { code for viewing type: }
                                           { 0=perspective, 1=XY, 2=XZ, 3=YZ }
      Fileread: boolean;                   { flag first file read }
      Nmatl: integer;                      { number of materials }
      Nsides: integer;                     { #sides of surface used (1 or 2)}
      Interpolate: boolean;                { flag for Gouraud interpolation }
      Epsilon: real;                       { Gouraud interpolation range }
      Shadowing: boolean;                  { flag shadowing option }
      Filemask: text80;                    { mask for naming data files }
      Inifile: text80;                     { name of INI file }
      Grfcmmdfile: text80;
      XYadjust: real;                      { factor for screen width }
      Showaxes: integer;                   { code to show (0) no axes; (1) }
                                           { axis directions; (2) full axes }
      Xaxislen,Yaxislen,Zaxislen: real;    { lengths of axes }
      Axiscolor: integer;                  { color to draw axes }
      Nwindow: integer;                    { # graphics windows on screen }
      Xfotran, Yfotran, Zfotran: real;     { transformed focal point }
      XYmax: real;                         { limits of transformed coords }
      memerr : boolean;                    { True if a memory error occured }
      ShowAllBorders: integer;             { code to (1) show surface borders}
                                           { in shaded plots or (0) not }
      Zmin,Zmax: real;                     { min & max Z coords }

      curmat: integer;                     { current matl in playpal }
      curcol: prim_color;                  { current color being changed }
      Lastplot: integer;
{$ifdef DEBUG}
      Dbgfile: text;                       { debugging file }
{$endif}

{ An important function for decoding the Connect array: }

function KONNEC (Surf, Vert: integer): integer;
{ Decode the Connect array to yield the connection data: Vertex Vert of
surface Surf. This function returns an index to the global Xtran, Ytran,
and Ztran arrays (i.e., a node number) }
begin
  Konnec := Connect[(Surf-1) * Maxvert + Vert];
end; { function KONNEC }

{ Procedure include files }

{ Graphics Functions }
{$I COLORMOD.INC}         { COLORMOD }
{$I DITHER.INC  }         { Graphics Dithering functions }
{$I OPENWIN.INC }         { procedure BRIGHT, OPENWIN }
{$I MENUMSG.INC }         { procedure MENUMSG }

{ Math routines and number input routines}
{$I ARCCOS.INC  }         { function  ARCCOS }
{$I MINMAX.INC }          { procedure MINMAX }
{$I GETKEY.INC  }         { function  GETKEY }
{$I CHKCMMD.INC }         { procedure CHKCMMD }
{$I INREAL.INC }          { procedure INREAL }
{$I GETONE.INC }          { functions GETONEREAL, GETONEINT }

{ startup routines }
{$I READCFG.INC }         { procedure READCFG }
{$I INITIAL.INC }         { procedure INITIAL }

{ Modeling Functions }
{$I ONSCREEN.INC }        { function  ONSCREEN }
{$I STORLINE.INC }        { procedure STORLINE }
{$I SWAPS.INC }           { procedure SWAPINT, SWAPREAL }
{$I SHELLPTS.INC }        { procedure SHELLPTS, SHELLSHADES }
{$I FILLSURF.INC }        { procedure BADSURF, FILLSURF }

{ Local variables for main }
var i: integer;
    mat: integer;
    surf: integer;
    node: integer;
    x: real;
    y: real;
    dx: real;
    dy: real;

{ put_rgb: Display the value of one of Red, Grn or Blu }
procedure put_rgb (var x: integer; y: integer; textstring: string;
  col: integer);
begin
  puttext (x, y, textstring, col);
  x := x + width_of_text (textstring);
end; { put_rgb }

{ fillrect: Draw a filled rectangle }
procedure fillrect (x1, y1, x2, y2, color: integer);
var bpts: array[1..5] of pointtype;
begin
  bpts[1].x := x1;
  bpts[1].y := y1;
  bpts[2].x := x2;
  bpts[2].y := y1;
  bpts[3].x := x2;
  bpts[3].y := y2;
  bpts[4].x := x1;
  bpts[4].y := y2;
  bpts[5].x := x1;
  bpts[5].y := y1;
  setcolor(color);
  setfillstyle (SolidFill, color);
  fillpoly (5, bpts);
end; { procedure fillrect }

{ refresh_text: Refresh the text for a single colorbar }
procedure refresh_text (mat: integer);
var surf: integer;
    node1: integer;
    x, y: integer;
    dx, dy: integer;
    temp: string[20];
    msg: string[80];
begin
  { Add text at end of line (RGB value) }

  surf := (mat-1) * NSURF_MAT + 1;
  node1 := konnec (surf, 1);
  y := round (Ytran[node1]);
  x := round (0.675 * Gxmax);

  { First clear out the old text (draw a black box) }
  dx := width_of_text ('(000,000,000)') - 1;
  dy := height_of_text ('0');
  fillrect (x, y, x+dx, y+dy, 0);

  put_rgb (x, y, '(', CYAN);
  str (Redmax[mat], msg);
  if (mat = curmat) and (curcol = Red) then
    put_rgb (x, y, msg, GREEN)
  else
    put_rgb (x, y, msg, CYAN);

  put_rgb (x, y, ',', CYAN);
  str (Grnmax[mat], msg);
  if (mat = curmat) and (curcol = Grn) then
    put_rgb (x, y, msg, GREEN)
  else
    put_rgb (x, y, msg, CYAN);

  put_rgb (x, y, ',', CYAN);
  str (Blumax[mat], msg);
  if (mat = curmat) and (curcol = Blu) then
    put_rgb (x, y, msg, GREEN)
  else
    put_rgb (x, y, msg, CYAN);

  put_rgb (x, y, ')', CYAN);

end; { refresh_text }

{ refresh_bars: Refresh the entire color bar display }
procedure refresh_bars (Full_refresh: boolean);
var surf: integer;
    mat: integer;
    i: integer;
    shade: real;
begin
  if Full_refresh then
    { Clear the window }
    setgmode(Nmatl)
  else
    { Just redefine the graphics palette }
    def_palette (Nmatl);
  for mat := 1 to Nmatl do begin
    if (Full_refresh) or (Matchanged[mat]) then begin
      surf := (mat-1) * NSURF_MAT + 1;
      shade := 0;
      for i := 1 to NSURF_MAT do begin
        fillsurf (surf, mat, shade);
        surf := surf + 1;
        shade := shade + 1.0/(NSURF_MAT-1.0);
      end;
      refresh_text (mat);
    end;
    Matchanged[mat] := FALSE;
  end;
end; { refresh_bars }

{ palhelp: Provide help on the use of playpal }
procedure palhelp (Cmmdline: boolean);
var c: char;
begin
  if (not Cmmdline) then begin
    { Switch back to text mode }
    exgraphic;
    clrscr;
  end;
  writeln('                        PLAYPAL COMMANDS:');
  writeln(' ');
  writeln('  UP,DOWN        SELECT NEXT MATERIAL');
  writeln('  TAB            SELECT NEXT COLOR (R, G, OR B)');
  writeln('  LEFT,RIGHT     LOWER, RAISE CURRENT COLOR VALUE');
  writeln('  HOME           SET CURRENT COLOR VALUE TO 1');
  writeln('  END            SET CURRENT COLOR VALUE TO 256');
  writeln('  ENTER          REFRESH COLOR BAR DISPLAY');
  writeln('  I              TOGGLE INCREMENT BETWEEN 16 (DEFAULT) AND 1');
  writeln('  S              SUGGEST NEW RGB VALUES');
  writeln('  Q              QUIT');
  writeln('  F1             HELP (THIS SCREEN)');
  writeln;

  if (not Cmmdline) then begin
    writeln('  (Press any key to continue)');
    repeat until keypressed;
    c := readkey;
    refresh_bars(TRUE);
  end;
end; { procedure palhelp }

{ update_color: Increment or decrement the current color value of the
  current material.
}
procedure update_color (delta: integer);
begin
  Matchanged[curmat] := TRUE;
  case curcol of
    Red: begin
      Redmax[Curmat] := Redmax[Curmat] + delta;
      if Redmax[Curmat] < 1 then
        Redmax[Curmat] := 1;
      if Redmax[Curmat] > 256 then
        Redmax[Curmat] := 256;
      { Note there is one special case: If we are incrementing from 1
        with a step of 16, then we want the result to be 16 instead of
        17 (so we can stay with multiples of 16).
      }
      if (Redmax[Curmat] = 17) and (delta = 16) then
        Redmax[Curmat] := 16;
    end;
    Grn: begin
      Grnmax[Curmat] := Grnmax[Curmat] + delta;
      if Grnmax[Curmat] < 1 then
        Grnmax[Curmat] := 1;
      if Grnmax[Curmat] > 256 then
        Grnmax[Curmat] := 256;
      if (Grnmax[Curmat] = 17) and (delta = 16) then
        Grnmax[Curmat] := 16;
    end;
    Blu: begin
      Blumax[Curmat] := Blumax[Curmat] + delta;
      if Blumax[Curmat] < 1 then
        Blumax[Curmat] := 1;
      if Blumax[Curmat] > 256 then
        Blumax[Curmat] := 256;
      if (Blumax[Curmat] = 17) and (delta = 16) then
        Blumax[Curmat] := 16;
    end;
  end; { case curcol }
end; { procedure update_color }

{ suggestRGB: Find a new RGB value that is within 10% of the current one
  that has a larger common denominator (to increase the number of pure
  RGB colors).  This is probably somewhat more complex than it needs to be.
}
procedure suggestRGB (Redmax, Grnmax, Blumax: integer);
var RGratio, GBratio, RBratio: real;
    SugRed, SugGrn, SugBlu: real;
    fact: integer;
    Tred, Tgrn, Tblu: integer;
    n: integer;
    fact2: integer;
    RGnew, GBnew, RBnew: real;
    tmp: string[20];
    msg: string[80];
    x, y, dx, dy: integer;
label DONE;
begin

  RGratio := Redmax / Grnmax;
  GBratio := Grnmax / Blumax;
  RBratio := Redmax / Blumax;
  fact := 32;

  repeat
    fact2 := fact div 2;
    { Pick a new RGB that is a multiple of fact }
    n := (Redmax + fact2) div fact;
    Tred := n * fact;
    if Tred < 1 then
      Tred := 1;
    if Tred > 256 then
      Tred := 256;
    n := (Grnmax + fact2) div fact;
    Tgrn := n * fact;
    if Tgrn < 1 then
      Tgrn := 1;
    if Tgrn > 256 then
      Tgrn := 256;
    n := (Blumax + fact2) div fact;
    Tblu := n * fact;
    if Tblu < 1 then
      Tblu := 1;
    if Tblu > 256 then
      Tblu := 256;

    { Use only if it is within SugTol percent of original RGB ratios }
    RGnew := Tred / Tgrn;
    GBnew := Tgrn / Tblu;
    RBnew := Tred / Tblu;
    if (abs (RGnew - RGratio)/RGratio < SugTol) and
       (abs (GBnew - GBratio)/GBratio < SugTol) and
       (abs (RBnew - RBratio)/RBratio < SugTol) then begin
      SugRed := Tred;
      SugGrn := Tgrn;
      SugBlu := Tblu;
      goto DONE;
    end;
    fact := fact2;

  until (fact < 2);

  { No suggested colors within tolerance - return originals }
  SugRed := Redmax;
  SugGrn := Grnmax;
  SugBlu := Blumax;

DONE:
  { First clear out the old text (draw a black box) }
  x := round (Gxmax * 0.025);
  y := round (gymax * 0.9);
  dx := width_of_text ('Suggest: RED=000 GREEN=000 BLUE=000');
  dy := height_of_text ('0');
  fillrect (x, y, x+dx, y+dy, 0);

  { Now show the user what we found }
  str (SugRed:3:0, tmp);
  msg := 'Suggest: RED=' + tmp;
  str (SugGrn:3:0, tmp);
  msg := msg + ' GREEN=' + tmp;
  str (SugBlu:3:0, tmp);
  msg := msg + ' BLUE=' + tmp;
  puttext (x, y, msg, GREEN);

end; { procedure SuggestRGB }

{ colorbars: Interactive color bar update procedure }
procedure colorbars;
var c: char;
    Color_Increment: integer;
begin
  curmat := 1;
  curcol := Red;
  Color_Increment := 16;
  refresh_bars(TRUE);

  { Interactive loop }
  repeat
    c := upcase (readkey);
    if c = chr(0) then begin
      { Pressed function or arrow key - get second value }
      c := readkey;
      case c of
        ';':          { F1 }
          palhelp (FALSE);
        'H': begin    { Up arrow }
          if curmat > 1 then begin
            curmat := curmat - 1;
            refresh_text (curmat+1);
            refresh_text (curmat);
          end;
        end;
        'P': begin    { Down arrow }
          if curmat < Nmatl then begin
            curmat := curmat + 1;
            refresh_text (curmat-1);
            refresh_text (curmat);
          end;
        end;
        'K': begin    { Left arrow }
          { Decrement current color value }
          update_color (-Color_Increment);
          refresh_text (curmat);
        end;
        'M': begin    { Right arrow }
          { Increment current color value }
          update_color (Color_Increment);
          refresh_text (curmat);
        end;
        'G': begin    { Home }
          { Set current color value to 1 }
          update_color (-256);
          refresh_text (curmat);
        end;
        'O': begin    { End }
          { Set current color value to 256 }
          update_color (256);
          refresh_text (curmat);
        end;
        else
          write (^G)
      end; { case c of }
    end else begin
      { Evaluate normal keypress }
      case c of
        chr(9): begin { Tab }
          if curcol = Red then
            curcol := Grn
          else if curcol = Grn then
            curcol := Blu
          else
            curcol := Red;
          refresh_text (curmat);
        end;
        chr(13): begin { Enter }
          refresh_bars(FALSE);
        end;
        'I': begin
          if Color_Increment = 16 then
            Color_Increment := 1
          else
            Color_Increment := 16;
        end;
        'P': begin
          { Hidden command to update palette without full refresh }
          def_palette (Nmatl);
        end;
        'S': begin
          SuggestRGB (Redmax[curmat], Grnmax[curmat], Blumax[curmat]);
        end;
        'Q': begin
          { Quit - Update files }
        end;
        else
          write (^G)
      end; { case c of }
    end; { if c = chr(0) }
  until (c = 'Q');
end; { colorbars }


begin  { main }

  if (paramcount > 0) then begin
    { Any parameter triggers help. }
    writeln ('usage: PLAYPAL [help]');
    writeln ('  (Any command-line parameter brings up this help display;');
    writeln ('  just type PLAYPAL to start the program.');
    palhelp (TRUE);
    halt;
  end;

  initial;

  { Enter graphics mode }
  { setgmode (1); }

  { Initializations for drawing boxes: 8 materials, NSURF_MAT surfaces each. }
  Fileread := true;
  Nsides := 1;
  Interpolate := true;
  Magnify := 1.0;
  ViewType := 1;
  Maxvert := 4;
  Flpurpose := 'VGA Palette Selector (F1 For Help)';
  Mono := FALSE;

  Nmatl := 8;
  surf := 1;
  node := 1;
  dx := (gxmax * 0.62) / NSURF_MAT;
  dy := gymax / (Nmatl * 3.75);
  y := 4*dy;
  for mat := 1 to Nmatl do begin
    Matchanged[mat] := TRUE;
    { Set initial RGB values according to the standard DOS color #'s }
    color_to_RGB (mat, Redmax[mat], Grnmax[mat], Blumax[mat]);
    Color[mat]  := mat;     { for non-VGA users only }
    { Shouldn't need rest of the material constants }

    { Each material gets NSURF_MAT surfaces }
    x := dx;
    { First set the leftmost 2 nodes }
    Xtran[node] := x;
    Ytran[node] := y;
    Xtran[node+1] := x;
    Ytran[node+1] := y+dy;
    node := node + 2;
    x := x + dx;

    for i := 1 to NSURF_MAT do begin
      { Create 2 new nodes }
      Xtran[node] := x;
      Ytran[node] := y;
      Xtran[node+1] := x;
      Ytran[node+1] := y+dy;
      node := node + 2;
      x := x + dx;
      { Form a surface by connecting this column of nodes to the prev one }
      Nvert[surf] := 4;
      Matl[surf] := mat;
      Connect[(surf-1)*Maxvert+1] := node-4;
      Connect[(surf-1)*Maxvert+2] := node-3;
      Connect[(surf-1)*Maxvert+3] := node-1;
      Connect[(surf-1)*Maxvert+4] := node-2;
      surf := surf + 1;
    end; { for i }

    y := y + 3 * dy;

  end; { for mat }

  Nsurf := surf-1;
  Nnodes := node-1;
  if (Nsurf <> NSURF_MAT * Nmatl) or (Nnodes <> (NSURF_MAT*2+2) * Nmatl)
      then begin
    { exgraphic; }
    clrscr;
    writeln('Error: Nsurf=', Nsurf, ' Nnodes=', Nnodes);
    halt;
  end;

  { Done with the setup - Here is the main function call }
  colorbars;

  { Exit graphics mode }
  exgraphic;
  window (1,1,80,25);
  clrscr;

end. { program PLAYPAL }