{*
 * @(#) art.pas - 2D graphic demonstration program.
 * (c) 1994 Ivan Maidanski <ivmai@chat.ru> http://ivmai.chat.ru
 * Freeware program source. All rights reserved.
 **
 * Language: Turbo Pascal
 * Tested with: Turbo Pascal v5.5
 * Last modified: 1994-08-09 16:45:00 GMT+04:00
 *}

program Art;

{
 To run this program you will need the following files:
  TURBO.EXE (or TPC.EXE)
  TURBO.TPL - The standard units
  GRAPH.TPU - The Graphics unit
  KEYBOARD.TPU - The Keyboard unit (non-standard)
  *.BGI - The graphics device drivers
  *.CHR - The graphics font files
  ART.HLP - The program help file
}

{ ART.HLP file content:

Art program
(c) 1994 Ivan Maidanski
<ivmai@chat.ru>
http://ivmai.chat.ru

This program is a
demonstration of the Borland
Graphics Interface (BGI) of
Turbo Pascal.
.

Program Directives:

/H : Use the highest reso-
lution mode (if possible),
/Gpath : Path of the graphics
files (*.BGI and *.CHR),
/Fname : Name of this file.

Hot Keys:

[BackSp] - Clear Picture,
[Tab] - Random Parameters,
[Enter] - Restore Parameters,
[Space] - Help (if posible).
[*] - Regenerate,
[Esc] - Exit,
[Ctrl-Break] - Quit.
.

Use Alphabet and Numeric
keys to control Parameters.
.

Other keys stop action.
.
.

There are the following
parameters:

 CurSave, CurDelta,
 CurShortX, CurShortY,
 CurCoord, CurColor,
 BackColor.
.

 1, 2, 3, 4, 5, 6, 7 -
 make them maximal;
 z, x, c, v, b, n, m -
 make them minimal;
 q, w, e, r, t, y, u -
 increase them;
 a, s, d, f, g, h, j -
 decrease them.
.

 !, @, #, $, %, ^, & -
 make them default.

 [Enter] -
 makes all
 parameters default.
}

{$B-,I-,O-,R-}
{$M 2048,0,65535}

uses
  Keyboard,
  Dos,
  Graph;

const {limits}
  MaxChange= 5;
  MaxLine= 4;
  MaxParam= 7;
  MaxSave= 255;
  MaxStr= 9;

const {messages}
  Msg1= 'Art.';
  Msg2= 'Program directives:';
  Msg3= ' /Gpath - Path to Graphics drivers';
  Msg4= ' /Fname - Name of Help file.';
  Msg5= ' /H - Use Highest resolution mode.';
  Msg6= ' Graphics error: ';
  Msg7= 'Press Space to help... Esc quits';
  Msg8= 'Hit any key,Space to Help,Esc to exit';
  Msg9= 'Press Space to see next page';
  Msg10= 'The End.';

type {complex}
  TColor= array[1..MaxLine] of Word;
  TCoord= array[1..4] of Word {X1,Y1,X2,Y2};
  TDelta= array[1..4] of ShortInt {X1,Y1,X2,Y2};
  TKey= array[1..MaxChange] of array[1..MaxParam] of Char
         {Maximum,Minimum,Inc,Dec,Default};
  TParam= array[1..MaxParam] of Byte
           {Memory,MaxDelta,ShortX,ShortY,IncD,IncC,BackColor};
  TSave= array[1..MaxSave] of TCoord;

const {typed}
  Keys: TKey= (('1','2','3','4','5','6','7'),
               ('Z','X','C','V','B','N','M'),
               ('Q','W','E','R','T','Y','U'),
               ('A','S','D','F','G','H','J'),
               ('!','@','#','$','%','^','&'));
  BParam: TParam= (80,6,50,50,70,16,3);
  MParam: TParam= (MaxSave,50,200,200,250,50,MaxColors);

var {global}
  Border: TCoord;
  Ch: Char;
  Color: TColor;
  Coord: TCoord;
  CurLine: Byte;
  Delta: TDelta;
  HelpFile: Text;
  Param: TParam;
  TestClear,
  TestHelp,
  TestPause: Boolean;
  Save: TSave;

procedure Hello;
 begin {Hello}
   WriteLn;
   WriteLn(Msg1);
   WriteLn(Msg2);
   WriteLn(Msg3);
   WriteLn(Msg4);
   WriteLn(Msg5)
 end {Hello};

procedure TestGraphError;
 var
   Res: Integer;
 begin {TestGraphError}
   Res:=GraphResult;
   if Res<GrOk
     then begin {then}
            Write(Msg6);
            WriteLn(GraphErrorMsg(Res));
            WriteLn(Msg10);
            Halt(1)
          end {then}
 end {TestGraphError};

function FindDirective(Name: Char): String;
 var
   N: Byte;
   Dir,
   S: String;
 begin {FindDirective}
   Dir:='';
   N:=0;
   while N<ParamCount
     do begin {while}
          Inc(N);
          S:=ParamStr(N);
          if(Length(S)>1) and (S[1]='/') and (UpCase(S[2])=Name)
            then begin {then}
                   Delete(S,1,2);
                   Dir:=Dir+S+' '
                 end {then}
        end {while};
   FindDirective:=Dir
 end {FindDirective};

function GetFileName(var Dir: String; Ext: ExtStr): String;
 var
   ExtAux,TempExt: ExtStr;
   Name,TempName: NameStr;
   P: Byte;
   Path,TempDir: DirStr;
   S: String;
 begin {GetFileName}
   P:=Pos(' ',Dir);
   S:='';
   if P>1
     then S:=Copy(Dir,1,P-1);
   Delete(Dir,1,P);
   FSplit(S,Path,Name,ExtAux);
   if Path=''
     then FSplit(ParamStr(0),Path,TempName,TempExt);
   if(Name='') and (Ext<>'')
     then FSplit(ParamStr(0),TempDir,Name,TempExt);
   if ExtAux=''
     then ExtAux:=Ext;
   GetFileName:=Path+Name+ExtAux
 end {GetFileName};

procedure InitGrDir;
 var
   Dir: String;
   Driver,
   Error,
   Mode: Integer;
 begin {InitGrDir}
   Dir:=FindDirective('G');
   Driver:=Detect;
   DetectGraph(Driver,Mode);
   TestGraphError;
   repeat
     Error:=Driver;
     Mode:=0;
     InitGraph(Error,Mode,GetFileName(Dir,''))
   until(Error=GrOk) or (Dir='');
   TestGraphError
 end {InitGrDir};
{$F+}
procedure BreakProc;
 begin {BreakProc}
   Ch:=QuitChar
 end {BreakProc};
{$F-}
procedure InitHiResDir;
 begin {InitHiResDir}
   if Length(FindDirective('H'))>0
     then SetGraphMode(GetMaxMode)
 end {InitHiResDir};

procedure InitHelpFile;
 var
   Dir: String;
 begin {InitHelpFile}
   Dir:=FindDirective('F');
   repeat
     Assign(HelpFile,GetFileName(Dir,'.HLP'));
     Reset(HelpFile);
     TestHelp:=IOResult=0
   until TestHelp or (Dir='')
 end {InitHelpFile};

procedure SetParam;
 var
   N: Byte;
 begin {SetParam}
   N:=MParam[1];
   while N>Param[1]
     do begin {while}
          Save[N,1]:=0;
          Dec(N)
        end {while};
   SetBkColor(Param[7]);
   Ch:=NullChar
 end {SetParam};

procedure RestoreParam;
 begin {RestoreParam}
   Param:=BParam;
   SetParam
 end {RestoreParam};

procedure RandomParam;
 var
   N: Byte;
 begin {RandomParam}
   N:=MaxParam;
   repeat
     Dec(N);
     Param[N]:=Random(MParam[N])
   until N<=1;
   SetParam
 end {RandomParam};

procedure ClearSave;
 begin {ClearSave}
   for CurLine:=MParam[1] downto 1
     do Save[CurLine,1]:=0
 end {ClearSave};

procedure InitVars;
 begin {InitVars}
   TestClear:=False;
   TestPause:=True;
   Border[1]:=1;
   Border[2]:=1;
   Border[3]:=GetMaxX-1;
   Border[4]:=GetMaxY-TextHeight('A')-15;
   Coord[1] :=(Border[1]+Border[3]) div 2;
   Coord[2] :=(Border[2]+Border[4]) div 2;
   Coord[3]:=Coord[1];
   Coord[4]:=Coord[2];
   SetColor(GetMaxColor);
   Randomize
 end {InitVars};

procedure SetNewDelta;
 var
   N: Byte;
   D: ShortInt;
 begin {SetNewDelta}
   D:=Param[2]+1;
   for N:=1 to 4
     do Delta[N]:=Random(D)-D div 2
 end {SetNewDelta};

procedure SetNewColor;
 var
   N: Byte;
 begin {SetNewColor}
   for N:=1 to MaxLine
     do Color[N]:=Random(GetMaxColor)+1
 end {SetNewColor};

procedure StatusLine(Msg: String);
 begin {StatusLine}
   SetColor(GetMaxColor);
   SetTextStyle(DefaultFont,HorizDir,1);
   SetTextJustify(CenterText,TopText);
   SetFillStyle(WideDotFill,4);
   Bar(Border[1],Border[4]+6,Border[3],GetMaxY-1);
   Rectangle(Border[1]-1,Border[4]+4,Border[3]+1,GetMaxY);
   OutTextXY(GetMaxX div 2,GetMaxY-TextHeight('A')-2,Msg)
 end {StatusLine};

procedure Init;
 begin {Init}
   Hello;
   InitGrDir;
   InitStatusKey;
   InitBreakProc;
   UserBreakProc:=BreakProc;
   InitHiResDir;
   InitHelpFile;
   RestoreParam;
   InitVars;
   ClearSave;
   SetNewDelta;
   SetNewColor;
   SetLineStyle(SolidLn,0,NormWidth);
   Rectangle(Border[1]-1,Border[2]-1,
             Border[3]+1,Border[4]+1);
   StatusLine(Msg7)
 end {Init};

procedure GetEvent;
 begin {GetEvent}
   if (Ch=NullChar) and KeyPressedFull
     then Ch:=GetCharKeyFull(ReadKeyFull)
 end {GetEvent};

procedure ChangeParam(N,M: Byte);
 begin {ChangeParam}
   case N of
     1: Param[M]:=MParam[M];
     2: Param[M]:=0;
     3: if Param[M]<MParam[M]
          then Inc(Param[M]);
     4: if Param[M]>0
          then Dec(Param[M]);
     5: Param[M]:=BParam[M]
   end {case};
   SetParam
 end {ChangeParam};

procedure TestParamKey;
 var
   I,
   J,
   SI,
   SJ: Byte;
 begin {TestParamKey}
   SI:=0;
   for I:=1 to MaxChange
     do for J:=1 to MaxParam
          do if UpCase(Ch)=Keys[I,J]
               then begin {then}
                      SI:=I;
                      SJ:=J
                    end {then};
   if SI>0
     then ChangeParam(SI,SJ)
 end {TestParamKey};

procedure DrawLine(Coord: TCoord; Color: TColor);
 begin {DrawLine}
   SetColor(Color[1]);
   Line(Border[1]+Coord[1],Border[2]+Coord[2],
        Border[1]+Coord[3],Border[2]+Coord[4]);
   SetColor(Color[2]);
   Line(Border[3]-Coord[1],Border[2]+Coord[2],
        Border[3]-Coord[3],Border[2]+Coord[4]);
   SetColor(Color[3]);
   Line(Border[1]+Coord[1],Border[4]-Coord[2],
        Border[1]+Coord[3],Border[4]-Coord[4]);
   SetColor(Color[4]);
   Line(Border[3]-Coord[1],Border[4]-Coord[2],
        Border[3]-Coord[3],Border[4]-Coord[4])
 end {DrawLine};

procedure AdjustDelta(N,Max: Byte);
 var
   Test: Integer;
 begin {AdjustDelta}
   Test:=Coord[N]+Delta[N];
   if(Test<=0) or (Test>=Border[Max])
     then Delta[N]:=-Delta[N]
     else Coord[N]:=Test
 end {AdjustDelta};

function NeedChange(N: Byte): Boolean;
 begin {NeedChange}
   NeedChange :=(MParam[N]>Param[N]) and (Random(Param[N])=0)
 end {NeedChange};

procedure ControlShort;
 begin {ControlShort}
   if NeedChange(3)
     then Coord[3] :=(Coord[1]+Coord[3]) div 2;
   if NeedChange(4)
     then Coord[4] :=(Coord[2]+Coord[4]) div 2
 end {ControlShort};

procedure EraseLine;
 var
   Color: TColor;
   N: Byte;
 begin {EraseLine}
   for N:=1 to MaxLine
     do Color[N]:=0;
   if Save[CurLine,1]>0
     then DrawLine(Save[CurLine],Color);
   Save[CurLine,1]:=0
 end {EraseLine};

procedure SaveLine;
 begin {SaveLine}
   Save[CurLine]:=Coord;
   if CurLine<Param[1]
     then Inc(CurLine)
     else CurLine:=1
 end {SaveLine};

procedure DoArt;
 begin {DoArt}
   if NeedChange(5)
     then SetNewDelta;
   if NeedChange(6)
     then SetNewColor;
   AdjustDelta(1,3);
   AdjustDelta(2,4);
   AdjustDelta(3,3);
   AdjustDelta(4,4);
   ControlShort;
   EraseLine;
   DrawLine(Coord,Color);
   TestClear:=True;
   TestPause:=True;
   SaveLine
 end {DoArt};

procedure Clear;
 var
   A,
   B,
   F,
   Y: Word;
 begin {Clear}
   if Ch=BackSpChar
     then Ch:=NullChar;
   F:=0;
   A:=4*Random(512)+1;
   B:=2*Random(1024)+1;
   SetColor(0);
   if TestClear
     then for Y:=Border[2] to Border[4]
            do begin {for}
                 repeat
                   F:=(A*F+B) mod 2048
                 until F<=Border[4]-Border[2];
                 Line(Border[1],F+Border[2],Border[3],F+Border[2])
               end {for};
   if TestClear
     then ClearSave;
   TestClear:=False
 end {Clear};

procedure FindFont;
 const
   Font: Word=0;
 var
   F,
   Size: Word;
 begin {FindFont}
   if Font=0
     then Font:=4;
   F:=Font;
   Dec(Font);
   SetTextStyle(F,0,0);
   if GraphResult<GrOk
     then F:=DefaultFont;
   Size:=2;
   if F=DefaultFont
     then Size:=1;
   if F=SmallFont
     then Size:=6;
   SetTextStyle(F,HorizDir,Size);
   SetTextJustify(CenterText,TopText)
 end {FindFont};

procedure WriteTextHelp(var P: Byte);
 var
   C: Word;
   Msg: String;
 begin {WriteTextHelp}
   ReadLn(HelpFile,Msg);
   if Msg<>''
     then TestClear:=True;
   C:=GetMaxColor;
   SetColor(C);
   if C>2
     then SetColor(Pred(C));
   OutTextXY((Border[1]+Border[3]) div 2,
             Border[2]+TextHeight('A')*P,Msg);
   Inc(P)
 end {WriteTextHelp};

procedure DrawAux;
 var
   Color,
   X,
   Y: Word;
 begin {DrawAux}
   Color:=GetMaxColor;
   if Color>1
     then Dec(Color);
   if Color>3
     then Dec(Color,4);
   SetColor(Color);
   X:=Save[CurLine,1];
   Y:=Save[CurLine,2];
   if X=0
     then begin {then}
            X:=Random(Border[3]-Border[1])+Border[1];
            Y:=Random(Border[4]-Border[2])+Border[2];
            Save[CurLine,1]:=X;
            Save[CurLine,2]:=Y;
            PutPixel(X,Y,Color)
          end {then}
     else begin {else}
            PutPixel(X,Y,0);
            Save[CurLine,1]:=0
          end {else};
   CurLine:=Random(MParam[1])+1
 end {DrawAux};

function WriteHelpPage: Boolean;
 var
   P: Byte;
 begin {WriteHelpPage}
   Ch:=NullChar;
   P:=0;
   FindFont;
   Clear;
   while(P<MaxStr) and not Eof(HelpFile)
     do WriteTextHelp(P);
   repeat
     DrawAux;
     GetEvent;
     TestParamKey
   until Ch>NullChar;
   WriteHelpPage:=Eof(HelpFile) or (Ch<>SpaceChar)
 end {WriteHelpPage};

procedure Help;
 begin {Help}
   if TestHelp
     then begin {then}
            StatusLine(Msg9);
            Reset(HelpFile);
            if IOResult=0
              then repeat
                   until WriteHelpPage;
            Close(HelpFile);
            if Ch<>QuitChar
              then Clear
          end {then};
   StatusLine(Msg7);
   if(Ch=ExitChar) or (Ch=SpaceChar)
     then Ch:=NullChar
 end {Help};

procedure Regenerate;
 var
   Last: Byte;
 begin {Regenerate}
   Ch:=NullChar;
   Last:=CurLine;
   TestClear:=False;
   repeat
     EraseLine;
     if CurLine<MParam[1]
       then Inc(CurLine)
       else CurLine:=1
   until CurLine=Last
 end {Regenerate};

procedure WaitToGo;
 begin {WaitToGo}
   StatusLine(Msg8);
   repeat
     GetEvent;
     TestParamKey
   until Ch>NullChar;
   StatusLine(Msg7)
 end {WaitToGo};

procedure Pause;
 begin {Pause}
   TestParamKey;
   if Ch>NullChar
     then begin {then}
            Ch:=NullChar;
            if TestClear and TestPause
              then WaitToGo;
            TestPause:=False
          end {then}
 end {Pause};

procedure DoEvent;
 begin {DoEvent}
   case Ch of
     NullChar: DoArt;
     QuitChar: ;
     BackSpChar: Clear;
     TabChar: RandomParam;
     EnterChar: RestoreParam;
     ExitChar: Ch:=QuitChar;
     SpaceChar: Help;
     StarChar: Regenerate
     else Pause
   end {case}
 end {DoEvent};

procedure Run;
 begin {Run}
   repeat
     GetEvent;
     DoEvent
   until Ch=QuitChar
 end {Run};

procedure Done;
 begin {Done}
   CloseGraph;
   RestoreCrtMode;
   DoneKeyboard;
   WriteLn(Msg10)
 end {Done};

begin {Main}
  Init;
  Run;
  Done
end {Main}.