mandel.pp 9.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1993-98 by Gernot Tenchio
  5. Mandelbrot Example using the Graph unit
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. program mandel;
  13. {
  14. Mandelbrot example using the graph unit.
  15. Note: For linux you need to run this program as root !!
  16. }
  17. uses
  18. {$ifdef go32v2}
  19. dpmiexcp,
  20. {$endif go32v2}
  21. dos,Graph;
  22. {
  23. const
  24. shift:byte=12;
  25. }
  26. var
  27. SearchPoint,ActualPoint,NextPoint : PointType;
  28. LastColor : longint;
  29. Gd,Gm,
  30. Max_Color,Max_X_Width,
  31. Max_Y_Width,Y_Width : word;
  32. Y1,Y2,X1,X2,Dy,Dx : Real;
  33. Zm : Integer;
  34. SymetricCase : boolean;
  35. LineY : array [0..600] OF BYTE;
  36. LineX : array [0..100,0..600] OF INTEGER;
  37. const
  38. SX : array [0..7] OF SHORTINT=(-1, 0, 1, 1, 1, 0,-1,-1);
  39. SY : array [0..7] OF SHORTINT=(-1,-1,-1, 0, 1, 1, 1, 0);
  40. type
  41. arrayType = array[1..50] of integer;
  42. {------------------------------------------------------------------------------}
  43. function ColorsEqual(c1, c2 : longint) : boolean;
  44. begin
  45. ColorsEqual:=((GetMaxColor=$FF) and ((c1 and $FF)=(c2 and $FF))) or
  46. ((GetMaxColor=$7FFF) and ((c1 and $F8F8F8)=(c2 and $F8F8F8))) or
  47. ((GetMaxColor=$FFFF) and ((c1 and $F8FCF8)=(c2 and $F8FCF8))) or
  48. ((GetMaxColor>$10000) and ((c1 and $FFFFFF)=(c2 and $FFFFFF)));
  49. end;
  50. {------------------------------------------------------------------------------}
  51. function CalcMandel(Point:PointType; z:integer) : Longint ;
  52. var
  53. x,y,xq,yq,Cx,Cy : real ;
  54. begin
  55. Cy:=y2 + dy*Point.y ;
  56. Cx:=x2 + dx*Point.x ;
  57. X:=-Cx ; Y:=-Cy ;
  58. repeat
  59. xq:=x * x;
  60. yq:=y * y ;
  61. y :=x * y;
  62. y :=y + y - cy;
  63. x :=xq - yq - cx ;
  64. z :=z -1;
  65. until (Z=0) or (Xq + Yq > 4 );
  66. if Z=0 Then
  67. CalcMandel:=(blue and $FFFFFF)
  68. else
  69. CalcMandel:=(z mod Max_Color) + 1 ;
  70. end;
  71. {-----------------------------------------------------------------------------}
  72. procedure Partition(var A : arrayType; First, Last : Byte);
  73. var
  74. Right,Left : byte ;
  75. V,Temp : integer;
  76. begin
  77. V := A[(First + Last) SHR 1];
  78. Right := First;
  79. Left := Last;
  80. repeat
  81. while (A[Right] < V) do
  82. inc(Right);
  83. while (A[Left] > V) do
  84. Dec(Left);
  85. if (Right <= Left) then
  86. begin
  87. Temp:=A[Left];
  88. A[Left]:=A[Right];
  89. A[Right]:=Temp;
  90. Right:=Right+1;
  91. Left:=Left-1;
  92. end;
  93. until Right > Left;
  94. if (First < Left) then
  95. Partition(A, First, Left);
  96. if (Right < Last) then
  97. Partition(A, Right, Last)
  98. end;
  99. {-----------------------------------------------------------------------------}
  100. function BlackScan(var NextPoint:PointType) : boolean;
  101. begin
  102. BlackScan:=true;
  103. repeat
  104. if NextPoint.X=Max_X_Width then
  105. begin
  106. if NextPoint.Y < Y_Width then
  107. begin
  108. NextPoint.X:=0 ;
  109. NextPoint.Y:=NextPoint.Y+1;
  110. end
  111. else
  112. begin
  113. BlackScan:=false;
  114. exit;
  115. end ; { IF }
  116. end ; { IF }
  117. NextPoint.X:=NextPoint.X+1;
  118. until GetPixel(NextPoint.X,NextPoint.Y)=0;
  119. end ;
  120. {------------------------------------------------------------------------------}
  121. procedure Fill(Ymin,Ymax,LastColor:integer);
  122. var
  123. P1,P3,P4,P : integer ;
  124. Len,P2 : byte ;
  125. Darray : arraytype;
  126. begin
  127. SetColor(LastColor);
  128. for P1:=Ymin+1 to Ymax-1 do
  129. begin
  130. Len:=LineY[P1] ;
  131. if Len >= 2 then
  132. begin
  133. for P2:=1 to Len do
  134. Darray[P2]:=LineX[P2,P1] ;
  135. if Len > 2 then
  136. Partition(Darray,1,len);
  137. P2:=1;
  138. repeat
  139. P3:= Darray[P2] ; P4:= Darray[P2 + 1];
  140. if P3 <> P4 then
  141. begin
  142. line ( P3 , P1 , P4 , P1) ;
  143. if SymetricCase then
  144. begin
  145. P:=Max_Y_Width-P1;
  146. line ( P3 , P , P4 , P ) ;
  147. end;
  148. end; { IF }
  149. P2:=P2+2;
  150. until P2 >= Len ;
  151. end; { IF }
  152. end; { FOR }
  153. end;
  154. {-----------------------------------------------------------------------------}
  155. Function NewPosition(Last:Byte):Byte;
  156. begin
  157. newposition:=(((last+1) and 254)+6) and 7;
  158. end;
  159. {-----------------------------------------------------------------------------}
  160. procedure CalcBounds;
  161. var
  162. lastOperation,KK,
  163. Position : Byte ;
  164. foundcolor : longint;
  165. Start,Found,NotFound : boolean ;
  166. MerkY,Ymax : Integer ;
  167. label
  168. L;
  169. begin
  170. repeat
  171. FillChar(LineY,SizeOf(LineY),0) ;
  172. ActualPoint:=NextPoint;
  173. LastColor:=CalcMandel(NextPoint,Zm) ;
  174. putpixel (ActualPoint.X,ActualPoint.Y,LastColor);
  175. if SymetricCase then
  176. putpixel (ActualPoint.X,Max_Y_Width-ActualPoint.Y,LastColor) ;
  177. Ymax:=NextPoint.Y ;
  178. MerkY:=NextPoint.Y ;
  179. NotFound:=false ;
  180. Start:=false ;
  181. LastOperation:=4 ;
  182. repeat
  183. Found:=false ;
  184. KK:=0 ;
  185. Position:=NewPosition(LastOperation);
  186. repeat
  187. LastOperation:=(Position+KK) and 7 ;
  188. SearchPoint.X:=ActualPoint.X+Sx[LastOperation];
  189. SearchPoint.Y:=ActualPoint.Y+Sy[LastOperation];
  190. if ((SearchPoint.X < 0) or
  191. (SearchPoint.X > Max_X_Width) or
  192. (SearchPoint.Y < NextPoint.Y) or
  193. (SearchPoint.Y > Y_Width)) then
  194. goto L;
  195. if (SearchPoint.X=NextPoint.X) and (SearchPoint.Y=NextPoint.Y) then
  196. begin
  197. Start:=true ;
  198. Found:=true ;
  199. end
  200. else
  201. begin
  202. FoundColor:=GetPixel(SearchPoint.X,SearchPoint.Y) ;
  203. if FoundColor = 0 then
  204. begin
  205. FoundColor:= CalcMandel (SearchPoint,Zm) ;
  206. Putpixel (SearchPoint.X,SearchPoint.Y,FoundColor) ;
  207. if SymetricCase then
  208. PutPixel (SearchPoint.X,Max_Y_Width-SearchPoint.Y,FoundColor) ;
  209. end ;
  210. if ColorsEqual(FoundColor,LastColor) then
  211. begin
  212. if ActualPoint.Y <> SearchPoint.Y then
  213. begin
  214. if SearchPoint.Y = MerkY then
  215. LineY[ActualPoint.Y]:=LineY[ActualPoint.Y]-1;
  216. MerkY:= ActualPoint.Y ;
  217. LineY[SearchPoint.Y]:=LineY[SearchPoint.Y]+1;
  218. end ;
  219. LineX[LineY[SearchPoint.Y],SearchPoint.Y]:=SearchPoint.X ;
  220. if SearchPoint.Y > Ymax then Ymax:= SearchPoint.Y ;
  221. Found:=true ;
  222. ActualPoint:=SearchPoint ;
  223. end;
  224. L:
  225. KK:=KK+1;
  226. if KK > 8 then
  227. begin
  228. Start:=true ;
  229. NotFound:=true ;
  230. end;
  231. end;
  232. until Found or (KK > 8);
  233. until Start ;
  234. if not NotFound then
  235. Fill(NextPoint.Y,Ymax,LastColor) ;
  236. until not BlackScan(NextPoint);
  237. end ;
  238. {------------------------------------------------------------------------------
  239. MAINROUTINE
  240. ------------------------------------------------------------------------------}
  241. var
  242. error : word;
  243. var neededtime,starttime : longint;
  244. hour, minute, second, sec100 : word;
  245. const
  246. {$ifdef win32}
  247. gmdefault : word = m640x480x16;
  248. {$else not win32}
  249. {$ifdef Linux}
  250. gmdefault : word = g640x480x256;
  251. {$else}
  252. gmdefault : word = m640x480x256;
  253. {$endif}
  254. {$endif win32}
  255. begin
  256. if paramcount>0 then
  257. begin
  258. val(paramstr(1),gm,error);
  259. if error<>0 then
  260. gm:=gmdefault;
  261. end
  262. else
  263. gm:=gmdefault;
  264. gd:=detect;
  265. GetTime(hour, minute, second, sec100);
  266. starttime:=((hour*60+minute)*60+second)*100+sec100;
  267. InitGraph(gd,gm,'');
  268. if GraphResult <> grOk then
  269. begin
  270. Writeln('Graph driver ',gd,' graph mode ',gm,' not supported');
  271. Halt(1);
  272. end;
  273. Max_X_Width:=GetMaxX;
  274. Max_y_Width:=GetMaxY;
  275. Max_Color:=GetMaxColor-1;
  276. ClearViewPort;
  277. x1:=-0.9;
  278. x2:= 2.2;
  279. y1:= 1.25;
  280. y2:=-1.25;
  281. zm:=90;
  282. dx:=(x1 - x2) / Max_X_Width ;
  283. dy:=(y1 - y2) / Max_Y_Width ;
  284. if abs(y1) = abs(y2) then
  285. begin
  286. SymetricCase:=true;
  287. Y_Width:=Max_Y_Width shr 1
  288. end
  289. else
  290. begin
  291. SymetricCase:=false;
  292. Y_Width:=Max_Y_Width;
  293. end;
  294. NextPoint.X:=0;
  295. NextPoint.Y:=0;
  296. LastColor:=CalcMandel(SearchPoint,zm);
  297. CalcBounds ;
  298. GetTime(hour, minute, second, sec100);
  299. neededtime:=((hour*60+minute)*60+second)*100+sec100-starttime;
  300. {$ifndef fpc_profile}
  301. readln;
  302. {$endif fpc_profile}
  303. CloseGraph;
  304. Writeln('Mandel took ',neededtime/100:0:3,' secs to generate mandel graph');
  305. Writeln('With graph driver ',gd,' and graph mode ',gm);
  306. end.
  307. {
  308. $Log$
  309. Revision 1.9 2000-02-22 03:43:55 alex
  310. fixed the warning
  311. Revision 1.8 2000/01/04 15:29:42 marco
  312. * fixed constants for graphmodes
  313. Revision 1.7 1999/12/22 14:36:07 jonas
  314. * changed type of max_color to word so it works now with 16bit color modes
  315. (thanks to Arjan van Dijk for noticing the problem)
  316. Revision 1.6 1999/12/14 22:59:52 pierre
  317. * adapted to new graph unit
  318. Revision 1.5 1999/05/27 21:36:33 peter
  319. * new demo's
  320. * fixed mandel for linux
  321. Revision 1.4 1998/12/20 22:22:10 peter
  322. * updates
  323. }