Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TPEGA.ZIP/KC-PAL.PAS

Pascal/Delphi Source File | 1986-02-01 | 7.9 KB | 314 lines

{                                                                              }
{   Program:     PAL, Version 01/20/86                                         }
{                                                                              }
{   Description: This program gives the user the ability to change the         }
{                palettes on the IBM's Enhanced Graphic Adapter.  This         }
{                program works much better with 'KCSETPAL.COM' see doc.        }
{                                                                              }
{   Author:      Kent Cedola                                                   }
{                2015 Meadow Lake Court, Norfolk VA, 23518. 1-(804)-857-0613   }
{                                                                              }
{   Language:    Turbo Pascal, V3.01A                                          }
{                                                                              }
{   Comments:    This program only includes the graphic routines needed to     }
{                save space and time for BBS's.  If you would like a complete  }
{                set of EGA graphic routines (FREE), please let me know.       }
{                                                                              }

{$K- }

{$I GPParms.p }
{$I GPInit.p  }
{$I GPTerm.p  }
{$I GPColor.p }
{$I GPMerge.p }
{$I GPPal.p   }
{$I GPRdPal.p }
{$I GPMOVE.P  }
{$I GPLine.p  }
{$I GPRect.p  }
{$I GPBox.p   }

const
  UP_ARROW    = #72;
  DOWN_ARROW  = #80;
  LEFT_ARROW  = #75;
  RIGHT_ARROW = #77;

var
  x,y,p,i: Integer;
  x1,y1:   Integer;

  ch   : Char;

  pal:   array [0..7] of array [0..1] of Byte;

procedure InitGraphics;
begin
  GPParms;                              { Sets up all global variables  }

  if GDTYPE = 4 then                    { Give monochrome user bad news }
    begin
      writeln('Sorry, must have a Color Display not monochrome!');
      halt(1);
    end
  else if GDTYPE <> 5 then              { Tell non-EGA users no can run }
    begin
      writeln('Enhanced Color Adapter and Display not found!');
      halt(2);
    end;

  if GDMEMORY = 64 then                 { We need lots of EGA memory    }
    begin
      writeln('This program will work much better with 128k+ EGA memory!');
      writeln('    Hit any key to continue!');
      Read(Kbd,Ch);
   end;

  GPInit;                               { We are now in graphic mode!   }

end;

procedure TermGraphics;
begin

  GPTerm;                               { Terminate graphic mode        }

end;

procedure TitlePage;
begin

  GPColor(Black);
  GPMOVE(0,0);
  GPBox(GDMAXCOL,GDMAXROW);

  TextColor(Cyan);
  gotoxy( 3, 2); write('KC-PAL 01/20/86');
  gotoxy(27, 2); write('Set the palettes of IBM''s EGA');
  gotoxy(68, 2); write('KC-GRAPHICS');

  for y := 0 to 1 do
    for x := 0 to 7 do
      begin
        GPColor(y*8+x);
        GPMOVE(x*72+32,139-y*61);
        GPBox(x*72+103,199-y*61);
        p := GPRdPal(y*8+x);
        if p = -1 then
          begin
            pal[x,y] := y * 56 + x;
            GPPal(y*8+x,y*56+x);
          end
        else
          pal[x,y] := p;
        GPColor(LightGray);
        gotoxy(x*9+7,16-y*11); write('C# ',pal[x,y]:2);
      end;

  GPColor(Green);
  GPMOVE(0,0);
  GPRect(639,349);
  GPMOVE(4,3);
  GPRect(635, 38);
  GPMOVE(4,41);
  GPRect(635,346);
  GPMOVE(31,77);
  GPRect(608,200);

  TextColor(LightGray);
  gotoxy(19,18);
  write('Palette Selected XX, Color XX, RGB = (X,X,X).');
  gotoxy(11,20);
  write('Use the arrow keys to select a palette.  Use +, -, R, G, B, or');
  gotoxy(07,21);
  write('numeric keys to change the current color. Hit the SPACE BAR to reset');
  gotoxy(07,22);
  write('the palettes to the their default values. Use the program KCSETPAL');
  gotoxy(07,23);
  write('to retain changes while using other programs. Hit the "ESC" key to');
  gotoxy(07,24);
  write('exit. Send comments (SASE) to 2015 Meadow Lake Ct., Norfolk VA 23518');

end;

procedure xoropt(X,Y: Integer);
var
  x1,y1: Integer;
begin
  x1 := x * 72 + 40;
  y1 := 210 - y * 154;

  GPColor(Green);
  GPMerge(3);
  GPMOVE(x1,y1);
  GPBox(x1+56,y1+14);
  GPmerge(0);
end;

procedure newcolor(x,y,c: Integer);
begin
  xoropt(x,y);

  TextColor(Cyan);
  gotoxy(x*9+10,16-y*11); write(c:2);
  gotoxy(46,18);          write(c:2);
  gotoxy(36,18);          write(y*8+x:2);

  gotoxy(57,18); write(((c shr 4) and 2) or ((c shr 2) and 1):1);
  gotoxy(59,18); write(((c shr 3) and 2) or ((c shr 1) and 1):1);
  gotoxy(61,18); write(((c shr 2) and 2) or (c and 1):1);

  GPPal(y*8+x,c);
  xoropt(x,y);

end;

begin { Main Line Code }

  InitGraphics;

  TitlePage;

  x := 0;
  y := 0;

  xoropt(x,y);
  newcolor(x,y,pal[x,y]);

  repeat
    GPColor(Green);

    Read(Kbd,Ch);

    if (Ch = #27) and keypressed then
      begin
      Read(Kbd,Ch);
      case Ch of
        UP_ARROW:
          begin
            xoropt(x,y);
            y := (y+1) mod 2;
            xoropt(x,y);
          end;

        LEFT_ARROW:
          begin
            xoropt(x,y);
            x := (x + 7) mod 8;
            xoropt(x,y);
          end;

        RIGHT_ARROW:
          begin
            xoropt(x,y);
            x := (x+1) mod 8;
            xoropt(x,y);
          end;

        DOWN_ARROW:
          begin
            xoropt(x,y);
            y := (y+1) mod 2;
            xoropt(x,y);
          end;
        end;
      end
    else
      begin
      case Ch of
        '0'..'9':
          begin
            pal[x,y] := (pal[x,y] * 10) mod 100 + (ord(ch) - ord('0'));
            if pal[x,y] > 63 then
              pal[x,y] := pal[x,y] mod 10;
          end;

        'R','r':
          begin
            i := (pal[x,y] shr 4 and 2 or pal[x,y] shr 2 and 1) + 1 and 3;
            pal[x,y] := pal[x,y] and $1B or i and 2 shl 4 or i and 1 shl 2;
          end;

        'G','g':
          begin
            i := (pal[x,y] shr 3 and 2 or pal[x,y] shr 1 and 1) + 1 and 3;
            pal[x,y] := pal[x,y] and $2D or i and 2 shl 3 or i and 1 shl 1;
          end;

        'B','b':
          begin
            i := (pal[x,y] shr 2 and 2 or pal[x,y] and 1 + 1) and 3;
            pal[x,y] := pal[x,y] and $36 or i and 2 shl 2 or i and 1;
          end;

        '+':
          begin
            pal[x,y] := (pal[x,y] + 1) mod 64;
          end;

        '-':
          begin
            pal[x,y] := (pal[x,y] + 63) mod 64;
          end;

        ' ':
          begin
            for y1 := 0 to 1 do
              for x1 := 0 to 7 do
                begin
                pal[x1,y1] := y1 * 56 + x1;
                if (x <> x1) or (y <> y1) then
                  begin
                  GPPal(y1*8+x1,y1*56+x1);
                  GPColor(LightGray);
                  gotoxy(x1*9+10,16-y1*11); write(pal[x1,y1]:2);
                  end;
                end;
          end;
        #27:
          begin

          end;
        else
          write(chr(7));
      end;
    end;
    newcolor(x,y,pal[x,y]);
  until Ch = #27;

  TermGraphics;

  i := 0;
  for y := 0 to 1 do
    for x := 0 to 7 do
      if pal[x,y] <> y*56+x then
        begin
        GPPal(y*8+x,pal[x,y]);
        i := i + 1;
        end;

  if i <> 0 then
    begin
    writeln('You can use the program "KCSETPAL" to set the palettes directly.');
    writeln;
    write('        KCSETPAL ');

    for y := 0 to 1 do
      for x := 0 to 7 do
        begin
        if pal[x,y] <> y*56+x then
          begin
          write(pal[x,y]);
          i := i - 1;
          end;
        if ((y <> 1) or (x <> 7)) and (i <> 0) then
          begin
          write(',');
          end;
        end;
    writeln; writeln;
    writeln('Put the above in your autoexec.bat file to set colors on boot!');
    end;
end.