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