[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    {$G+} { Enable 286 Instructions }
    {$N+} { Enable Math Coprocessor - Delete This Line If You Don't Have One }
    Program FractalPlasma;

    { Programmed By David Dahl }

    (* PUBLIC DOMAIN *)

    Uses
      CRT,
      Palette;

    Const
      Rug = 0.2;

    Type
      VGAPtr  = ^VGAType;
      VGAType = Array [0..199, 0..319] of Byte;

    Var
      Screen    : VGAPtr;

      PlasmaMap : VGAPtr;
      PlasmaPal : PaletteType;

    Procedure GeneratePlasma(P : VGAPtr);
    {                                                                 }
    { This procedure uses an algorithm to generate a fractal surface. }
    {                                                                 }
    { Algorithm from page 359 of _Computer_Graphics:_the_Principles_  }
    { _Behind_the_Art_And_Science_ by Pokorny and Gerald.             }
    {                                                                 }
      Procedure FractPlasma(il, jl, ih, jh : Integer);
      Var
        im, jm : Integer;
      Begin
        im := (il + ih + 1) DIV 2;
        jm := (jl + jh + 1) DIV 2;

        If jm < jh then
        Begin
          If P^[il,jm] = 0 Then
            P^[il,jm] := Trunc(((P^[il,jl] + P^[il,jh]) / 2) +
                                  Random*Rug*(jh-jl));
          If il < ih Then
            P^[ih,jm] := Trunc(((P^[ih,jl] + P^[ih,jh]) / 2) +
                                  Random*Rug*(jh-jl));
        End;

        If im < ih then
        Begin
          If P^[im,jl] = 0 Then
            P^[im,jl] := Trunc(((P^[il,jl] + P^[ih,jl]) / 2) +
                                  Random*Rug*(ih-il));
          If jl < jh Then
            P^[im,jh] := Trunc(((P^[il,jh] + P^[ih,jh]) / 2) +
                                  Random*Rug*(jh-jl));
        End;

        If (im < ih) AND (jm < jh) Then
          P^[im,jm] := Trunc(((P^[il,jl] + P^[ih,jl] +
                               P^[il,jh] + P^[ih, jh]) / 4) +
                               Random*Rug*(ABS(ih-il)+abs(jh-jl)));
        If (im < ih) OR (jm < jh) Then
        Begin
          FractPlasma(il, jl, im, jm);
          FractPlasma(il, jm, im, jh);
          FractPlasma(im, jl, ih, jm);
          FractPlasma(im, jm, ih, jh);
        End;
      End;

    Begin
      FractPlasma(0, 0, 199, 319);
    End;

    Procedure InitVGA13h; Assembler;
    Asm
      MOV AX, $0013
      INT $10
    End;

    Procedure CalculatePalette(Var PalOut : PaletteType);
    Var
      RA, GA, BA : Integer;
      RF, GF, BF : Integer;
      RS, GS, BS : Integer;
      Counter    : Word;
    Begin
      RA := 16 + Random(32-16);
      GA := 16 + Random(32-16);
      BA := 16 + Random(32-16);

      RF := 2 + Random(5);
      GF := 2 + Random(5);
      BF := 2 + Random(5);

      RS := Random(64);
      GS := Random(64);
      BS := Random(64);

      For Counter := 0 to 255 do
      With PalOut[Counter] do
      Begin
        Red   := 32 + Round(RA * Sin((RS + Counter * RF) * Pi / 128));
        Green := 32 + Round(GA * Sin((GS + Counter * GF) * Pi / 128));
        Blue  := 32 + Round(BA * Sin((BS + Counter * BF) * Pi / 128));
      End;
    End;

    Procedure RotatePalette(Var PalIn : PaletteType);
    Var
      TRGB : PaletteRec;
    Begin
      TRGB := PalIn[0];
      Move (PalIn[1], PalIn[0], 255 * 3);
      PalIn[255] := TRGB;
    End;

    Var
      Int : Integer;
      Key : Char;
    Begin
      DirectVideo := False;
      Randomize;

      InitVGA13h;

      Screen := Ptr($A000,$0000);
      New(PlasmaMap);

      { Initialize Workspace }
      FillChar(PlasmaMap^, 320 * 200 , 0);

      { Calculate Smooth Random Colors }
      CalculatePalette(PlasmaPal);

      GotoXY(12, 12);
      Writeln('Generating Plasma');
      GotoXY(14, 14);
      Writeln('Please Wait...');

      GeneratePlasma(PlasmaMap);

      { Set All Colors to Black }
      BlackPalette;
      { Copy Fractal To Screen }
      Screen^ := PlasmaMap^;

      { Rotate Palette And Fade It In Slowly }
      For Int := 1 to 32 do
      Begin
        RotatePalette(PlasmaPal);
        FadeInFromBlackQ(PlasmaPal, Int);
      End;

      { Rotate Full Intensity Palette And Wait For KeyPress }
      Repeat
        RotatePalette(PlasmaPal);
        SetPalette(PlasmaPal);
      Until KeyPressed;

      { Rotate Palette and Fade It Out Slowly }
      For Int := 31 downto 0 do
      Begin
        RotatePalette(PlasmaPal);
        FadeInFromBlackQ(PlasmaPal, Int);
      End;

      Dispose(PlasmaMap);

      TextMode(C80);

      { Flush Keyboard Buffer }
      While KeyPressed do
        Key := ReadKey;
    End.

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]