Falcon 030 Power 2/F030_POWER2.iso/ST_STE/MAGS/MAGGIE22.ARJ/magg22st.msa/GOODIES/TEXTURES.ZIP/TEXTURES/PERLIN2.PAS

Pascal/Delphi Source File | 1997-01-08 | 6KB | 181 lines

PROGRAM Perlin;

{
  Example code to demonstrate artificial texture creation

  Steve Tattersall for (Maggie 22)

  Program and routines to implement noise and turbulence functions
  as described in Perlin (1985) See the article in this issue
  for more help

  This is purely an example: those wishing to develop a full texture
  system should think about storing values in the lattice in the range
  0 to 1 rather than as integer values, for example. Also the code is
  completely unoptimised to better show the algorithm used.

  email: [e-mail]
  smail: 6 Derwent Drive, Littleborough, Lancs OL15 0BT England

}

USES Dos, Crt, Graph;

CONST
   LatticeSize = 20;                      { Lattice size }

VAR

   x,y,                                 { FOR..NEXT type counters }
   Driver,Mode : Integer;               { used for graphics - ignore }

   Lattice : ARRAY [0..LatticeSize,0..LatticeSize,1..3] OF integer;


   { ------------------ Subprograms ----------------------------------}
   PROCEDURE Init_Lattice;
   VAR
      X, Y : integer;
   BEGIN
      FOR Y:= 0 TO LatticeSize-1 DO
         FOR X:= 0 TO LatticeSize-1 DO
         BEGIN
            Lattice [X,Y,1] := Random (256) - 128;
            Lattice [X,Y,2] := Random (256) - 128;
            Lattice [X,Y,3] := Random (256) - 128;
         END
   END;

   { ------------------------------------------------------------ }
   PROCEDURE Get_Lattice ( x,y : integer;
                           VAR value, xgrad, ygrad : real );
   BEGIN
      xgrad := Lattice [x MOD LatticeSize , y MOD LatticeSize, 1];
      ygrad := Lattice [x MOD LatticeSize , y MOD LatticeSize, 2];
      value := Lattice [x MOD LatticeSize , y MOD LatticeSize, 3];
   END;

   { ------------------------------------------------------------ }
   FUNCTION Interpolate_Cubic
               ( v0, v1, g0, g1, x : real ) : real;
   BEGIN
      Interpolate_Cubic := (-2*v1 + 2*v0 + g0 + g1 ) * x*x*x
                        +  (-2*g0 - g1 - 3*v0 + 3*v1) * x*x
                        +  (g0) * x
                        +  (v0)
   END;

   { ------------------------------------------------------------ }

   FUNCTION Interpolate_Square
               ( v0, v1, g0, g1, x : real ) : real;
   BEGIN
      Interpolate_Square := 3 * (-2*v1 + 2*v0 + g0 + g1 ) * x*x
                        +  2 * (-2*g0 - g1 - 3*v0 + 3*v1) * x
                        +  (g0)
   END;

   { ------------------------------------------------------------ }
   { This procedure interpolates both value and new gradient }
   PROCEDURE Interpolate1
                  ( VAR value1, value2, xgrad1, xgrad2,
                    ygrad1, ygrad2,
                    xfrac : real;
                VAR newvalue, newygrad : real );
   BEGIN
      newvalue := Interpolate_Cubic ( value1, value2, xgrad1, xgrad2, xfrac);
      newygrad := Interpolate_Cubic ( value1, value2, ygrad1, ygrad2, xfrac);
   END;
   { ------------------------------------------------------------ }
   { Interpolates the final value only. }
   PROCEDURE Interpolate2
                  ( VAR value1, value2,
                    ygrad1, ygrad2,
                    yfrac    : real;
                VAR newvalue : real );
   BEGIN
      newvalue := Interpolate_Cubic ( value1, value2, ygrad1, ygrad2, yfrac);
   END;

   { ------------------------------------------------------------ }
   FUNCTION Noise2D ( x, y : real ) : real;

   VAR
      value1, value2, value3, value4,
      xgrad1, xgrad2, xgrad3, xgrad4,
      ygrad1, ygrad2, ygrad3, ygrad4 : real;

      newvalue1, newvalue2,
      newygrad1, newygrad2 : real;
      finalvalue : real;

      xint, yint : integer;
      xfrac, yfrac : real;

   { Method:
      - Take the 4 corners' xgrad,ygrad and values.
      - Interpolate [x,y] to [x+1,y], giving new value and ygrad
      - Interpolate [x,y+1] to [x+1,y+1], giving same
      - Use two values and ygrads to calculate final value.
   }
   BEGIN
      xint := trunc (x); yint := trunc (y);
      xfrac := x - xint ; yfrac := y - yint;

      Get_Lattice ( xint,   yint,   value1, xgrad1, ygrad1 );
      Get_Lattice ( xint+1, yint,   value2, xgrad2, ygrad2 );
      Get_Lattice ( xint,   yint+1, value3, xgrad3, ygrad3 );
      Get_Lattice ( xint+1, yint+1, value4, xgrad4, ygrad4 );

      Interpolate1 ( value1, value2, xgrad1, xgrad2,
                           ygrad1, ygrad2, xfrac, newvalue1, newygrad1 );
      Interpolate1 ( value3, value4, xgrad3, xgrad4,
                           ygrad3, ygrad4, xfrac, newvalue2, newygrad2 );
      Interpolate2 ( newvalue1, newvalue2, newygrad1,
                           newygrad2, yfrac, finalvalue );
      Noise2D := finalvalue;
   END;
   { ------------------------------------------------------------ }

   FUNCTION Turb2D ( x, y : real ) : real;
   VAR
      T, size : real;
   BEGIN
      T := 0;
      size := 1 ;
      WHILE size > 0.01 DO
      BEGIN
         T := T + abs ( Noise2D(x/size,y/size) * size );
         size := size * 0.5
      END;
      Turb2D := T;
   END;

   { ------------------ End of subprograms ------------------------- }



{ This is now the main program code - subprograms are called from this }

BEGIN
   { Set up the lattice of points }
   Init_Lattice;                            { initialize lattice values }

   { Put in graphics mode }
   Driver := DETECT;                        { these lines init the graphics }

   InitGraph(Driver,Mode,'');               { add path if using TurboPascal }

   { Main plotting loop. To look at the turbulence function, change
     "Noise2D" to "Turb2D" and recompile }

   FOR Y := 0 TO 199 DO
      IF NOT KeyPressed THEN
         FOR X := 0 TO 319 DO
            PutPixel ( X,Y, trunc (Noise2D(X*0.01,Y*0.01)) MOD 16 );

   readln;                                  { wait for a keypress }
   CloseGraph;                              { shut down graphics, quit }
END.