Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/XGRAPH.ZIP/ZOO2.PAS

Pascal/Delphi Source File | 1987-03-09 | 16.4 KB | 483 lines

{ Graphics demo, it shows some the animal-curves generated between two  }
{ endpoints.                                                            }
{                                                                       }
{ Warning, This demo can have habit forming effects!, some programmers  }
{ have given up lots of useful hours to stare at the pretty patterns in }
{ the screen.                                                           }
{                                                                       }
{ Written by Abe Achkinazi on May 1986. Curve type "sines" thanks to    }
{ and idea by Roderick Young.                                           }
{ Modified to use Extended Graphics Routines in September 1986.         }
{                                                                       }
{ Permission to distribute, change, mutilate and learn from this        }
{ program is granted.                                                   }
{                                                                       }
program zoo(input,output);

{$I Xgraph.pas}

label ErrorExit;
const
  max_point = 60;                      { Controls the number of points }
                                        { per curve                     }

  x1 = 0; y1 = 1; x2 = 2; y2 = 3;       { constants used to access array }
                                        { 'points'                       }

type
  { Some the possible paths for the curves }
  curve_type = ( sines, sines2, random1, planar, square1, general );

  { Common data structure for all animal-curves }
  list_type = record
                { Reseed constant }
                reseed : integer;

                { Time slice variables }
                slice_const, slice_counter : integer;

                { Window descriptor }
                top_x, top_y, length, width : integer;

                { Maintain track of previous points }
                points : array [0..3, 0..max_point] of integer;
                last_point : integer;
                start : integer;

                { curve related parameters }
                case what_path: curve_type of
                  sines, sines2
                          : ( omega : array [0..3] of real;
                            increment, delta_increment : real );
                  random1 : ( x1_temp, y1_temp, x2_temp, y2_temp,
                              rx1, ry1, rx2, ry2: real );
                  planar  : ( steps : integer;
                              x, y, px1, py1, dx1, dy1, px2, py2,
                              dx2, dy2 : integer;
                              border : integer );
                  square1 : ( sq1_steps : integer );
                  general : ( parms : array [0..5] of real )
              end;

var
  GrfData : GraphicsData;
  Regs : VidRegs;
  BlitParms : BlitParm;
  { Actual curves variables }
  list, list2, list3, list4, list5 : list_type;

  { Frame buffer size variables }
  OneThird, OneHalf, TwoThird : integer;

  ScreenMode : integer;

function GetMode(var ScreenMode: integer):boolean;
{
        Function to check if a parameter was passed and if its valid.
}
var
  Code : integer;
begin
  if (ParamCount < 1) or (ParamCount > 1) then GetMode := false
  else begin { At least has some parameter see if its legal }
    Val(ParamSTR(1), ScreenMode, Code);
    if Code <> 0 then GetMode := false
    else if ScreenMode in [Video320x200BW, Video320x200Color, Video640x200,
       VideoEGA320x200, VideoEGA640x200, VideoEGA640x350Mono, VideoEGA640x350Color,
       VideoMulti640x400, VideoMulti320x400]
    then GetMode := true
    else GetMode := false;
  end;
end; { of GetMode }

function previous_point( i, last_point : integer ): integer;
begin
  if i = 0 then previous_point := last_point;
end;

function next_point(i, last_point : integer ): integer;
begin
  next_point := (i+1) mod (last_point+1);
end;

procedure draw_border(list : list_type);
begin
  with list, Regs do begin
    ax:=VidLine shl 8 + $78 { white solid line };
    cx:=top_x; dx:=top_y; si:=top_x + width; di:=top_y;
    Intr(VideoInt, Regs);

    cx:=top_x + width; dx:=top_y; si:=top_x + width;
    di:=top_y + length; Intr(VideoInt, Regs);

    cx:=top_x + width; dx:=top_y + length; si:=top_x;
    di:=top_y + length; Intr(VideoInt, Regs);

    cx:=top_x; dx:=top_y + length; si:=top_x; di:=top_y;
    Intr(VideoInt, Regs);
  end;
end;

procedure clear_window(list : list_type);
begin
  with list, BlitParms do begin
    { Clear the currently selected window }
    Regs.ax := VidBlit shl 8; Regs.bx := $000F;
    Regs.ds := seg(BlitParms); Regs.si := ofs(BlitParms);
    DestOffset := ofs(GrfData); DestSegment := seg(GrfData);
    SrcOffset := ofs(GrfData); SrcSegment := seg(GrfData);
    RectOrigenX := top_x*GrfData.BitPixelDensity; RectOrigenY := top_y;
    RectCornerX := (top_x+width)*GrfData.BitPixelDensity;
        RectCornerY := top_y+length;
    PointX := RectOrigenX; PointY := RectOrigenY;
    Opcode := Blit0; TextOp := TextS;
{ Inline($CC); }
    Intr(VideoInt, Regs);
  end;
end;

procedure draw_line( list: list_type );
var i,j,k : integer;
begin
  with list, Regs do begin
    case what_path of
      sines, planar, square1: begin
        i := next_point(start, last_point); { Calculate next line to be used }

        { Erase the last line in the list }
        ax:=VidLine shl 8+$7F {Back Solid Line };
        cx:=points[x1,i]; dx:=points[y1,i]; si:=points[x2,i]; di:=points[y2,i];
        Intr(VideoInt, Regs);

        { draw the current line }
        { Pick color and pattern base on table pos.}
        ax:=VidLine shl 8+(Start mod 15+1)*8+(Start mod 7);
        cx:=points[x1,start]; dx:=points[y1,start]; si:=points[x2,start];
        di:=points[y2,start]; Intr(VideoInt, Regs); end;

      sines2 : begin
        i := next_point(start, last_point);
        k := next_point(i, last_point);
        j := previous_point(start, last_point);
        ax:=VidLine shl 8+(i mod 15+1)*8 { Pick color base on table pos.};
        cx:=points[x1,i]; dx:=points[y1,i]; si:=points[x1,k];
        di:=points[y1,k]; Intr(VideoInt, Regs);
        cx:=points[x2,i]; dx:=points[y2,i]; si:=points[x2,k];
        di:=points[y2,k]; Intr(VideoInt, Regs);
      end;

      random1: begin
        i := next_point(start, last_point); { Calculate next line to be used }

        { Erase the last line in the list }
        ax:=VidLine shl 8+$7F {Back Solid Line };
        cx:=points[x1,i]; dx:=points[y1,i]; si:=points[x2,i]; di:=points[y2,i];
        Intr(VideoInt, Regs);

        { draw the current line }
        { Pick color and pattern base on table pos.}
        ax:=VidLine shl 8+(Start mod 15+1)*8+(Start mod 7);
        cx:=points[x1,start]; dx:=points[y1,start]; si:=points[x2,start];
        di:=points[y2,start]; Intr(VideoInt, Regs); end

    end; { of what_curve case }
  end;
end;

{ Used by Random1 curve path, it reverses direction in the x-sense }
function oppx(border : integer; list : list_type): integer;
begin
  with list do case border of
    0, 2 : oppx := top_x + random(width);
    1    : oppx := top_x + random(width);
    3    : oppx := top_x + random(width)
  end;
end;

{ Used by Random1 curve path, it reverses direction in the y-sense }
function oppy(border : integer; list : list_type): integer;
begin
  with list do case border of
    0   : oppy := top_y + random(length);
    1,3 : oppy := top_y + random(length);
    2   : oppy := top_y + random(length);
  end;
end;

function adjx(var border : integer; list : list_type): integer;
begin
  with list do case border of
    0, 2: if random(2)=0 then begin
            border := 3;
            adjx := (top_x+1) + random(width-2); end
          else begin
            border := 1;
            adjx := (top_x+1) + random(width-2); end;
    1, 3: begin
            if random(2) = 0 then border := 2
                             else border := 0;
            adjx := (top_x+1) + random(width-2);
          end
  end;
end;

function adjy(border: integer; list: list_type): integer;
begin
    adjy := (list.top_y+1) + random(list.length-2);
end;

{ Calculates what is the next set of points for the curve path }
procedure calc (var list : list_type);
begin
  with list do begin
    case what_path of
      sines, sines2 : begin
        increment := increment + delta_increment;
        points[x1,start] :=
          (top_x+1) + round(((sin(omega[x1]*increment)+1.0) / 2.0) * (width-2));
        points[y1,start] :=
          (top_y+1) + round(((sin(omega[y1]*increment)+1.0) / 2.0) * (length-2));
        points[x2,start] :=
          (top_x+1) + round(((sin(omega[x2]*increment)+1.0) / 2.0) * (width-2));
        points[y2,start] :=
          (top_y+1) + round(((sin(omega[y2]*increment)+1.0) / 2.0) * (length-2));
      end;

      random1 : begin
        x1_temp := ((random * 2.0) - 1.0) / 10.0;
        y1_temp := ((random * 2.0) - 1.0) / 10.0;
        x2_temp := ((random * 2.0) - 1.0) / 10.0;
        y2_temp := ((random * 2.0) - 1.0) / 10.0;

        rx1 := rx1 + x1_temp;
        if rx1 > 1.0 then rx1 := 1.0
          else if rx1 < 0.0 then rx1 := 0.0;

        ry1 := ry1 + y1_temp;
        if ry1 > 1.0 then ry1 := 1.0
          else if ry1 < 0.0 then ry1 := 0.0;

        rx2 := rx2 - x2_temp;
        if rx2 > 1.0 then rx2 := 1.0
          else if rx2 < 0.0 then rx2 := 0.0;

        ry2 := ry2 - y2_temp;
        if ry2 > 1.0 then ry2 := 1.0
          else if ry2 < 0.0 then ry2 := 0.0;

        points[x1,start] := (top_x+1) + round(rx1 * (width-2));
        points[y1,start] := (top_y+1) + round(ry1 * (length-2));
        points[x2,start] := (top_x+1) + round(rx2 * (width-2));
        points[y2,start] := (top_y+1) + round(ry2 * (length-2));
      end;

      square1: begin end;

      planar: begin
        if steps = 0 then begin
          steps := 7 + random(5);
          x := px1; y := py1; px2 := px1; py2 := py1;
          dx2 := (oppx(border, list) - x) div steps;
          dy2 := (oppy(border, list) - y) div steps;
          dx1 := (adjx(border, list) - x) div steps;
          dy1 := (adjy(border, list) - y) div steps;
        end;
        px1 := px1 + dx1; py1 := py1 + dy1;
        px2 := px2 + dx2; py2 := py2 + dy2;
        points[x1,start] := px1; points[y1,start] := py1;
        points[x2,start] := px2; points[y2,start] := py2;
        steps := steps - 1;
      end
    end;
  end;
end;

{ Fills up the curve's queues with new points, and initializes all      }
{ other variables needed for this curve.                                }
procedure Seed( var list : list_type;
                dummy_x, dummy_y, wide, tall : integer;
                curve : curve_type );
var i : integer;
begin
  with list do begin
    { Initialize window }
    top_x := dummy_x; top_y := dummy_y; length := tall; width := wide;

    draw_border(list);

    { Initialize Path related parameters }
    what_path := curve;
    case what_path of
      sines, sines2: begin
               omega[x1] := Random;
               omega[y1] := Random;
               omega[x2] := Random;
               omega[y2] := Random;
               increment := 0; delta_increment := 0.2;
               last_point := 15 + random(5);
             end;
      random1: begin
                 rx1 := random; ry1 := random;
                 rx2 := random; ry2 := random;
                 last_point := 10 + random(5);
               end;
      square1: begin end;
      planar: begin
                border := random(4);
                px1 := top_x + random(width);
                py1 := top_y + random(length);
                last_point := 10 + random(15);
                steps := 0;
              end

    end; { of case curve }

    { Initialize point array }
    start := 0;
    for i := 0 to (last_point+1) do begin
      start := next_point(list.start,list.last_point);
      calc(list);
    end;

    { Initialize time slice variables }
    slice_const := 0;
    slice_counter := 0;

    reseed := 100 + random(200);

  end; { of with list }

end; { of Seed }

{ Performs one step of the given curve. It takes care of all            }
{ housekeeping issues such as adjusting curves timers and reseeding     }
{ if needed.                                                            }
procedure Step(var list: list_type);
begin
    list.slice_counter := list.slice_counter - 1;
    if list.slice_counter <= 0 then begin
      Calc(list);
      Draw_line(list);
      list.start := next_point(list.start, list.last_point);
      list.slice_counter := list.slice_const;
   end;
   list.reseed := list.reseed - 1;
   if list.reseed = 0 then begin
    clear_window(list);
    Seed(list, list.top_x, list.top_y, list.width, list.length, list.what_path);
   end;

end; { of Step }

function Trim( n :integer):integer;
{
    Function to guarantee that the result is always byte aligned on the
    right (always ends in bit 7).
}
begin
  if (n mod 8) <> 6 then Trim := (n div 8) * 8 - 2
    else Trim := n;
end;

function Clip( n : integer):integer;
{
    Function to gurantee that the result is always byte align on the
    left (always ends in bit 0).
}
begin
  if (n mod 8) <> 0 then Clip := (n div 8) * 8
    else Clip := n;
end;

begin
Regs.ax := VidSetMode shl 8 + 03; Intr(VideoInt, Regs); { Clear Screen in Alpha }

{ Check to make sure that video extensions are installed }
Regs.ax := VidID * 256; Regs.bx := 0; Intr(VideoInt, Regs);
if Regs.bx = 0 then begin
  Writeln('Extended Graphics functions not installed.');
  writeln('Hit return to exit');
  readln;
  goto ErrorExit;
end;

{ See if user passed legal parameter }
if not GetMode(ScreenMode) then begin
  writeln('Usage: Zoo2 x');
  writeln('where x is a legal graphics mode number from this list:');
  writeln;
  writeln(' 4) is CGA 320x200');
  writeln(' 5) CGA 320x200');
  writeln(' 6) CGA 640x200');
  writeln('13) EGA 320x200');
  writeln('14) EGA 640x200');
  writeln('15) EGA 640x350 Monochrome');
  writeln('16) EGA 640x350 Color');
  writeln('20) HP-Multimode 640x400');
  writeln('21) HP-Multimode 320x400');
  goto ErrorExit;
end;

{ introduction }
writeln(' There are an infinite number of pairs of points in a plane.');
writeln(' This programs shows some of the strange fauna that exists');
writeln(' based on the relationship between two points:');
writeln;
writeln('   Squiggle  - Seems to like to turn an twist in a smooth path.');
writeln;
writeln('   Lissajous - Ever seen the TV series "The Outer Limits" ?. Look');
writeln('               at the source code, the relation between Squiggle');
writeln('               and Lissajous is interesting.');
writeln;
writeln('   Planes    - Triangular planes turning this way and that ...');
writeln;
writeln('   Random    - What can I say, when all else fails go for the old');
writeln('               and faithfull random number generator.');
writeln;
writeln(' written by Abe Achkinazi, May 1 1986.');
writeln(' Updated to support color and multiple video adapters');
writeln(' on August 6, 1986. Squiggles is based on a program');
writeln(' written by Roderick Young.');
writeln;
writeln('Hit <return> to visit the ZOO and');
writeln(' <return> once more to leave it.');
readln;

GraphInit(GrfData, ScreenMode);

with GrfData do begin
  OneThird := (MaxX - MinX + 1) div 3;
  TwoThird := (MaxX - MinX + 1) div 3 + (MaxX - MinX + 1) mod 3;
  OneHalf  := (MaxY - MinY + 1) div 2;

  { Initialize the different animals. }
  Seed(list, Clip(MinX),               MinY,       Trim(OneThird-1), OneHalf-1, sines2);

  Seed(list2, Clip(OneThird),          MinY,       Trim(TwoThird-1), MaxY, sines);

  Seed(list3, Clip(OneThird+TwoThird), MinY,       Trim(OneThird-1), OneHalf-1, planar);

  Seed(list4, Clip(MinX),              OneHalf,    Trim(OneThird-1), OneHalf-1, random1);

  Seed(list5, Clip(OneThird+TwoThird), OneHalf,    Trim(OneThird-1), OneHalf-1, sines2);

  { Now go around and around given each a chance to perform }
  repeat
    Step(list);
    Step(list2);
    Step(list3);
    Step(list4);
    Step(list5);
  until KeyPressed;
end;

{ if using extended modes turn off same way }
if ScreenMode in [20, 21] then begin
  Regs.ax := VidExtendedFunctions shl 8+5; Regs.bx := 3 end
else
  Regs.ax := VidSetMode shl 8 + 3;
Intr(VideoInt, Regs);

ErrorExit:;     { Falls to here when there is an error }
end.