ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/ITPAUG90.ZIP/GRPIX.PAS

Pascal/Delphi Source File | 1990-06-20 | 9.9 KB | 436 lines

PROGRAM GrPix;

USES Dos,GRAPH, Crt;

{* This program demonstrates some Turbo Pascal
 * graphics pixel manipulation functions.
 *
 * It requires the TP BGI drivers in the current
 * directory or an environment variable, BGI,
 * that points to it, e.g.:
 *
 * BGI=D:\TP\BGI
 *
 *}

CONST
  MaxLogoRows = 9;
  MaxLogoCols = 42;
TYPE
  BitMapType = ARRAY[1..MaxLogoRows] OF
                              String[MaxLogoCols];
CONST
  CobbLogoPixelMap : BitMapType =
    ('00FFFF000F000FFFF000F00FFFFF000F00FFFFF000',
     '0FFFFFF00F00FFFFFF00F00FF00FF00F00FF00FF00',
     '0FF00FF00F00FF00FF00F00FF00FF00F00FF00FF00',
     '0FF000000F00FF00FF00F00FFFFFF00F00FFFFFF00',
     '0FF000000F00FF00FF00F00FFFFF000F00FFFFF000',
     '0FF000000F00FF00FF00F00FF00FF00F00FF00FF00',
     '0FF00FF00F00FF00FF00F00FF00FF00F00FF00FF00',
     '0FFFFFF00F00FFFFFF00F00FFFFFF00F00FFFFFF00',
     '00FFFF000F000FFFF000F00FFFFF000F00FFFFF000');

CONST
  BLACKRECTSTARTCOL = 100;
  BLACKRECTSTARTROW = 100;
  BLACKRECTENDCOL   = 109;
  BLACKRECTENDROW   = 210;

  BLUERECTSTARTCOL  = (BLACKRECTSTARTCOL-2);
  BLUERECTSTARTROW  = (BLACKRECTSTARTROW-2);
  BLUERECTENDCOL    = (BLACKRECTENDCOL + 2 + 33);
  BLUERECTENDROW    = (BLACKRECTENDROW+2);

  WHITERECTSTARTCOL = BLACKRECTSTARTCOL;
  WHITERECTSTARTROW = BLACKRECTSTARTROW;
  WHITERECTENDCOL   = (BLACKRECTENDCOL + 33);
  WHITERECTENDROW   = BLACKRECTENDROW;

VAR
  MaxX, MaxY, MaxColor: Integer;
  MaxPix,QuarterPix   : Longint;

FUNCTION BlackRectOffset(N: Integer): Integer;
BEGIN
  BlackRectOffset := N * 11
END;

    { displays error #, message and exits  }

PROCEDURE ErrorExit(ErrCode: Integer;
                    Message: String);
BEGIN
  WriteLn('Error ',ErrCode:3,' returned from ',
                                      Message);
  Halt
END;

    { graphics compatible message function     }

PROCEDURE GrMessage(Message: String);
BEGIN
  Bar(0,GetMaxY-(TextHeight(Message)*2),
      TextWidth(Message),
      GetMaxY-(TextHeight(Message)));

  { write message                        }

  OutTextXY(0,GetMaxY-(TextHeight(Message)*2),
            Message);
END;

PROCEDURE Pause;
VAR
  TempStr : String;
  A       : Char;
BEGIN
  TempStr := 'Press any key to continue...';
  GrMessage(TempStr);
  WHILE NOT KeyPressed DO; A:= ReadKey;
  GrMessage('                            ')
END;

    { randomly draws randomly colored pixels   }

PROCEDURE DrawRandomlyColoredPixels;
VAR
  Color, X, Y: Word;
  L          : Longint;

BEGIN

  { for 1/4 of the pixels on screen    }

  FOR L := 1 TO QuarterPix DO BEGIN

    { get coordinates and color        }

    X := Random(MaxX + 1);
    Y := Random(MaxY + 1);
    Color := Random(MaxColor + 1);

    { write pixel                      }

    PutPixel(X,Y,Color);
    IF KeyPressed THEN Exit
    END
END;

    { fills screen with each color             }

PROCEDURE FillScreenWithColoredPixels;
VAR
  Color, X, Y : Word;
  M, N        : Longint;

BEGIN
  N := MaxPix DIV MaxColor;

        { for each color available     }

  X := 0;
  Y := 0;

  FOR Color := 1 TO MaxColor DO BEGIN
    FOR M := 1 TO N DO BEGIN
              { write the pixel          }
      PutPixel(X,Y,Color);
      Inc(X);    { next column          }
      { if last column, reset, next row  }
      IF (X > MaxX) THEN BEGIN
        X := 0;
        Inc(Y)    {temp}
        END;
            { if on last line, break           }
      IF (Y > MaxY) THEN Exit;
      IF KeyPressed THEN Exit;
      END;
    IF KeyPressed THEN Exit;
    END;
END;

    { draws line from coordinates              }

PROCEDURE DrawColoredLine(Fx, Fy, Tx, Ty: Word);

VAR
  Pixel,I,J,K,L:  Word;
  Up           :  Boolean;

BEGIN

  Up := FALSE;

        { if drawing -> \ or / }

  IF Tx >= Fx THEN BEGIN
    I := Fx;
    K := Tx;
    J := Fy;
    L := Ty;
    IF Ty < Fy THEN Up := TRUE  { drawing /    }
    END
  ELSE BEGIN        { else drawing <- \ or /   }
    I := Tx;
    K := Fx;
    J := Ty;
    L := Fy;
    IF Ty > Fy THEN Up := TRUE   { drawing /    }
    END;

  WHILE TRUE DO BEGIN

            { get the pixel    }

    Pixel := GetPixel(I,J);

            { adjust color     }

    IF Pixel > 7 THEN
      Dec(Pixel,6)
    ELSE
      Inc(Pixel,7);

           { write pixel      }

    PutPixel(I,J,Pixel);

    { increment (decrement) if needed }

    IF J <> L THEN
      IF Up THEN
        Dec(J)
      ELSE
        Inc(J);
    IF I <> K THEN
      Inc(I);

    { when to and from are equal   }

    IF (J = L) AND (I = K) THEN Exit
    END
END;

    { draws lines from center pixel            }

PROCEDURE DrawLinesFromCenter;
VAR
  CenterX, CenterY:  Integer;
BEGIN
    CenterX := MaxX DIV 2; CenterY := MaxY DIV 2;

    DrawColoredLine(centerx-100,centery-100,
            CenterX,CenterY);
    DrawColoredLine(CenterX,centery-100,
            CenterX,CenterY);
    DrawColoredLine(CenterX+100,centery-100,
            CenterX,CenterY);
    DrawColoredLine(centerx-100,CenterY,
            CenterX,CenterY);
    DrawColoredLine(CenterX+100,CenterY,
            CenterX,CenterY);
    DrawColoredLine(centerx-100,CenterY+100,
            CenterX,CenterY);
    DrawColoredLine(CenterX,CenterY+100,
            CenterX,CenterY);
    DrawColoredLine(CenterX+100,CenterY+100,
            CenterX,CenterY);
END;

    { concentric squares from center pixel     }

PROCEDURE ExplodingFilledSquare(radius,Color:
                                          Word);
VAR
  CenterX, CenterY, I, J: Word;

BEGIN

  CenterX := MaxX DIV 2; CenterY := MaxY DIV 2;

        { write center pixel   }

  PutPixel(CenterX,CenterY,Color);

        { for each square      }

  FOR I := 0 TO Radius-1 DO BEGIN
            { write top line       }
    FOR J := centerx-i TO CenterX+i-1 DO
      PutPixel(J,centery-i,Color);
            { write sides          }
    FOR J := centery-i TO CenterY+i-1 DO BEGIN
      PutPixel(centerx-i,J,Color);
      PutPixel(CenterX+I,J,Color)
      END;
           { write bottom         }
    FOR J := centerx-i TO CenterX+I DO
      PutPixel(J,CenterY+I,Color);
    IF KeyPressed THEN Exit
    END
END;

    { randomly fills display with pixels       }

PROCEDURE decay(numpix: Longint; Color: Word);
VAR
  L: Longint;
  X, Y: Word;
BEGIN
  FOR L := 1 TO numpix DO BEGIN
          { get coordinates          }
    X := Random(MaxX+1);
    Y := Random(MaxY+1);
          { write 4 pixels of color  }
    PutPixel(X,Y,Color);
    PutPixel(X+1,Y,Color);
    PutPixel(X,Y+1,Color);
    PutPixel(X+1,Y+1,Color);
    IF KeyPressed THEN Exit
    END
END;


    { draws filled rectangle in coordinates    }

PROCEDURE DrawFilledRectangle(startcol,
        startrow, endcol, endrow, Color: Word);
VAR
  I : Word;
BEGIN
  WHILE (startrow <= endrow) DO BEGIN
    FOR I := startcol TO endcol DO
      PutPixel(I,startrow,Color);
    Inc(startrow)
    END
END;

    { draws pixelmap at coordinates            }


PROCEDURE DrawPixelMap(startcol, startrow: Word;
                       BitMap: BitMapType);

FUNCTION AtoH(C: Char): Word;
BEGIN
  IF C > '9' THEN
    AtoH := Ord(C) - Ord('A') + 10
  ELSE
    AtoH := Ord(C) - Ord('0');
END;

VAR
  I, J: Word;
  P   : String;

BEGIN
        { for each pointer in the array    }

  FOR I := 1 TO MaxLogoRows DO BEGIN
    P := BitMap[I];
            { for each byte in the string      }
    FOR J := 1 TO MaxLogoCols DO
            { display the converted pixel      }
      PutPixel(startcol+J,startrow+I,AtoH(P[J]))
    END
END;

VAR
  GraphDriver,GraphMode : Integer;
  BgiPath               : String;
  ErrMsg                : String[80];

BEGIN
  { get BGI path if one }

  BgiPath := GetEnv('BGI');

  { initialize graphics System}

  GraphDriver := Detect;
  InitGraph(GraphDriver,GraphMode,BgiPath);

  IF(GraphDriver < 0) THEN BEGIN
    ErrMsg := 'InitGraph (' +
               GraphErrorMsg(GraphDriver) + ')';
    ErrorExit(GraphDriver,ErrMsg);
    END;

  { initialize random number generator }

  Randomize;

  { initialize global variables          }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  MaxColor := GetMaxColor;
  MaxPix := Longint(MaxX) * Longint(MaxY);

  QuarterPix := MaxPix DIV 4;

  SetColor(BLACK);

  DrawRandomlyColoredPixels;
  Pause;

  ClearDevice;
  FillScreenWithColoredPixels;
  Pause;

  DrawLinesFromCenter;
  Pause;

  ExplodingFilledSquare(50,BLACK);
  Pause;
  ExplodingFilledSquare(50,CYAN);
  Pause;

  decay((MaxPix DIV 12),BLACK);
  Pause;


      { draw COBB Group Logo:                }
      { first, the blue background           }

  DrawFilledRectangle(BLUERECTSTARTCOL,
          BLUERECTSTARTROW,BLUERECTENDCOL,
          BLUERECTENDROW,BLUE);

      { next, the white logo background      }
  DrawFilledRectangle(WHITERECTSTARTCOL,
          WHITERECTSTARTROW,WHITERECTENDCOL,
          WHITERECTENDROW,WHITE);

      { then, each black column              }

  DrawFilledRectangle(BLACKRECTSTARTCOL+
          BlackRectOffset(0),BLACKRECTSTARTROW,
          BLACKRECTENDCOL+BlackRectOffset(0),
          BLACKRECTENDROW,BLACK);

  DrawFilledRectangle(BLACKRECTSTARTCOL+
          BlackRectOffset(1),BLACKRECTSTARTROW,
          BLACKRECTENDCOL+BlackRectOffset(1),
          BLACKRECTENDROW,BLACK);
  DrawFilledRectangle(BLACKRECTSTARTCOL+
          BlackRectOffset(2),BLACKRECTSTARTROW,
          BLACKRECTENDCOL+BlackRectOffset(2),
          BLACKRECTENDROW,BLACK);

  DrawFilledRectangle(BLACKRECTSTARTCOL+
          BlackRectOffset(3),BLACKRECTSTARTROW,
          BLACKRECTENDCOL+BlackRectOffset(3),
          BLACKRECTENDROW,BLACK);

      { finally, the COBB pixelmap           }

  DrawPixelMap(100,103,CobbLogoPixelMap);

  Pause;

      { switch back to text mode, cleanup}
  CloseGraph;
END.