Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/mcgatpu/apfemcga.pas

Pascal/Delphi Source File | 1991-05-25 | 4.3 KB | 199 lines

program apfel;
       {Apelmänchen Routine für TURBO PASCAL
    Aus:
         CHIP MAGAZIN 1990 (Monat unbekannt )

         Modified by:

         STEVEN OF OZ
         DISASTER BBS  0211/683207   GERMANY GILBNET

             Hardware required: MCGA / VGA - COLOR
         }


uses dos,crt,mcga;

const     stname='FRACTAL.GRA';
      name='ZOOMFRAC.GRA';
      cr=#13#10;

var
      xmax,xmin,ymax,ymin :real;
      xmaxt,xmint,ymaxt,ymint:real;
      xmaxtl,xmintl,ymaxtl,ymintl:real;
      tmax,yp,xp,x,y :integer;
      schritte,hg:byte;
      dx,dy,cy,cx,temp:real;
      ywa,yqa,yw,xw,xq,yq:real;
      regs:registers;
      xk,yk:Integer;
         ch:char;
        num:byte;
        newname,tempname:string;

procedure wait;
begin

 ch:=readkey;
 while keypressed do ch:=readkey
end;

procedure reset(ite:boolean);
begin
       tempname:=stname;
       xmax:= 2.0;  {Standart param.}
       xmin:=-1.5;
       ymax:= 2.1;
       ymin:=-2.1;
       if ite then tmax:=16;   {Iterationdepth}
       hg:=8       {Background color}
end;

procedure create;
label raus;
begin
      xk:=320;    {Video size of MCGA}
      yk:=200;

      dx:=(xmax-xmin)/xk;
      dy:=(ymax-ymin)/yk;
      cy:=ymax;

      for yp:=0 to yk do begin
       cx:=xmin;
       ywa:=0-cy;
       yqa:=ywa*ywa;
       for xp:=0 to xk do begin
    xw:=0-cx;
    yw:=ywa;
    xq:=xw*xw;
    yq:=yqa;
     for schritte:=1 to tmax do begin
      yw:=(yw+yw)*xw-cy;
      xw:=xq-yq-cx;
      xq:=xw*xw;
      yq:=yw*yw;
      if xq+yq>=8 then goto raus
     end;
     schritte:=hg;
  raus:  PrintPixelAt(Schritte,xp,yp);
     cx:=cx+dx
    end;
    if keypressed then begin
         setmode(text);
           xmax:=xmaxtl;
           xmin:=xmintl;
           ymax:=ymaxtl;
           ymin:=ymintl;
          exit end;
    cy:=cy-dy
       end
end;

begin
      clrscr;
      Reset(true);      {standart param}
      tempname:=stname;

  repeat
      Gotoxy(1,1);
      Writeln('Written by STEVEN OF OZ',cr,
          'Revised Version V1.2',cr,
          'DISASTER BBS 0211/686331 GILBNET GERMANY',cr,cr,
          '1. Load last fractal',cr,
          '2. ZOOM and SAVE',cr,
          '3. Iterationdepth/ Num of colors and repaint',cr,
          '4. RESET',cr,
          '5. Last data',cr,
          'e. Exit',cr,cr,
          'MEM : ',memavail,' required 128k ',cr,cr,
          'Current Data:',cr,
          'XMax: ',xmax:2:4,cr,
          'YMax: ',ymax:2:4,cr,
          'XMin: ',xmin:2:4,cr,
          'YMin: ',ymin:2:4,cr,
          'TMax: ',tmax,'            Iterationdepth/ Num of colors');
      Wait;

       case ch of
    '1': begin setmode(mcgam); load(name) ;wait;setmode(text) end;
    '2': begin
           num:=0;

           xmaxtl:=xmax;  {Merker}
           xmintl:=xmin;
           ymaxtl:=ymax;
           ymintl:=ymin;

           setmode(mcgam); {Grafikmodus setzen}
           load(tempname);

           GraphMouse;     {Mousepointer MCGA on}
           repeat
             Getmousepos(x,y,button);
                     dec(y,2);
             case button of
             left: begin    {Obere linke Ecke holen}
                 sound(440);
                 delay(100);
                 nosound;

                                  xmaxt:=xmin+((xmax-xmin)/639)*x;
                                  ymint:=ymin+((ymax-ymin)/199)*y
                end;
            right: begin    {Untere rechte Ecke holen}
                 sound(1000);
                 delay(100);
                 nosound;

                                  xmint:=xmin+((xmax-xmin)/639)*x;
                                  ymaxt:=ymin+((ymax-ymin)/199)*y
                end
           end;
                   if keypressed then ch:=readkey;

           until  ch=#27;

           xmax:=xmint;
           xmin:=xmaxt;
           ymax:=ymint;
           ymin:=ymaxt;

           HideMouse;
           create;
           if not(keypressed) then begin
                    save(name);
            wait;
            setmode(text);
                     if tempname<>name then tempname:=name
           end
                    else
                      if tempname=stname then reset(true)
         end;
    '3': begin
          clrscr;
          Write('Iterationstiefe/ Anzahl der Farben (16-255) : ');
          Readln(tmax);
          if (tmax>255) or (tmax<-1) then tmax:=16;
          clrscr;
          Setmode(mcgam);
          create;
          if not(keypressed) then begin
           save(name);
           wait;
           Setmode(text)
          end
         end;
    '4': reset(true);
        '5': begin
           xmax:=xmaxtl;
           xmin:=xmintl;
           ymax:=ymaxtl;
           ymin:=ymintl
         end
       end
   until ch ='e'
end.