home *** CD-ROM | disk | FTP | other *** search
/ 8bitfiles.net/archives / archives.tar / archives / genie-commodore-file-library / C128CPM / GRC128.ZIP / FRACTALS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-06-15  |  5.6 KB  |  272 lines
  1. program chaos;
  2.  
  3.     type
  4.          tsrec = record
  5.            xs:integer;
  6.            ys: integer;
  7.            xe:integer;
  8.            ye:integer;
  9.            car:array[1..8] of char;
  10.            linv:byte;
  11.            lover:byte
  12.          end;
  13.  
  14.  
  15.          nstr=record
  16.            xw:integer;
  17.            yw:integer;
  18.            xq:integer;
  19.            yq:integer;
  20.            wt:integer;
  21.            sinv:byte;
  22.            sover:byte
  23.           end;
  24.  
  25.          feld=array [1..4096] of byte;
  26.  
  27.          ttextrec = record
  28.             inv:integer;
  29.             offs:integer;
  30.             zeile:integer;
  31.             spalte:integer;
  32.             addr:integer
  33.           end;
  34.  
  35.         xrec = record
  36.            kx:integer;
  37.            ky:integer
  38.         end;
  39.  
  40.         xyz = array [1..8] of char;
  41.  
  42. var  ndd:nstr;
  43.      speicher:feld;
  44.      lrec:xrec;
  45.      textrec:ttextrec;
  46.      s,e:integer;
  47.      srec,erec:tsrec;
  48.      x,y:integer;
  49.      mytext:array [1..11] of char;
  50.      wxn,wyn,wxo,wyo,alfa : real;
  51.      wxp,wyp,wzaehler : integer;
  52.      ch : char;
  53.      wf : array [1..15] of real;
  54.      zx : byte;
  55.      modell,gen : integer;
  56.      win : real;
  57.  
  58. procedure GrFOn;
  59.    begin
  60.    bdos (153);
  61.    end;
  62.  
  63. procedure GrSOn;
  64.    begin
  65.    bdos (154);
  66.    end;
  67.  
  68. procedure GrFOff;
  69.    begin
  70.    bdos (155);
  71.    end;
  72.  
  73. procedure SetPix(xp,yp:integer);
  74.    begin
  75.    lrec.kx:=xp;lrec.ky:=yp;
  76.    bdos(156,addr(lrec))
  77.    end;
  78.  
  79. procedure EraPix (xp,yp:integer);
  80.     begin
  81.     lrec.kx:=xp;lrec.ky:=yp;
  82.     bdos(157,addr(lrec))
  83.     end;
  84.  
  85.  
  86. procedure ClrGr;
  87.     begin
  88.     bdos (158)
  89.     end;
  90.  
  91. procedure SaveWi(x1,y1,x2,y2:integer);
  92.     begin
  93.     ndd.xw:=x1;
  94.     ndd.yw:=y1;
  95.     ndd.xq:=x2;
  96.     ndd.yq:=y2;
  97.     ndd.wt:=addr(speicher);
  98.     bdos(159,addr(ndd))
  99.     end;
  100.  
  101.  
  102. procedure LoadWi(x1,y1,x2,y2:integer;inv:byte;over:byte);
  103.     begin
  104.     ndd.xw:=x1;
  105.     ndd.yw:=y1;
  106.     ndd.xq:=x2;
  107.     ndd.yq:=y2;
  108.     ndd.wt:=addr(speicher);
  109.     ndd.sinv:=inv;
  110.     ndd.sover:=over;
  111.     bdos(160,addr(ndd))
  112.     end;
  113.  
  114. procedure SaveFW (x1,y1,x2,y2:integer;xk:xyz);
  115.     begin
  116.     srec.xs:=x1;
  117.     srec.ys:=y1;
  118.     srec.xe:=x2;
  119.     srec.ye:=y2;
  120.     srec.car[1]:=xk[1];srec.car[2]:=xk[2];
  121.     srec.car[3]:=xk[3];srec.car[4]:=xk[4];
  122.     srec.car[5]:=xk[5];srec.car[6]:=xk[6];
  123.     srec.car[7]:=xk[7];srec.car[8]:=xk[8];
  124.     bdos(161,addr(srec))
  125.     end;
  126.  
  127. procedure LoadFW (x1,y1,x2,y2:integer;xk:xyz;inv:byte;over:byte);
  128.     begin
  129.     srec.xs:=x1;
  130.     srec.ys:=y1;
  131.     srec.xe:=x2;
  132.     srec.ye:=y2;
  133.     srec.car[1]:=xk[1];srec.car[2]:=xk[2];
  134.     srec.car[3]:=xk[3];srec.car[4]:=xk[4];
  135.     srec.car[5]:=xk[5];srec.car[6]:=xk[6];
  136.     srec.car[7]:=xk[7];srec.car[8]:=xk[8];
  137.     srec.linv:=inv;srec.lover:=over;
  138.     bdos(162,addr(srec))
  139.     end;
  140.  
  141. procedure GFtext (i,o,z,s,a :integer);
  142.     begin
  143.     textrec.inv:=i;
  144.     textrec.offs:=o;
  145.     textrec.spalte:=s;
  146.     textrec.zeile:=z;
  147.     textrec.addr:=a;
  148.     bdos(163,addr(textrec))
  149.    end;
  150.  
  151. procedure scrdump (i:integer);
  152.    begin
  153.    bdos (164,i)
  154.    end;
  155.  
  156. begin
  157. ClrScr;
  158. modell := 1;
  159. while (modell <> 0) do
  160. begin
  161. gotoxy(10,8);
  162. write('1   Henon    Model');
  163. gotoxy(10,10);
  164. write('2   Planet   Model');
  165. gotoxy(10,12);
  166. write('choose one  (1 oder 2 ,0 .. end) : ');
  167. read(modell);
  168. if (modell <> 0) then
  169. if (modell = 1) then
  170. begin
  171. ClrScr;
  172. gotoxy(10,8);
  173. write('angel  (44 - 295)     : ');
  174. repeat
  175.   read(win);
  176. until((win >=44) and (win <= 295.0));
  177. gotoxy(10,10);
  178. write('accuracy (50 - 32000 high values take a long time to finish ) : ');
  179. read(gen);
  180. GrSOn;
  181. ClrGr;
  182.  
  183.  
  184. mytext[1]:=CHR(12);
  185. mytext[2]:='H';
  186. mytext[3]:='e';
  187. mytext[4]:='n';
  188. mytext[5]:='o';
  189. mytext[6]:='n';
  190. mytext[7]:=' ';
  191. mytext[8]:='I';
  192. mytext[9]:='s';
  193. mytext[10]:='l';
  194. mytext[11]:='a';
  195. mytext[12]:='n';
  196. mytext[13]:='d';
  197. GFtext(1,0,2,15,addr(mytext));
  198. wf[1]:=0.05;wf[2]:=0.1;wf[3]:=0.12;wf[4]:=0.3;wf[5]:=0.4;wf[6]:=0.47;
  199. wf[7]:=0.55;wf[8]:=0.57;wf[9]:=0.59; wf [10]:=0.605;
  200. wf[11]:=0.62; wf[12]:=0.7;
  201. for zx:= 11 downto 1 do
  202.     begin
  203.     alfa:= (* 50.0; 0.7 *) (* 90.57; 0.7 *) (*66.00  0.7; 0.78; 0.82 *)
  204.       (* 92.0 0.62;*) (* 178.0; 0.7 *)
  205.      (* 192.0; 0.7 *) (* 210.0; *) win;
  206.     wxo:=wf[zx];wyo:=0.0;
  207.     wzaehler:=0;
  208.     alfa:=(3.141592653*2/360*alfa);
  209.     repeat
  210.         wxn:=wxo*cos(alfa)-(wyo-wxo*wxo)*sin(alfa);
  211.         wyn:=wxo*sin(alfa)+(wyo-wxo*wxo)*cos(alfa);
  212.         wzaehler:=wzaehler+1;
  213.         wxo:=wxn;wyo:=wyn;
  214.         wxp:=round(wxn * 310 + 320);wyp:=round(wyn * 90 + 100);
  215.         if wxp<=0 then wxp:=0;
  216.         if wxp>=639 then wxp:=639;
  217.         if wyp<=0 then wyp:=0;
  218.         if wyp>=199 then wyp:=199;
  219.         SetPix(wxp,wyp);
  220.     until (wzaehler > gen);
  221.     end;
  222. GrFOff;
  223. end
  224. else
  225.   begin
  226.  
  227.    wxo:=0.0;wyo:=0.0;
  228.    clrscr;gotoxy(10,10);
  229.    write('accuracy (50 - 32000 high values take a long time to finish )  : ');
  230.    read(gen);
  231.    wzaehler:=0;
  232.    GrSOn;
  233.    ClrGr;
  234.  
  235. mytext[1]:=CHR(18);
  236. mytext[2]:='s';
  237. mytext[3]:='t';
  238. mytext[4]:='r';
  239. mytext[5]:='a';
  240. mytext[6]:='n';
  241. mytext[7]:='g';
  242. mytext[8]:='e';
  243. mytext[9]:=' ';
  244. mytext[10]:='a';
  245. mytext[11]:='t';
  246. mytext[12]:='t';
  247. mytext[13]:='r';
  248. mytext[14]:='a';
  249. mytext[15]:='c';
  250. mytext[16]:='t';
  251. mytext[17]:='o';
  252. mytext[18]:='r';
  253. GFtext(1,0,14,15,addr(mytext));
  254.    repeat
  255.      wxn:=wyo+1-(1.4*wxo*wxo);
  256.      wyn:=0.3*wxo;
  257.      wzaehler:=wzaehler+1;
  258.      wxo:=wxn;wyo:=wyn;
  259.      wxp:=round(213.0*wxn+320.0);wyp:=round(211.0*wyn+100.0);
  260.      if wxp<1 then wxp:=1;
  261.      if wxp>635 then wxp:=635;
  262.      if wyp<1 then wyp:=1;
  263.      if wyp>195 then wyp:=195;
  264.      SetPix(wxp,wyp);
  265.    until (wzaehler>gen);
  266. GrFOff;
  267. end
  268. end
  269. end.
  270.  
  271.  
  272.