PureBoard

Code: Alles auswählen

UNIT EXTPOV;

Interface

Uses Dos;

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

Type POV_TLindenmayerSystem = Record
     RuleName:Char;
     Rule:String;
End;

Type POV_TDACPalette256 = Array[0..255] Of Array[0..2] Of Byte;

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

Const _POVRAY_MAXX = 640;
      _POVRAY_MAXY = 480;
      _POVRAY_XMIN = 0;
      _POVRAY_YMIN = 5;
      _POVRAY_ZMIN = (-10);
      _POVRAY_XMAX = 10;
      _POVRAY_YMAX = (-5);
      _POVRAY_ZMAX = 10;
      _POVRAY_PATH = 'C:\POVRAY\';
      _POVRAY_NAME = 'POVRAY.EXE';

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

Var POVRAY_XMIN, POVRAY_YMIN, POVRAY_ZMIN,
    POVRAY_XMAX, POVRAY_YMAX, POVRAY_ZMAX,
    POVRAY_MAXX, POVRAY_MAXY:Real;
    POVRAY_PATH, POVRAY_NAME:String;

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

Procedure SetPOVRAYPath(Path:String);
Procedure SetPOVRAYResolution(XWidth, YWidth:Integer);
Procedure SetPOVRAYCoordinateSystem(x1,y1,z1,x2,y2,z2:Real);
Procedure ConvertLindenmayerSystemToPOVRAYScript(
                            FileName, Axiom:String;
                            Buffer:Array Of POV_TLindenmayerSystem;
                            Degree:Real;
                            Turn:Real;
                            Factor:Real;
                            Iterations:Byte;
                            x, y:Real;
                            CameraXPos, CameraYPos, CameraZPos:Real;
                            LookAtXPos, LookAtYPos, LookAtZPos:Real;
                            BlurSamples:Integer;
                            PlaneColor1, PlaneColor2:Real;
                            ColorFlag:Boolean;
                            R, G, B:Real;
                            ColorPalette:POV_TDACPalette256;
                            Index1, Index2:Byte;
                            Size:Real;
                            ZPos:Real;
                            LightSource1X, LightSource1Y, LightSource1Z,
                            LightSource2X, LightSource2Y,
                            LightSource2Z:Real;
                            FlowerPot:Boolean);
Function RunPOVRAY(ScriptFile, IniFile, Params:String):Integer;

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

Implementation

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

Procedure SetPOVRAYPath(Path:String);
Begin
If (Copy(Path,Length(Path),1) <> '\') Then Path := (Path+'\');
POVRAY_PATH := Path;
End;

Procedure SetPOVRAYResolution(XWidth, YWidth:Integer);
Begin
POVRAY_MAXX := XWidth;
POVRAY_MAXY := YWidth;
End;

Procedure SetPOVRAYCoordinateSystem(x1,y1,z1,x2,y2,z2:Real);
Begin
POVRAY_XMIN := 0;
POVRAY_YMIN := 5;
POVRAY_ZMIN := (-10);
POVRAY_XMAX := 10;
POVRAY_YMAX := (-5);
POVRAY_ZMAX := 10;
End;

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

Procedure ConvertLindenmayerSystemToPOVRAYScript(
                            FileName, Axiom:String;
                            Buffer:Array Of POV_TLindenmayerSystem;
                            Degree:Real;
                            Turn:Real;
                            Factor:Real;
                            Iterations:Byte;
                            x, y:Real;
                            CameraXPos, CameraYPos, CameraZPos:Real;
                            LookAtXPos, LookAtYPos, LookAtZPos:Real;
                            BlurSamples:Integer;
                            PlaneColor1, PlaneColor2:Real;
                            ColorFlag:Boolean;
                            R, G, B:Real;
                            ColorPalette:POV_TDACPalette256;
                            Index1, Index2:Byte;
                            Size:Real;
                            ZPos:Real;
                            LightSource1X, LightSource1Y, LightSource1Z,
                            LightSource2X, LightSource2Y,
                            LightSource2Z:Real;
                            FlowerPot:Boolean);

Type TTurtleStack = Record
     XPos,
     YPos,
     Heading:Real;
End;

Const FLOWERPOTSIZE = 4;
Const MaxSize = 9999;

Var ColorCounter:Byte;
    MaxRules, TurtleString_Size,
    TurtleString_Segment, TurtleString_Offset, StackSize:Word;
    Drawing:Boolean;
    POVRAYPalette:Array[0..255, 0..2] Of Real;
    TurtleString:^Char;
    Stack:Array[1..MaxSize] Of ^TTurtleStack;
    POV:Text;

Procedure _PMap(_x, _y, _x1, _y1, _x2, _y2:Real; Var _a, _b:Real);
Var f1, f2:Real;
Begin
f1 := ((_x2 - _x1) / POVRAY_MAXX);
f2 := ((_y2 - _y1) / POVRAY_MAXY);
_a := ((_x * f1) + _x1);
_b := ((_y * f2) + _y1);
End;

Function _s(x:Integer):String;
Var tmp:String;
Begin
Str(x,tmp);
_s := tmp;
End;

Function rs(x:Real):String;
Var tmp:String;
Begin
Str(x:1:4,tmp);
rs := tmp;
End;

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

Var _heading, _posx, _posy:Real;
    _down, _up:Boolean;

Procedure _InitTurtle;
Begin
_heading := 0;
_up := False;
_down := True;
_posx := x;
_posy := y;
End;

Procedure _SetHeading(_degree:Real);
Begin
_degree := (_degree-(Trunc((_degree/360))*360));
_heading := _degree;
End;

Procedure _SetXYPos(_x, _y:Real);
Begin
_posx := _x;
_posy := _y;
End;

Procedure _Forwd(_n:Real);
Var a1, a2, b1, b2,
    x, y, xx, yy:Real;
Begin
x := (_n*cos(_heading*PI/180));
y := (_n*sin(_heading*PI/180));
xx := _posx+x;
yy := _posy+y;
If (_down = True) Then
Begin
   _PMap(_posx,_posy,POVRAY_XMIN,POVRAY_YMIN,POVRAY_XMAX,POVRAY_YMAX,
        a1,b1);
   _PMap(xx,yy,POVRAY_XMIN,POVRAY_YMIN,POVRAY_XMAX,POVRAY_YMAX,
        a2,b2);
   Write(POV,'cylinder { <'+rs(a2)+','+rs(b2)+','+rs(ZPos)+'>, ');
   Write(POV,'<'+rs(a1)+','+rs(b1)+','+rs(ZPos)+'>, ');
   Write(POV,rs(Size)+' pigment { color rgb <');
   If (ColorFlag = True) Then
   Begin
      Write(POV,rs(POVRAYPalette[ColorCounter,0])+',');
      Write(POV,rs(POVRAYPalette[ColorCounter,1])+',');
      Write(POV,rs(POVRAYPalette[ColorCounter,2]));
   End
   Else
   Begin
      Write(POV,rs(R)+',');
      Write(POV,rs(G)+',');
      Write(POV,rs(B));
   End;
   Writeln(POV,'> }}');
   Flush(POV);
End;
_posx := xx;
_posy := yy;
End;

Procedure _TurnLeft(_n:Real);
Begin
_SetHeading((_heading-_n));
End;

Procedure _TurnRight(_n:Real);
Begin
_SetHeading((_heading+_n));
End;

Procedure _PenUp;
Begin
_up := True;
_down := False;
End;

Procedure _PenDown;
Begin
_up := False;
_down := True;
End;

Function _GetHeading:Real;
Begin
_GetHeading := _heading;
End;

Function _GetXPos:Real;
Begin
_GetXPos := _posx;
End;

Function _GetYPos:Real;
Begin
_GetYPos := _posy;
End;

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

Procedure Init;
Var i:Integer;
    tmpvar1, tmpvar2:Real;
    tmp:String;
Begin
MaxRules := High(Buffer);
StackSize := 1;
If (Iterations = 0) Then
   Iterations := 1;
GetMem(TurtleString,$FFFF);
TurtleString_Segment := Seg(TurtleString^);
TurtleString_Offset := Ofs(TurtleString^);
{---------------------------------------------------------------------------}
_PMap(CameraXPos,CameraYPos,POVRAY_XMIN,POVRAY_YMIN,POVRAY_XMAX,POVRAY_YMAX,
      tmpvar1,tmpvar2);
CameraXPos := tmpvar1;
CameraYPos := tmpvar2;
If (CameraZPos > POVRAY_ZMAX) Then CameraZPos := POVRAY_ZMAX;
If (CameraZPos < POVRAY_ZMIN) Then CameraZPos := POVRAY_ZMIN;
_PMap(LookAtXPos,LookAtYPos,POVRAY_XMIN,POVRAY_YMIN,POVRAY_XMAX,POVRAY_YMAX,
      tmpvar1,tmpvar2);
LookAtXPos := tmpvar1;
LookAtYPos := tmpvar2;
If (LookAtZPos > POVRAY_ZMAX) Then LookAtZPos := POVRAY_ZMAX;
If (LookAtZPos < POVRAY_ZMIN) Then LookAtZPos := POVRAY_ZMIN;
If ((CameraXPos = LookAtXPos) And
    (CameraYPos = LookAtYPos) And
    (CameraZPos = LookAtZPos)) Then
Begin
   CameraXPos := (POVRAY_XMIN+(POVRAY_XMAX/2));
   CameraYPos := (POVRAY_YMIN+((POVRAY_YMAX-POVRAY_YMIN)/2));
   CameraZPos := (POVRAY_ZMIN+(POVRAY_ZMAX/2));
End;
If ((CameraXPos = LookAtXPos) And
    (CameraYPos = LookAtYPos) And
    (CameraZPos = LookAtZPos)) Then
Begin
   LookAtXPos := (POVRAY_XMIN+(POVRAY_XMAX/2));
   LookAtYPos := (POVRAY_YMIN+((POVRAY_YMAX-POVRAY_YMIN)/2));
   LookAtZPos := (POVRAY_ZMIN+(POVRAY_ZMAX/2));
End;
If (PlaneColor1 > 255.0) Then PlaneColor1 := 255.0;
If (PlaneColor1 < 0.0) Then PlaneColor1 := 0.0;
PlaneColor1 := (PlaneColor1/255);
If (PlaneColor2 > 255.0) Then PlaneColor2 := 255.0;
If (PlaneColor2 < 0.0) Then PlaneColor2 := 0.0;
PlaneColor2 := (PlaneColor2/255);
If (R > 255.0) Then R := 255.0;
If (R < 0.0) Then R := 0.0;
R := (R/255);
If (G > 255.0) Then G := 255.0;
If (G < 0.0) Then G := 0.0;
G := (G/255);
If (B > 255.0) Then B := 255.0;
If (B < 0.0) Then B := 0.0;
B := (B/255);
For i := 0 To 255 Do
Begin
   POVRAYPalette[i,0] := ((ColorPalette[i,0] shl 2)/255);
   POVRAYPalette[i,1] := ((ColorPalette[i,1] shl 2)/255);
   POVRAYPalette[i,2] := ((ColorPalette[i,2] shl 2)/255);
End;
Size := (Abs(Size)/POVRAY_MAXX);
If (ZPos > POVRAY_ZMAX) Then ZPos := POVRAY_ZMAX;
If (ZPos < POVRAY_ZMIN) Then ZPos := POVRAY_ZMIN;
_PMap(LightSource1X,LightSource1Y,POVRAY_XMIN,POVRAY_YMIN,
      POVRAY_XMAX,POVRAY_YMAX,tmpvar1,tmpvar2);
LightSource1X := tmpvar1;
LightSource1Y := tmpvar2;
If (LightSource1Z > POVRAY_ZMAX) Then LightSource1Z := POVRAY_ZMAX;
If (LightSource1Z < POVRAY_ZMIN) Then LightSource1Z := POVRAY_ZMIN;
_PMap(LightSource2X,LightSource2Y,POVRAY_XMIN,POVRAY_YMIN,
      POVRAY_XMAX,POVRAY_YMAX,tmpvar1,tmpvar2);
LightSource2X := tmpvar1;
LightSource2Y := tmpvar2;
If (LightSource2Z > POVRAY_ZMAX) Then LightSource2Z := POVRAY_ZMAX;
If (LightSource2Z < POVRAY_ZMIN) Then LightSource2Z := POVRAY_ZMIN;
{---------------------------------------------------------------------------}
Assign(POV,FileName);
{---------------------------------------------------------------------------}
Rewrite(POV);
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'//-                                                          -');
Write(POV,'//-  TITLE: '+FileName);
tmp := '';
For i := 1 To (49-Length(FileName)) Do tmp := (tmp+' ');
Writeln(POV,tmp+'-');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//-  GENERATED WITH CONVERTLINDENMAYERSYSTEMTOPOVRAYSCRIPT   -');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//-                       UNIT XPOVRAY                       -');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//-                    (c) Michi$oft, 2005                   -');
Writeln(POV,'//-                                                          -');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'#include "colors.inc"');
Writeln(POV,'#include "shapes.inc"');
Writeln(POV,'#include "textures.inc"');
Writeln(POV,'#version 3.0');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'plane');
Writeln(POV,'{');
Writeln(POV,'   <0,1,0>, (-5)');
Writeln(POV,'   pigment');
Writeln(POV,'   {');
Write(POV,'      checker color rgb <'+rs(PlaneColor1));
Write(POV,','+rs(PlaneColor1)+','+rs(PlaneColor1)+'> color rgb <');
Writeln(POV,rs(PlaneColor2)+','+rs(PlaneColor2)+','+rs(PlaneColor2)+'>');
Writeln(POV,'   }');
Writeln(POV,'}');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'light_source');
Writeln(POV,'{');
Write(POV,'   <'+rs(LightSource1X)+',');
Write(POV,rs(LightSource1Y)+',');
Writeln(POV,rs(LightSource1Z)+'>');
Writeln(POV,'   color White');
Writeln(POV,'}');
Writeln(POV,'');
Writeln(POV,'light_source');
Writeln(POV,'{');
Write(POV,'   <'+rs(LightSource2X)+',');
Write(POV,rs(LightSource2Y)+',');
Writeln(POV,rs(LightSource2Z)+'>');
Writeln(POV,'   color White');
Writeln(POV,'}');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'camera');
Writeln(POV,'{');
Write(POV,'   location <');
Writeln(POV,rs(CameraXPos)+','+rs(CameraYPos)+','+rs(CameraZPos)+'>');
Write(POV,'   look_at <');
Writeln(POV,rs(LookAtXPos)+','+rs(LookAtYPos)+','+rs(LookAtZPos)+'>');
Writeln(POV,'   blur_samples '+_s(BlurSamples));
Writeln(POV,'}');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'');
Writeln(POV,'//------------------------------------------------------------');
Writeln(POV,'//-          HERE STARTS THE LINDENMAYER-FRACTAL!            -');
Writeln(POV,'//------------------------------------------------------------');
Flush(POV);
Close(POV);
End;

Procedure MakeTurtleString;
Var BufferSegment, BufferOffset,
    TmpBufferSegment, TmpBufferOffset:Word;
    i, k, l:Word;
    strcnt, tmpcnt:LongInt;
    ReplaceFlag:Boolean;
    TurtleString_Buffer, TmpBuffer:^Char;
    Label EndOfLoop;
Begin
GetMem(TurtleString_Buffer,$FFFF);
GetMem(TmpBuffer,$FFFF);
BufferSegment := Seg(TurtleString_Buffer^);
BufferOffset := Ofs(TurtleString_Buffer^);
TmpBufferSegment := Seg(TmpBuffer^);
TmpBufferOffset := Ofs(TmpBuffer^);
For i := 1 To Length(Axiom) Do
   Mem[BufferSegment:(BufferOffset+(i-1))] := Byte(Axiom[i]);
Mem[BufferSegment:(BufferOffset+Length(Axiom))] := 0;
For i := 1 To Iterations Do
Begin
   strcnt := 0;
   tmpcnt := 0;
   Repeat
      If (Not(Chr(Mem[BufferSegment:strcnt]) In ['+','-','[',']'])) Then
      Begin
         ReplaceFlag := False;
         For k := 0 To MaxRules Do
         Begin
            If (Chr(Mem[BufferSegment:strcnt]) = Buffer[k].RuleName) Then
            Begin
               For l := 0 To (Length(Buffer[k].Rule)-1) Do
                  Mem[TmpBufferSegment:(TmpBufferOffset+tmpcnt+l)] := Byte(Buffer[k].Rule[(l+1)]);
               If ((tmpcnt+l+1) >= $FFFF) Then
                  Goto EndOfLoop;
               Inc(tmpcnt,l);
               Inc(tmpcnt);
               ReplaceFlag := True;
               Break;
            End;
         End;
         If (ReplaceFlag = False) Then
         Begin
            Mem[TmpBufferSegment:(TmpBufferOffset+tmpcnt)] := Mem[BufferSegment:(BufferOffset+strcnt)];
            If (tmpcnt >= $FFFF) Then
               Goto EndOfLoop;
            Inc(tmpcnt);
         End;
      End
      Else
      Begin
         Mem[TmpBufferSegment:(TmpBufferOffset+tmpcnt)] := Mem[BufferSegment:(BufferOffset+strcnt)];
         Inc(tmpcnt);
         If (tmpcnt >= $FFFF) Then
            Goto EndOfLoop;
      End;
      Inc(strcnt);
   Until (Mem[BufferSegment:strcnt] = 0);
   Dec(tmpcnt);
   For k := 0 To tmpcnt Do
      Mem[BufferSegment:(BufferOffset+k)] := Mem[TmpBufferSegment:(TmpBufferOffset+k)];
   Mem[BufferSegment:(BufferOffset+(tmpcnt+1))] := 0;
End;
EndOfLoop:
If (tmpcnt > $FFFF) Then
   tmpcnt := (tmpcnt-(tmpcnt-$FFFF));
For i := 0 To tmpcnt Do
Begin
   Mem[TurtleString_Segment:(TurtleString_Offset+i)] := Mem[BufferSegment:(BufferOffset+i)];
   Mem[BufferSegment:(BufferOffset+i)] := 0;
   Mem[TmpBufferSegment:(TmpBufferOffset+i)] := 0;
End;
FreeMem(TmpBuffer,$FFFF);
FreeMem(TurtleString_Buffer,$FFFF);
TurtleString_Size := tmpcnt;
End;

Procedure Turtle(command:Char);
Begin
If ((command = 'F') Or (command = 'f')) Then
Begin
   If (Drawing = True) Then
      _PenDown
   Else
      _PenUp;
   _Forwd(Factor);
End;
If (command = '+') Then
   _TurnRight(Degree);
If (command = '-') Then
   _TurnLeft(Degree);
If (command = '[') Then
Begin
   If (StackSize = MaxSize) Then Exit;
   If (ColorCounter < Index2) Then Inc(ColorCounter);
   New(Stack[StackSize]);
   Stack[StackSize]^.XPos := _GetXPos;
   Stack[StackSize]^.YPos := _GetYPos;
   Stack[StackSize]^.Heading := _GetHeading;
   Inc(StackSize);
End;
If (command = ']') Then
Begin
   Dec(StackSize);
   If (StackSize = 0) Then Exit;
   If (ColorCounter > Index1) Then Dec(ColorCounter);
   _SetXYPos(Stack[StackSize]^.XPos,Stack[StackSize]^.YPos);
   _SetHeading(Stack[StackSize]^.Heading);
   Dispose(Stack[StackSize]);
End;
End;

Procedure Interpret;
Var i:Word;
    command:Char;
Begin
Append(POV);
_InitTurtle;
_SetHeading(Turn);
ColorCounter := Index1;
For i := 0 To TurtleString_Size Do
Begin
   command := Chr(Mem[TurtleString_Segment:(TurtleString_Offset+i)]);
   If (command = 'F') Then
      Drawing := True
   Else If (command = 'f') Then
      Drawing := False;
   Turtle(command);
End;
End;

Procedure Done;
Var tmpvar1, tmpvar2:Real;
Begin
FreeMem(TurtleString,$FFFF);
If (FlowerPot = True) Then
Begin
   _PMap(x,y,POVRAY_XMIN,POVRAY_YMIN,POVRAY_XMAX,POVRAY_YMAX,
         tmpvar1,tmpvar2);
   Writeln(POV,'//------------------------------------------------------------');
   Write(POV,'sphere { <'+rs(tmpvar1)+','+rs(tmpvar2)+','+rs(ZPos)+'>, ');
   Write(POV,rs((Size*FLOWERPOTSIZE*PI))+' texture { pigment { color rgb <');
   If (ColorFlag = True) Then
   Begin
      Write(POV,rs(POVRAYPalette[Index1,0])+',');
      Write(POV,rs(POVRAYPalette[Index1,1])+',');
      Write(POV,rs(POVRAYPalette[Index1,2])+'>');
   End
   Else
   Begin
      Write(POV,rs(R)+',');
      Write(POV,rs(G)+',');
      Write(POV,rs(B)+'>');
   End;
   Writeln(POV,' }}}');
End;
Writeln(POV,'//------------------------------------------------------------');
Flush(POV);
Close(POV);
End;

Begin
Init;
MakeTurtleString;
Interpret;
Done;
End;

Function RunPOVRAY(ScriptFile, IniFile, Params:String):Integer;
Var execstr, parameterstr, tmp:String;
Begin
execstr := '';
parameterstr := '';
tmp := '';
execstr := (POVRAY_PATH+POVRAY_NAME);
If (IniFile <> '') Then parameterstr := (parameterstr+IniFile);
parameterstr := (parameterstr+'+I'+ScriptFile+' +W');
Str(Round(POVRAY_MAXX),tmp);
parameterstr := (parameterstr+tmp);
Str(Round(POVRAY_MAXY),tmp);
parameterstr := (parameterstr+' +H'+tmp);
If (Params <> '') Then parameterstr := (parameterstr+' '+Params);
Exec(execstr,parameterstr);
RunPOVRAY := DosError;
End;

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

BEGIN
POVRAY_NAME := _POVRAY_NAME;
SetPOVRAYPath(_POVRAY_PATH);
SetPOVRAYResolution(_POVRAY_MAXX,_POVRAY_MAXY);
SetPOVRAYCoordinateSystem(_POVRAY_XMIN,_POVRAY_YMIN,_POVRAY_ZMIN,
                          _POVRAY_XMAX,_POVRAY_YMAX,_POVRAY_ZMAX);
END.