home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / gfx / misc / cloudsaga / source / clouds.mod < prev    next >
Encoding:
Text File  |  1994-07-18  |  14.1 KB  |  462 lines
  1. (*---------------------------------------------------------------------------
  2.     :Program.    CloudsAGA.mod
  3.     :Author.     Daniel Amor
  4.     :Address.    Ludwigstr. 124, D-70197 Stuttgart
  5.     :Shortcut.   [da]
  6.     :Version.    1.15
  7.     :Date.       31-May-94
  8.     :Copyright.  PD
  9.     :Language.   Oberon-2
  10.     :Translator. Amiga Oberon 3.0
  11.     :Imports.    Clouds [da].
  12.     :Contents.   Erzeugt Fraktal-Wolken.
  13.     :Remark.     Aufruf: Clouds
  14. ---------------------------------------------------------------------------*)
  15.  
  16. MODULE Clouds;
  17.  
  18. (* $OvflChk- $RangeChk- $StackChk- $NilChk- $ReturnChk- $CaseChk- $TypeChk- *)
  19.  
  20. IMPORT  e    : Exec,
  21.         d    : Dos,
  22.         I    : Intuition,
  23.         gt   : GadTools,
  24.         g    : Graphics,
  25.         req  : Requests,
  26.         GUI  : CloudsGUI,
  27.         u    : Utility,
  28.         r    : Random,
  29.         y    : SYSTEM,
  30.         pal  : Palette,
  31.         str  : Strings,IFF,ASL;
  32.  
  33. CONST UntereFarbe   = 4;
  34.  
  35. VAR quit,open,gOK                 : BOOLEAN;
  36.     msgptr,msgptr1,msgptr2        : I.IntuiMessagePtr;
  37.     msg,msg1,msg2                 : I.IntuiMessage;
  38.     item1,item2                   : I.MenuItemPtr;
  39.     aktgad1,aktgad2               : I.GadgetPtr;
  40.     vp                            : g.ViewPortPtr;
  41.     nummer,farbe,na,fonty,size,version    : INTEGER;
  42.     win                           : I.WindowPtr;
  43.     depth,resx,resy               : LONGINT;
  44.     key                           : CHAR;
  45.     wx,wy,ObereFarbe,MittlereFarbe: INTEGER;
  46.     VERSION                       : ARRAY 90 OF CHAR;
  47.     Col                           : pal.colourRecord;
  48.  
  49. PROCEDURE FileReq(hail: ARRAY OF CHAR; VAR name: ARRAY OF CHAR; win : I.WindowPtr): BOOLEAN;
  50.  
  51. VAR i,j       : INTEGER;
  52.     Dirname   : ARRAY 256 OF CHAR;
  53.     Filename  : ARRAY 356 OF CHAR;
  54.     flags     : LONGINT;
  55.     res       : BOOLEAN;
  56.     fr        : ASL.FileRequesterPtr;
  57.     pattern   : ARRAY 80 OF CHAR;
  58.  
  59. BEGIN
  60.   j := SHORT(str.Length(name));
  61.   WHILE (j>=0) & (name[j]#":") & (name[j]#"/") DO DEC(j) END;
  62.   i := 0;
  63.   WHILE i<=j DO Dirname[i] := name[i]; INC(i) END; Dirname[i] := 0X;
  64.   j := 0;
  65.   REPEAT Filename[j] := name[i]; INC(j); INC(i) UNTIL name[i-1]=0X;
  66.   fr := ASL.AllocAslRequestTags(ASL.fileRequest, u.done);
  67.   IF fr=NIL THEN HALT(20) END;
  68.   flags := ASH(1,ASL.patGad);
  69.   INC(flags,ASH(1,ASL.save));
  70.   res := ASL.AslRequestTags(fr, ASL.hail,     y.ADR(hail),
  71.                                 ASL.file,     y.ADR(Filename),
  72.                                 ASL.dir,      y.ADR(Dirname),
  73.                                 ASL.window,   win,
  74.                                 ASL.pattern,  y.ADR(pattern),
  75.                                 ASL.funcFlags,flags,
  76.                                 u.done);
  77.   COPY(fr.dir^,Dirname);
  78.   COPY(fr.file^,Filename);
  79.  
  80.   i := SHORT(str.Length(Dirname));
  81.   IF (i>0) & (Dirname[i-1]#"/") & (Dirname[i-1]#":") THEN
  82.     Dirname[i] := "/"; INC(i);
  83.     Dirname[i] := 0X;
  84.   END;
  85.   IF LEN(name)>i+str.Length(Filename) THEN
  86.     COPY(Dirname,name);
  87.     str.Append(name,Filename);
  88.     RETURN TRUE;
  89.   END;
  90.   RETURN FALSE;
  91. END FileReq;
  92.  
  93. PROCEDURE OpenWindow (left,top,width,height: LONGINT; VAR win: I.WindowPtr);
  94.  
  95. VAR quit: BOOLEAN;
  96.  
  97. BEGIN
  98.   IF height<resy-GUI.FontY THEN top:=GUI.FontY+3 END;
  99.   win := I.OpenWindowTagsA ( NIL,
  100.                     I.waLeft,          left,
  101.                     I.waTop,           top,
  102.                     I.waWidth,         width,
  103.                     I.waHeight,        height,
  104.                     I.waIDCMP,         LONGSET {I.closeWindow,I.refreshWindow,I.vanillaKey,I.menuPick},
  105.                     I.waFlags,         LONGSET {I.windowDrag,I.windowDepth,I.windowClose,I.activate,I.newLookMenus},
  106.                     I.waTitle,         y.ADR ("Generating..."),
  107.                     I.waScreenTitle,   y.ADR ("CloudsAGA 1.15 © Danny Amor in 1994"),
  108.                     I.waPubScreen,     GUI.Scr,
  109.                     I.waMinWidth,      67,
  110.                     I.waMinHeight,     21,
  111.                     I.waMaxWidth,      656,
  112.                     I.waMaxHeight,     414, u.done);
  113.  
  114.   gt.RefreshWindow (win, NIL);
  115. END OpenWindow;
  116.  
  117. PROCEDURE CloseWindow (VAR win: I.WindowPtr);
  118.  
  119. BEGIN
  120.   IF win # NIL THEN
  121.     I.CloseWindow (win);
  122.     win := NIL;
  123.   END;
  124. END CloseWindow;
  125.  
  126. PROCEDURE TestF(VAR farbe: INTEGER);
  127.  
  128. BEGIN
  129.   IF farbe>ObereFarbe  THEN farbe:=ObereFarbe;  END;
  130.   IF farbe<UntereFarbe THEN farbe:=UntereFarbe; END;
  131. END TestF;
  132.  
  133. PROCEDURE RandomFarbe(VAR Rp: g.RastPortPtr; Start: INTEGER; VAR mf: REAL; x,y: INTEGER);
  134.  
  135. VAR farbe: INTEGER;
  136.     OK   : BOOLEAN;
  137.  
  138. BEGIN
  139.   farbe:=SHORT(Start+SHORT(mf*(r.RND(1)*LONG(2)-1))+1);
  140.   TestF(farbe);
  141.   g.SetAPen(Rp,farbe);
  142.   OK:=g.WritePixel(Rp,x+4,y+fonty);
  143. END RandomFarbe;
  144.  
  145. PROCEDURE Cloud(numiter: INTEGER; mu: REAL; na: INTEGER);
  146.  
  147. TYPE Coord = ARRAY 11 OF INTEGER;
  148.  
  149. VAR i,j,k,l,x1,y1,x2,y2,x3,y3,smul1,smul2,p  : INTEGER;
  150.     xy                                       : Coord;
  151.     n,n1,farbe,nk,test,test2                 : INTEGER;
  152.     farbe1,farbe2,farbe3,farbe4              : LONGINT;
  153.     mf                                       : REAL;
  154.  
  155.   PROCEDURE BigPic(n,i: INTEGER; VAR n1,l: INTEGER);
  156.  
  157.   BEGIN
  158.    n1:=n DIV 2;
  159.    l:=y.LSH(LONG(1),i);
  160.   END BigPic;
  161.  
  162.   PROCEDURE SetEdge(VAR Rp: g.RastPortPtr; x1,y1,x2,y2,x3,y3: INTEGER; VAR mf: REAL);
  163.  
  164.   BEGIN
  165.     farbe1:=g.ReadPixel(Rp,x1+4,y1+fonty);
  166.     farbe2:=g.ReadPixel(Rp,x2+4,y2+fonty);
  167.     RandomFarbe(Rp,SHORT(farbe1+farbe2) DIV 2,mf,x3,y3);
  168.   END SetEdge;
  169.  
  170.  PROCEDURE SetPoint(VAR Rp: g.RastPortPtr; VAR mf: REAL; VAR xy: Coord);
  171.  
  172.   VAR a: BOOLEAN;
  173.  
  174.   BEGIN
  175.     farbe1:=g.ReadPixel(Rp,xy[1]+4,xy[2]+fonty);
  176.     farbe2:=g.ReadPixel(Rp,xy[3]+4,xy[4]+fonty);
  177.     farbe3:=g.ReadPixel(Rp,xy[5]+4,xy[6]+fonty);
  178.     farbe4:=g.ReadPixel(Rp,xy[7]+4,xy[8]+fonty);
  179.     farbe:=SHORT(((farbe1+farbe2+farbe3+farbe4) DIV 4)+SHORT(r.RND(2)*2*mf-mf));
  180.     TestF(farbe);
  181.     g.SetAPen(Rp,farbe);
  182.     a:=g.WritePixel(Rp,xy[9]+4,xy[10]+fonty);
  183.   END SetPoint;
  184.  
  185. BEGIN
  186.   mf:=(numiter+1)*mu;
  187.   RandomFarbe(win^.rPort,MittlereFarbe,mf,0,  0);
  188.   RandomFarbe(win^.rPort,MittlereFarbe,mf,0, na);
  189.   RandomFarbe(win^.rPort,MittlereFarbe,mf,na, 0);
  190.   RandomFarbe(win^.rPort,MittlereFarbe,mf,na,na);
  191.   n:=na;
  192.   test:=1;
  193.   FOR i:=0 TO numiter DO
  194.     mf:=(numiter-i+1)*mu;
  195.     BigPic(n,i,n1,l);
  196.     FOR j:=1 TO l DO
  197.       smul1:=(j-1)*n;
  198.       smul2:=j*n;
  199.       SetEdge(win^.rPort,smul1,0    ,smul2,0    ,smul2-n1,0       ,mf);
  200.       SetEdge(win^.rPort,smul1,na   ,smul2,na   ,smul2-n1,na      ,mf);
  201.       SetEdge(win^.rPort,0    ,smul1,0    ,smul2,0       ,smul2-n1,mf);
  202.       SetEdge(win^.rPort,na   ,smul1,na   ,smul2,na      ,smul2-n1,mf);
  203.     END;
  204.     n:=n1;
  205.   END;
  206.   n:=na;
  207.   FOR i:=0 TO numiter DO
  208.     mf:=(numiter-i+1)*mu;
  209.     BigPic(n,i,n1,l);
  210.     FOR k:=1 TO l DO
  211.       FOR j:=1 TO l DO
  212.         smul1:=k*n;   smul2:=j*n;
  213.         xy[1]:=smul2-n; xy[2]:=smul1-n; xy[3]:=smul2-n;
  214.         xy[4]:=smul1  ; xy[5]:=smul2  ; xy[6]:=smul1-n;
  215.         xy[7]:=smul2  ; xy[8]:=smul1  ; xy[9]:=smul2-n1;
  216.         xy[10]:=smul1-n1;
  217.         SetPoint(win^.rPort,mf,xy);
  218.       END;
  219.     END;
  220.     nk:=0;
  221.     FOR k:=1 TO test DO
  222.       nk:=1-nk;
  223.       test2:=y.LSH(LONG(1),i)-nk;
  224.       FOR j:=1 TO test2 DO
  225.         smul1:=j*n+nk*n1;   smul2:=k*n1;
  226.         xy[1]:=smul1-n1; xy[2]:=smul2-n1; xy[3]:=smul1;
  227.         xy[4]:=smul2   ; xy[5]:=smul1-n1; xy[6]:=smul2+n1;
  228.         xy[7]:=smul1-n ; xy[8]:=smul2   ; xy[9]:=smul1-n1;
  229.         xy[10]:=smul2;
  230.         SetPoint(win^.rPort,mf,xy);
  231.       END;
  232.     END;
  233.     n:=n1;
  234.     test:=((test+1)*2)-1;
  235.   END;
  236.   I.SetWindowTitles(win,y.ADR("OK!"),y.ADR("CloudsAGA 1.15 © Danny Amor in 1994"));
  237. END Cloud;
  238.  
  239. PROCEDURE SizeOut(VAR na: INTEGER; faktor,size: INTEGER);
  240.  
  241. VAR numiter: INTEGER;
  242.     mu     : REAL;
  243.  
  244. BEGIN
  245.   numiter:=size+5;
  246.   faktor:=size+2;
  247.   na:=y.LSH(LONG(64),size);
  248.   mu:=2.5-faktor/5;
  249.   Cloud(numiter,mu,na);
  250. END SizeOut;
  251.  
  252. PROCEDURE Smooth(VAR na: INTEGER);
  253.  
  254. VAR y1,x,farbe                 : INTEGER;
  255.     a                          : BOOLEAN;
  256.     farbe1,farbe2,farbe3,farbe4: LONGINT;
  257.  
  258. BEGIN
  259.   I.SetWindowTitles(win,y.ADR("Smoothing..."),y.ADR("CloudsAGA 1.15 © Danny Amor in 1994"));
  260.   FOR y1:=0 TO na-1 DO
  261.     FOR x:=0 TO na-1 DO
  262.       farbe1:=g.ReadPixel(win^.rPort,x+4,y1+fonty);
  263.       farbe2:=g.ReadPixel(win^.rPort,x+5,y1+fonty);
  264.       farbe3:=g.ReadPixel(win^.rPort,x+4,y1+1+fonty);
  265.       farbe4:=g.ReadPixel(win^.rPort,x+5,y1+1+fonty);
  266.       farbe :=SHORT(SHORT((farbe1+farbe2+farbe3+farbe4)/4));
  267.       g.SetAPen(win^.rPort,farbe);
  268.       a:=g.WritePixel(win^.rPort,x+4,y1+fonty);
  269.     END;
  270.   END;
  271.   I.SetWindowTitles(win,y.ADR("OK!"),y.ADR("CloudsAGA 1.15 © Danny Amor in 1994"));
  272. END Smooth;
  273.  
  274. PROCEDURE SetColors(VAR vp: g.ViewPortPtr);
  275.  
  276. VAR i: INTEGER;
  277.  
  278. BEGIN
  279.   g.SetRGB4(vp,0,10,10,10);
  280.   g.SetRGB4(vp,1,0,0,0);
  281.   g.SetRGB4(vp,2,15,15,15);
  282.   g.SetRGB4(vp,3,6,8,11);
  283.   IF version<39 THEN
  284.     FOR i:= 4 TO 19 DO g.SetRGB4(vp,i,i-4,i-4,15); END;
  285.     g.SetRGB4(vp,20,11,11,11);
  286.     FOR i:=21 TO 31 DO g.SetRGB4(vp,i,(i DIV 2)-1,(i DIV 2)-1,(i DIV 2)); END;
  287.   END;
  288. END SetColors;
  289.  
  290. PROCEDURE ClickNull(VAR size: INTEGER);
  291.  
  292. BEGIN
  293.   INC(size);
  294.   IF size>5 THEN size:=0; END;
  295.   gt.SetGadgetAttrs(GUI.CloudsGadgets[0]^,GUI.CloudsWnd,NIL,gt.cyActive,size);
  296. END ClickNull;
  297.  
  298. PROCEDURE ClickOne(VAR x,y1: INTEGER);
  299.  
  300. BEGIN
  301.   x:=y.LSH(LONG(64),size);
  302.   y1:=x;
  303.   x:=x+10;
  304.   y1:=y1+fonty+4;
  305.   OpenWindow(0,0,x,y1,win);
  306.   open:=TRUE;
  307.   I.WindowToFront(GUI.CloudsWnd);
  308.   SizeOut(na,4,size);
  309. END ClickOne;
  310.  
  311. PROCEDURE ClickFour(x,y1: INTEGER);
  312.  
  313. VAR Ok   : BOOLEAN;
  314.     Name : ARRAY 80 OF CHAR;
  315.     xm,ym: LONGINT;
  316.  
  317. BEGIN
  318.   Name:="RAM:Clouds_1.IFF";
  319.   Ok:=FileReq("Save Clouds as...",Name,win);
  320.   IF Ok THEN
  321.     I.SetWindowTitles(win,y.ADR("Saving..."),y.ADR("CloudsAGA 1.15 © Danny Amor in 1994"));
  322.     I.WindowToBack(GUI.CloudsWnd);
  323.     xm:=win^.leftEdge DIV 8+(x DIV 8)+1;
  324.     ym:=win^.topEdge+y1;
  325.     IF xm>resx THEN xm:=(x DIV 8)+1-(xm-resx); END;
  326.     IF ym>resy THEN ym:=y1-(ym-resy); END;
  327.     req.Assert(IFF.SaveClip(y.ADR(Name),win^.rPort.bitMap,win^.wScreen^.viewPort.colorMap.colorTable,1,win^.leftEdge DIV 8,win^.topEdge,xm,ym),"Couldn't save picture!");
  328.     I.WindowToFront(GUI.CloudsWnd);
  329.     I.SetWindowTitles(win,y.ADR("OK!"),y.ADR("CloudsAGA 1.15 © Danny Amor in 1994"));
  330.   END;
  331. END ClickFour;
  332.  
  333. PROCEDURE DoColours;
  334.  
  335. BEGIN
  336.   ObereFarbe:=y.LSH(LONG(1),depth)-1;
  337.   MittlereFarbe:=(ObereFarbe DIV 2)+SHORT(depth);
  338. END DoColours;
  339.  
  340. PROCEDURE ClickFive(VAR vp: g.ViewPortPtr);
  341.  
  342. VAR doit: BOOLEAN;
  343.  
  344. BEGIN
  345.   doit:=TRUE;
  346.   IF open THEN doit:=req.Request("Change Screenmode:","Do you want to restart with another\nresolution (this pic will be killed)?","OK","Cancel"); END;
  347.   IF doit THEN
  348.     CloseWindow(win);
  349.     GUI.CloseCloudsWindow(GUI.CloudsWnd);
  350.     GUI.CloseDownScreen(GUI.Scr);
  351.     req.Assert(GUI.SetupScreen(depth,resx,resy)=0,"Unable to open screen!");
  352.     Col.AGACol[0]:=NIL;
  353.     DoColours;
  354.     vp:=y.ADR(GUI.Scr^.viewPort);
  355.     fonty:=GUI.FontY+3;
  356.     SetColors(vp);
  357.     size:=0;
  358.     req.Assert(GUI.OpenCloudsWindow(GUI.CloudsWnd,GUI.Scr)=0,"Unable to open window!");
  359.     open      := FALSE;
  360.     quit      := FALSE;
  361.   END;
  362. END ClickFive;
  363.  
  364. PROCEDURE WaitUntilClosedInfo;
  365.  
  366. VAR msg: I.IntuiMessagePtr;
  367.  
  368. BEGIN
  369.   e.WaitPort(GUI.InfoReqWnd.userPort);
  370.   msg:=e.GetMsg(GUI.InfoReqWnd.userPort);
  371.   e.ReplyMsg(msg);
  372.   GUI.CloseInfoReqWindow;
  373. END WaitUntilClosedInfo;
  374.  
  375. PROCEDURE CheckKey(code: INTEGER);
  376.  
  377. VAR key: CHAR;
  378.  
  379. BEGIN
  380.   key:=CAP(CHR(code));
  381.   IF  key="Z"                 THEN ClickNull(size);   END;
  382.   IF (key="C") AND (NOT open) THEN ClickOne(wx,wy);   END;
  383.   IF  key="P"                 THEN pal.ShowPalette(GUI.Scr,Col,4); END;
  384.   IF (key="M") AND open       THEN Smooth(na); END;
  385.   IF (key="S") AND open       THEN ClickFour(wx,wy);  END;
  386.   IF  key="R"                 THEN ClickFive(vp);     END;
  387. END CheckKey;
  388.  
  389. BEGIN
  390.   VERSION := "$VER: CloudsAGA 1.15 (31.05.94) by Daniel Amor, Ludwigstr. 124, 70197 Stuttgart, Germany";
  391.   version := g.gfx.libNode.version;
  392.   depth   := 5;
  393.   req.Assert (GUI.SetupScreen(depth,resx,resy) = 0, "Unable to open screen!");
  394.   req.Assert (GUI.OpenCloudsWindow(GUI.CloudsWnd,GUI.Scr) = 0, "Unable to open window!");
  395.   quit    := FALSE;
  396.   open    := FALSE;
  397.   DoColours;
  398.   vp:=y.ADR(GUI.Scr^.viewPort);
  399.   SetColors(vp);
  400.   fonty:=GUI.FontY+3;
  401.   size:=0;
  402.   REPEAT
  403.     IF open THEN
  404.       quit := (d.ctrlC IN e.Wait (LONGSET {GUI.CloudsWnd.userPort.sigBit,
  405.                                            win.userPort.sigBit,
  406.                                            d.ctrlC}))
  407.     ELSE
  408.       quit := (d.ctrlC IN e.Wait (LONGSET {GUI.CloudsWnd.userPort.sigBit,
  409.                                            d.ctrlC}));
  410.     END;
  411.     msgptr1 := gt.GetIMsg (GUI.CloudsWnd.userPort);
  412.     IF msgptr1 # NIL THEN
  413.       msg1 := msgptr1^;
  414.       gt.ReplyIMsg (msgptr1);
  415.  
  416.       IF (I.closeWindow IN msg1.class) THEN
  417.         quit := req.RequestWin("Clouds Requester","Do you really want to quit?","Yes","No",GUI.CloudsWnd);
  418.       END;
  419.       IF (I.gadgetUp IN msg1.class) THEN
  420.         aktgad1:=msg1.iAddress;
  421.         nummer:=aktgad1.gadgetID;
  422.         IF  nummer=GUI.GDSize                   THEN size:=msg1.code; END;
  423.         IF (nummer=GUI.GDCreate) AND (NOT open) THEN ClickOne(wx,wy);  END;
  424.         IF  nummer=GUI.GDAnimate                THEN pal.ShowPalette(GUI.Scr,Col,4); END;
  425.         IF (nummer=GUI.GDSmooth) AND open       THEN Smooth(na); END;
  426.         IF (nummer=GUI.GDSave) AND open         THEN ClickFour(wx,wy); END;
  427.         IF  nummer=GUI.GDScreen                 THEN ClickFive(vp); END;
  428.       END;
  429.       IF (I.vanillaKey IN msg1.class) THEN CheckKey(msg1.code); END;
  430.       IF (I.menuPick IN msg1.class) THEN
  431.         IF I.MenuNum(msg1.code)=0 THEN
  432.           IF I.ItemNum(msg1.code)=0 THEN
  433.             req.Assert(GUI.OpenInfoReqWindow()=0, "Unable to open Info-Requester!");
  434.             WaitUntilClosedInfo;
  435.           END;
  436.           IF I.ItemNum(msg1.code)=2 THEN
  437.             quit := req.RequestWin("Clouds Requester","Do you really want to quit?","Yes","No",GUI.CloudsWnd);
  438.           END;
  439.         END;
  440.       END;
  441.     ELSE
  442.       IF NOT quit THEN
  443.         msgptr2 := gt.GetIMsg (win.userPort);
  444.         IF msgptr2 # NIL THEN
  445.           msg2 := msgptr2^;
  446.           gt.ReplyIMsg (msgptr2);
  447.  
  448.           IF (I.vanillaKey IN msg2.class) THEN CheckKey(msg2.code); END;
  449.           IF (I.closeWindow IN msg2.class) THEN
  450.             CloseWindow(win);
  451.             open := FALSE;
  452.           END;
  453.         END;
  454.       END;
  455.     END;
  456.   UNTIL quit;
  457. CLOSE
  458.   CloseWindow(win);
  459.   GUI.CloseCloudsWindow(GUI.CloudsWnd);
  460.   GUI.CloseDownScreen(GUI.Scr);
  461. END Clouds.
  462.