mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-16 16:59:12 +02:00
+ mandel changed for new graph unit (probably not very linux compatible !)
This commit is contained in:
pierre
parent
cc415c9cd4
commit
7e69364aab
342
install/demo/nmandel.pp
Normal file
342
install/demo/nmandel.pp
Normal file
@ -0,0 +1,342 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1993-98 by Gernot Tenchio
|
||||
|
||||
Mandelbrot Example using the Graph unit
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
program mandel;
|
||||
|
||||
{
|
||||
Mandelbrot example using the graph unit.
|
||||
|
||||
Note: For linux you need to run this program as root !!
|
||||
}
|
||||
|
||||
uses
|
||||
{$ifdef go32v2}
|
||||
{$ifdef profile}
|
||||
{ profile needs only to be inserted in _USES
|
||||
for version < 0.99.9 PM }
|
||||
profile,
|
||||
{$endif profile}
|
||||
heaptrc,
|
||||
dpmiexcp,
|
||||
{$endif go32v2}
|
||||
Graph;
|
||||
|
||||
{$ifdef FPC}
|
||||
{$ifdef go32v2}
|
||||
{$ifndef ver0_99_8}
|
||||
{$define has_colors_equal}
|
||||
{$endif ver0_99_8}
|
||||
{$endif go32v2}
|
||||
{$endif FPC}
|
||||
|
||||
const
|
||||
shift:byte=12;
|
||||
|
||||
var
|
||||
SearchPoint,ActualPoint,NextPoint : PointType;
|
||||
LastColor : longint;
|
||||
Gd,Gm,
|
||||
Max_Color,Max_X_Width,
|
||||
Max_Y_Width,Y_Width : integer;
|
||||
Y1,Y2,X1,X2,Dy,Dx : Real;
|
||||
Zm : Integer;
|
||||
Flag : boolean;
|
||||
LineY : array [0..600] OF BYTE;
|
||||
LineX : array [0..100,0..600] OF INTEGER;
|
||||
const
|
||||
SX : array [0..7] OF SHORTINT=(-1, 0, 1, 1, 1, 0,-1,-1);
|
||||
SY : array [0..7] OF SHORTINT=(-1,-1,-1, 0, 1, 1, 1, 0);
|
||||
type
|
||||
arrayType = array[1..50] of integer;
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
{$ifndef has_colors_equal}
|
||||
function ColorsEqual(c1, c2 : longint) : boolean;
|
||||
begin
|
||||
ColorsEqual:=((GetMaxColor=$FF) and ((c1 and $FF)=(c2 and $FF))) or
|
||||
((GetMaxColor=$7FFF) and ((c1 and $F8F8F8)=(c2 and $F8F8F8))) or
|
||||
((GetMaxColor=$FFFF) and ((c1 and $F8FCF8)=(c2 and $F8FCF8))) or
|
||||
((GetMaxColor>$10000) and ((c1 and $FFFFFF)=(c2 and $FFFFFF)));
|
||||
end;
|
||||
|
||||
{$endif not has_colors_equal}
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
function CalcMandel(Point:PointType; z:integer) : Longint ;
|
||||
var
|
||||
x,y,xq,yq,Cx,Cy : real ;
|
||||
begin
|
||||
Cy:=y2 + dy*Point.y ;
|
||||
Cx:=x2 + dx*Point.x ;
|
||||
X:=-Cx ; Y:=-Cy ;
|
||||
repeat
|
||||
xq:=x * x;
|
||||
yq:=y * y ;
|
||||
y :=x * y;
|
||||
y :=y + y - cy;
|
||||
x :=xq - yq - cx ;
|
||||
z :=z -1;
|
||||
until (Z=0) or (Xq + Yq > 4 );
|
||||
if Z=0 Then
|
||||
CalcMandel:=1
|
||||
else if getMaxColor>255 then
|
||||
CalcMandel:=(stdcolors[(z mod 254) + 1] and $FFFFFF)
|
||||
else
|
||||
CalcMandel:=(z mod Max_Color) + 1 ;
|
||||
end;
|
||||
|
||||
{-----------------------------------------------------------------------------}
|
||||
procedure Partition(var A : arrayType; First, Last : Byte);
|
||||
var
|
||||
Right,Left : byte ;
|
||||
V,Temp : integer;
|
||||
begin
|
||||
V := A[(First + Last) SHR 1];
|
||||
Right := First;
|
||||
Left := Last;
|
||||
repeat
|
||||
while (A[Right] < V) do
|
||||
inc(Right);
|
||||
while (A[Left] > V) do
|
||||
Dec(Left);
|
||||
if (Right <= Left) then
|
||||
begin
|
||||
Temp:=A[Left];
|
||||
A[Left]:=A[Right];
|
||||
A[Right]:=Temp;
|
||||
Right:=Right+1;
|
||||
Left:=Left-1;
|
||||
end;
|
||||
until Right > Left;
|
||||
if (First < Left) then
|
||||
Partition(A, First, Left);
|
||||
if (Right < Last) then
|
||||
Partition(A, Right, Last)
|
||||
end;
|
||||
|
||||
{-----------------------------------------------------------------------------}
|
||||
function BlackScan(var NextPoint:PointType) : boolean;
|
||||
begin
|
||||
BlackScan:=true;
|
||||
repeat
|
||||
if NextPoint.X=Max_X_Width then
|
||||
begin
|
||||
if NextPoint.Y < Y_Width then
|
||||
begin
|
||||
NextPoint.X:=0 ;
|
||||
NextPoint.Y:=NextPoint.Y+1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
BlackScan:=false;
|
||||
exit;
|
||||
end ; { IF }
|
||||
end ; { IF }
|
||||
NextPoint.X:=NextPoint.X+1;
|
||||
until GetPixel(NextPoint.X,NextPoint.Y)=0;
|
||||
end ;
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
procedure Fill(Ymin,Ymax,LastColor:integer);
|
||||
var
|
||||
P1,P3,P4,P : integer ;
|
||||
Len,P2 : byte ;
|
||||
Darray : arraytype;
|
||||
begin
|
||||
SetColor(LastColor);
|
||||
for P1:=Ymin+1 to Ymax-1 do
|
||||
begin
|
||||
Len:=LineY[P1] ;
|
||||
if Len >= 2 then
|
||||
begin
|
||||
for P2:=1 to Len do
|
||||
Darray[P2]:=LineX[P2,P1] ;
|
||||
if Len > 2 then
|
||||
Partition(Darray,1,len);
|
||||
P2:=1;
|
||||
repeat
|
||||
P3:= Darray[P2] ; P4:= Darray[P2 + 1];
|
||||
if P3 <> P4 then
|
||||
begin
|
||||
line ( P3 , P1 , P4 , P1) ;
|
||||
if Flag then
|
||||
begin
|
||||
P:=Max_Y_Width-P1;
|
||||
line ( P3 , P , P4 , P ) ;
|
||||
end;
|
||||
end; { IF }
|
||||
P2:=P2+2;
|
||||
until P2 >= Len ;
|
||||
end; { IF }
|
||||
end; { FOR }
|
||||
end;
|
||||
|
||||
{-----------------------------------------------------------------------------}
|
||||
Function NewPosition(Last:Byte):Byte;
|
||||
begin
|
||||
newposition:=(((last+1) and 254)+6) and 7;
|
||||
end;
|
||||
|
||||
{-----------------------------------------------------------------------------}
|
||||
procedure CalcBounds;
|
||||
var
|
||||
lastOperation,KK,
|
||||
Position : Byte ;
|
||||
foundcolor : longint;
|
||||
Start,Found,NotFound : boolean ;
|
||||
MerkY,Ymax : Integer ;
|
||||
label
|
||||
L;
|
||||
begin
|
||||
repeat
|
||||
FillChar(LineY,SizeOf(LineY),0) ;
|
||||
ActualPoint:=NextPoint;
|
||||
LastColor:=CalcMandel(NextPoint,Zm) ;
|
||||
putpixel (ActualPoint.X,ActualPoint.Y,LastColor);
|
||||
if Flag then
|
||||
putpixel (ActualPoint.X,Max_Y_Width-ActualPoint.Y,LastColor) ;
|
||||
Ymax:=NextPoint.Y ;
|
||||
MerkY:=NextPoint.Y ;
|
||||
NotFound:=false ;
|
||||
Start:=false ;
|
||||
LastOperation:=4 ;
|
||||
repeat
|
||||
Found:=false ;
|
||||
KK:=0 ;
|
||||
Position:=NewPosition(LastOperation);
|
||||
repeat
|
||||
LastOperation:=(Position+KK) and 7 ;
|
||||
SearchPoint.X:=ActualPoint.X+Sx[LastOperation];
|
||||
SearchPoint.Y:=ActualPoint.Y+Sy[LastOperation];
|
||||
if ((SearchPoint.X < 0) or
|
||||
(SearchPoint.X > Max_X_Width) or
|
||||
(SearchPoint.Y < NextPoint.Y) or
|
||||
(SearchPoint.Y > Y_Width)) then
|
||||
goto L;
|
||||
if (SearchPoint.X=NextPoint.X) and (SearchPoint.Y=NextPoint.Y) then
|
||||
begin
|
||||
Start:=true ;
|
||||
Found:=true ;
|
||||
end
|
||||
else
|
||||
begin
|
||||
FoundColor:=GetPixel(SearchPoint.X,SearchPoint.Y) ;
|
||||
if FoundColor = 0 then
|
||||
begin
|
||||
FoundColor:= CalcMandel (SearchPoint,Zm) ;
|
||||
Putpixel (SearchPoint.X,SearchPoint.Y,FoundColor) ;
|
||||
if Flag then
|
||||
PutPixel (SearchPoint.X,Max_Y_Width-SearchPoint.Y,FoundColor) ;
|
||||
end ;
|
||||
if ColorsEqual(FoundColor,LastColor) then
|
||||
begin
|
||||
if ActualPoint.Y <> SearchPoint.Y then
|
||||
begin
|
||||
if SearchPoint.Y = MerkY then
|
||||
LineY[ActualPoint.Y]:=LineY[ActualPoint.Y]-1;
|
||||
MerkY:= ActualPoint.Y ;
|
||||
LineY[SearchPoint.Y]:=LineY[SearchPoint.Y]+1;
|
||||
end ;
|
||||
LineX[LineY[SearchPoint.Y],SearchPoint.Y]:=SearchPoint.X ;
|
||||
if SearchPoint.Y > Ymax then Ymax:= SearchPoint.Y ;
|
||||
Found:=true ;
|
||||
ActualPoint:=SearchPoint ;
|
||||
end;
|
||||
L:
|
||||
KK:=KK+1;
|
||||
if KK > 8 then
|
||||
begin
|
||||
Start:=true ;
|
||||
NotFound:=true ;
|
||||
end;
|
||||
end;
|
||||
until Found or (KK > 8);
|
||||
until Start ;
|
||||
if not NotFound then
|
||||
Fill(NextPoint.Y,Ymax,LastColor) ;
|
||||
until not BlackScan(NextPoint);
|
||||
end ;
|
||||
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
MAINROUTINE
|
||||
------------------------------------------------------------------------------}
|
||||
{$ifndef Linux}
|
||||
var
|
||||
error : word;
|
||||
{$endif not Linux}
|
||||
|
||||
begin
|
||||
{$ifdef Linux}
|
||||
gm:=0;
|
||||
gd:=0;
|
||||
{$else}
|
||||
if paramcount>0 then
|
||||
begin
|
||||
val(paramstr(1),gm,error);
|
||||
if error<>0 then
|
||||
gm:=$103;
|
||||
end
|
||||
else
|
||||
gm:=$103;
|
||||
gd:=$ff;
|
||||
{$ifDEF TURBO}
|
||||
gd:=detect;
|
||||
{$endif}
|
||||
{$endif}
|
||||
InitGraph(gd,gm,'D:\bp\bgi');
|
||||
if GraphResult <> grOk then Halt(1);
|
||||
Max_X_Width:=GetMaxX;
|
||||
Max_y_Width:=GetMaxY;
|
||||
Max_Color:=GetMaxColor-1;
|
||||
ClearViewPort;
|
||||
|
||||
x1:=-0.9;
|
||||
x2:= 2.2;
|
||||
y1:= 1.25;
|
||||
y2:=-1.25;
|
||||
zm:=90;
|
||||
dx:=(x1 - x2) / Max_X_Width ;
|
||||
dy:=(y1 - y2) / Max_Y_Width ;
|
||||
if abs(y1) = abs(y2) then
|
||||
begin
|
||||
{$ifndef NOFLAG}
|
||||
flag:=true;
|
||||
{$endif NOFLAG}
|
||||
Y_Width:=Max_Y_Width shr 1
|
||||
end
|
||||
else
|
||||
begin
|
||||
flag:=false;
|
||||
Y_Width:=Max_Y_Width;
|
||||
end;
|
||||
NextPoint.X:=0;
|
||||
NextPoint.Y:=0;
|
||||
LastColor:=CalcMandel(SearchPoint,zm);
|
||||
CalcBounds ;
|
||||
{$ifndef fpc_profile}
|
||||
readln;
|
||||
{$endif fpc_profile}
|
||||
CloseGraph;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-11-17 18:17:53 pierre
|
||||
+ mandel changed for new graph unit (probably not very linux compatible !)
|
||||
|
||||
Revision 1.3 1998/09/11 10:55:25 peter
|
||||
+ header+log
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user