home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 220.lha / Tunnel / Tunnel.mod < prev    next >
Encoding:
Text File  |  1996-02-15  |  9.8 KB  |  340 lines
  1. (*$T-  note: some progs (not this one) won't run properly like this; TDI to blame: type conversion problems *)
  2. (*$S- *)
  3. MODULE Tunnel;
  4.  
  5. (* Not Just another cute demo of Amiga graphics and menus, etc.
  6.    the code is not optimised; the doloop cycles could have been much more
  7.    compact with a procedure but who cares! Just watch the output like
  8.    everybody else.
  9.  
  10.    Created: 17/2/88 by Garth Thornton
  11.    
  12.    Modified: 27/2/88
  13.  
  14. Copyright (c) 1988 by Garth Thornton
  15.  
  16. This program can be freely copied, but please
  17. leave my name in. Thanks, Garth.
  18.  
  19. *)
  20. FROM SYSTEM    IMPORT ADR, BYTE, ADDRESS, SETREG, NULL, WORD;
  21. FROM WBStart IMPORT GetWBStartUpMsg, ReturnWBStartUpMsg;
  22. FROM Intuition IMPORT IntuitionName, IntuitionBase, WindowPtr, ScreenPtr,
  23.      CurrentTime, IntuiMessagePtr, IDCMPFlags, IDCMPFlagSet;
  24. FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase, Jam1,
  25.      DrawingModeSet, PlanePtr;
  26. FROM Pens IMPORT SetAPen, SetDrMd, RectFill;
  27. FROM Libraries  IMPORT OpenLibrary, CloseLibrary;
  28. FROM Windows IMPORT CloseWindow;
  29. FROM Ports      IMPORT ReplyMsg, MessagePtr, GetMsg;
  30. FROM Screens    IMPORT CloseScreen, ShowTitle;
  31. FROM Areas IMPORT AreaInfo, InitArea, AreaEllipse, AreaEnd;
  32. FROM Rasters IMPORT RastPort, RastPortPtr, TmpRas, InitTmpRas, AllocRaster,
  33.      FreeRaster;
  34. FROM Views IMPORT ModeSet ;
  35. FROM Colors IMPORT LoadRGB4 ;
  36. FROM RandomNumbers IMPORT Random, Seed;
  37. FROM MathLib0 IMPORT power, entier;
  38. FROM InOut IMPORT WriteString, WriteLn;
  39.  
  40. (* The modules below are home grown, or borrowed etc *)
  41. FROM TunnelMenu IMPORT ConnectMenu, DisconnectMenu, TunMenuType,
  42.                        ActionItemType, ViewItemType, PatternItemType,
  43.        StyleItemType;
  44. FROM MyScreen IMPORT SetUpScreen, MyIDCMPFlagSet;
  45. FROM TunInfo IMPORT ShowTunInfo, InitTunInfo;
  46. FROM DecodeMenu IMPORT MenuNull, MenuNumber, ItemNumber;
  47. (* theres a TDI module that does these now.. *)
  48.  
  49. CONST
  50.   depth = 5;
  51.   width = 320;
  52.   height = 200;
  53.   IntuitionRev = 0;
  54.   Maxdelay = 3000;
  55.   Mindelay = 100;
  56.  
  57.  
  58. VAR
  59.   wp : WindowPtr;
  60.   sp : ScreenPtr;
  61.   ColourTable : ARRAY [0..31] OF CARDINAL;
  62.   wbmsg : ADDRESS;
  63.  
  64.   areabuffer: ARRAY [0..799] OF WORD;
  65.   AI: AreaInfo;
  66.   AP: LONGINT;
  67.   TR: TmpRas;
  68.   TRplane: PlanePtr;
  69.   RP: RastPortPtr;
  70.  
  71.   (* These variables hold the state of things *)
  72.      Patt  : CARDINAL;
  73.      RGBFold, SpeedLk, Forward : BOOLEAN;
  74.       
  75.  
  76.  
  77. (* ++++++++++++++++++++++++++++++++++ *)
  78. PROCEDURE OpenLibraries () : BOOLEAN;
  79.   BEGIN
  80.     (* Open intuition library *)
  81.     IntuitionBase := OpenLibrary (IntuitionName,IntuitionRev);
  82.     IF IntuitionBase = 0 THEN
  83.       WriteString ("Open intuition failed"); WriteLn;
  84.       RETURN FALSE
  85.     END;
  86.     (* Now open the graphics library *)
  87.     GraphicsBase := OpenLibrary (GraphicsName, 0);
  88.     IF GraphicsBase = 0 THEN 
  89.       WriteString ("Open of graphics library failed "); WriteLn;
  90.       RETURN FALSE 
  91.     END;
  92.     RETURN TRUE
  93.   END OpenLibraries;
  94.  
  95. (* ++++++++++++++++++++++++++++++++++++ *)
  96. PROCEDURE ProcessMenuRequest (code : CARDINAL; VAR quit : BOOLEAN);
  97.   VAR
  98.     menu, item : CARDINAL;
  99.  
  100.   BEGIN
  101.     menu := MenuNumber (code); item := ItemNumber (code);
  102.     CASE TunMenuType (menu) OF
  103.       Actions:
  104.         CASE ActionItemType (item) OF
  105.           HideTitle:   ShowTitle (sp, FALSE);  |
  106.            UnHideTitle: ShowTitle (sp, TRUE);  |
  107.             AboutTunnel: ShowTunInfo (wp);  |
  108.              QuitTunnel:  quit := TRUE
  109.          END;
  110.                  |
  111.       View:
  112.         CASE ViewItemType (item) OF
  113.           Front:  Forward := TRUE;|
  114.           Rear:   Forward := FALSE;
  115.         END;
  116.                  |
  117.       Pattern:
  118.         CASE PatternItemType (item) OF
  119.           Single:  Patt:=1; |
  120.           Double:  Patt:=2; |
  121.           Reverse: Patt:=3; |
  122.         END;
  123.                  |
  124.       Style:
  125.         CASE StyleItemType (item) OF
  126.           RGBFoldover: RGBFold := TRUE;    |
  127.           RGBBounce:   RGBFold := FALSE;   |
  128.           Speedlocked: SpeedLk := TRUE;    |
  129.           Speedfree  : SpeedLk := FALSE;   |
  130.         END;
  131.     END;
  132.   END ProcessMenuRequest;
  133.  
  134.  
  135. (* ++++++++++++++++++++++++++++++++++++ *)
  136.  
  137.   VAR
  138.     MsgPtr : IntuiMessagePtr;
  139.     Quit   : BOOLEAN;
  140.     code   : CARDINAL;
  141.     class  : IDCMPFlagSet;
  142.  
  143.  
  144. PROCEDURE InitColourTable;
  145. VAR i: CARDINAL;
  146. BEGIN
  147.   FOR i := 0 TO 31 DO
  148.     ColourTable[i] := 0H; (*  black *)
  149.   END ;
  150.   LoadRGB4(ADR(sp^.VPort), ADR(ColourTable),32)
  151. END InitColourTable;
  152.  
  153.  
  154. VAR
  155.   i, j, count1, count2 : CARDINAL;
  156.   secs, mics : LONGCARD;
  157.   t1, t2, delay1, delay2, delinc1, delinc2 : INTEGER;
  158.   
  159.   h, v, colour1, colour2 : CARDINAL ;
  160.     rinc1,ginc1,binc1, red1, blue1, green1 : INTEGER ;
  161.     rinc2,ginc2,binc2, red2, blue2, green2 : INTEGER ;
  162.     rgb1, rgb2 : ARRAY [0..31] OF CARDINAL;
  163.  
  164.  
  165. PROCEDURE DoLoop1;
  166.  
  167. BEGIN
  168.   red1:=red1+rinc1;
  169.   IF (red1<1) OR (red1>318) THEN red1:=red1 DIV 319 * 319;
  170.     IF RGBFold AND (Random(100)<30) THEN red1:=319-red1;
  171.     ELSE rinc1:= INTEGER(Random(40)+1);
  172.        IF red1=319 THEN rinc1:=-rinc1 END;
  173.     END;
  174.   END;
  175.   blue1:=blue1+binc1;
  176.   IF (blue1<1) OR (blue1>318) THEN blue1:=blue1 DIV 319 * 319;
  177.     IF RGBFold AND (Random(100)<30) THEN blue1:=319-blue1;
  178.     ELSE binc1:= INTEGER(Random(40)+1);
  179.       IF blue1=319 THEN binc1:=-binc1 END;
  180.     END;
  181.   END;
  182.   green1:=green1+ginc1;
  183.   IF (green1<1) OR (green1>318) THEN green1:=green1 DIV 319 * 319;
  184.     IF RGBFold AND (Random(100)<30) THEN green1:=319-green1;
  185.     ELSE ginc1:= INTEGER(Random(40)+1);
  186.        IF green1=319 THEN ginc1:=-ginc1 END;
  187.     END;
  188.   END;
  189.   rgb1[count1]:= CARDINAL(red1 DIV 20 * 256 + green1 DIV 20 *16 + blue1 DIV 20);
  190.   IF Patt=1 THEN
  191.     count1:= (count1+1) MOD 32;
  192.     FOR i:=31 TO 0 BY -1 DO
  193.       IF Forward THEN j:=i ELSE j:=31-i END;
  194.       ColourTable[j]:= rgb1[(i+count1) MOD 32];
  195.     END;
  196.   ELSE
  197.     count1:= (count1+1) MOD 16;
  198.     FOR i:=31 TO 1 BY -2 DO
  199.       IF Forward THEN j:=i ELSE j:=32-i END;
  200.       ColourTable[j]:= rgb1[(i DIV 2 +count1) MOD 16];
  201.     END;
  202.   END;
  203.   LoadRGB4(ADR(sp^.VPort),ADR(ColourTable),32);
  204. END DoLoop1;
  205.  
  206. PROCEDURE DoLoop2;
  207.  
  208. BEGIN
  209.   red2:=red2+rinc2;
  210.   IF (red2<1) OR (red2>318) THEN red2:=red2 DIV 319 * 319;
  211.     IF RGBFold AND (Random(100)<30) THEN red2:=319-red2;
  212.     ELSE rinc2:= INTEGER(Random(40)+1);
  213.        IF red2=319 THEN rinc2:=-rinc2 END;
  214.     END;
  215.   END;
  216.   blue2:=blue2+binc2;
  217.   IF (blue2<1) OR (blue2>318) THEN blue2:=blue2 DIV 319 * 319;
  218.     IF RGBFold AND (Random(100)<30) THEN blue2:=319-blue2;
  219.     ELSE binc2:= INTEGER(Random(40)+1);
  220.       IF blue2=319 THEN binc2:=-binc2 END;
  221.     END;
  222.   END;
  223.   green2:=green2+ginc2;
  224.   IF (green2<1) OR (green2>318) THEN green2:=green2 DIV 319 * 319;
  225.     IF RGBFold AND (Random(100)<30) THEN green2:=319-green2;
  226.     ELSE ginc2:= INTEGER(Random(40)+1);
  227.        IF green2=319 THEN ginc2:=-ginc2 END;
  228.     END;
  229.   END;
  230.   rgb2[count2]:= CARDINAL(red2 DIV 20 * 256 + green2 DIV 20 *16 + blue2 DIV 20);
  231.   count2:= (count2+1) MOD 16;
  232.   FOR i:=30 TO 0 BY -2 DO
  233.     IF Patt=3 THEN
  234.       IF Forward THEN j:=30-i ELSE j:=i END;
  235.     ELSE 
  236.       IF Forward THEN j:=i ELSE j:=30-i END;
  237.     END;
  238.     ColourTable[j]:= rgb2[(i DIV 2 +count2) MOD 16];
  239.   END;
  240.   LoadRGB4(ADR(sp^.VPort),ADR(ColourTable),32);
  241. END DoLoop2;
  242.  
  243.  
  244. BEGIN  (* main *)
  245.   wbmsg := GetWBStartUpMsg();
  246.   IF OpenLibraries () THEN  
  247.     InitTunInfo ();
  248.  
  249.     Quit := FALSE;
  250.     (* Initialize state variables *)
  251.     RGBFold := FALSE;
  252.     SpeedLk := TRUE;
  253.     Patt := 1;
  254.     Forward := TRUE;
  255.  
  256.     CurrentTime(ADR(secs),ADR(mics));
  257.     Seed(secs + mics);
  258.     MyIDCMPFlagSet := IDCMPFlagSet{MenuPick};
  259.     SetUpScreen (wp, sp, width, height, depth, ModeSet{});
  260.     RP := wp^.RPort;
  261.     SetDrMd(RP, Jam1);
  262.     InitArea(AI,areabuffer,SIZE(areabuffer));
  263.     TRplane := AllocRaster(width,height);
  264.     IF TRplane # 0 THEN
  265.       AP := -1 ;
  266.       InitTmpRas(ADR(TR),TRplane,width DIV 16 * height);
  267.       WITH RP^ DO
  268.         areaInfo := ADR(AI);
  269.         AreaPtrn := ADR(AP);
  270.         AreaPtSz := BYTE(1);
  271.         tmpRas := ADR(TR);
  272.       END;
  273.       InitColourTable ;
  274.       (* Attach menu to the window *)
  275.       ConnectMenu (wp);
  276.       (* set up tunnel graphix  *)
  277.       SetAPen(RP,0);
  278.       RectFill(RP,0,0,319,199);
  279.       FOR i:= 30 TO 0 BY -1 DO
  280.         SetAPen(RP,31-i);
  281.         h:= (i*i + i*17) DIV 10 + 1;  IF i>26 THEN h:=h+(i-26)*(i-26) END;
  282.         v:= (i*i*7 +i*110) DIV 100 + 1;
  283.         IF AreaEllipse(RP,160,100,h,v) THEN END ;
  284.         AreaEnd(RP)
  285.       END ;
  286.       (* init loop vars  *)
  287.         count1:=0;   count2:=0;
  288.         rinc1:=INTEGER(Random(5)+1);  binc1:=INTEGER(Random(5)+1);
  289.         ginc1:=INTEGER(Random(5)+1);
  290.         red1:=0;  green1:=0;  blue1:=0;
  291.         rinc2:=INTEGER(Random(5)+1);  binc2:=INTEGER(Random(5)+1);
  292.         ginc2:=INTEGER(Random(5)+1);
  293.         red2:=0;  green2:=0;  blue2:=0;
  294.         delay1:=Maxdelay;    delay2:= Mindelay;
  295.         delinc1:=-10;   delinc2:=-5;
  296.       t1:=0; t2:=0;
  297.    (* THE loop!  *)
  298.       REPEAT
  299.         INC(t1);   INC(t2);
  300.         IF t1 > delay1 THEN
  301.           (* see if menu picked  *)
  302.           MsgPtr := GetMsg(wp^.UserPort);     
  303.           IF MsgPtr <> NULL THEN
  304.             class := MsgPtr^.Class; code := MsgPtr^.Code;
  305.             ReplyMsg (MessagePtr(MsgPtr));
  306.             IF (class = IDCMPFlagSet {MenuPick}) AND (code <> MenuNull)
  307.               THEN ProcessMenuRequest (code, Quit) 
  308.             END;
  309.           END;
  310.           t1 := 0;
  311.           DoLoop1;
  312.           delay1 := delay1 + delinc1;
  313.           IF delay1 > Maxdelay THEN delinc1:= -(5 + INTEGER(Random(20)))
  314.           ELSIF delay1 < Mindelay THEN delinc1:= (5 + INTEGER(Random(20)))
  315.           END;
  316.         END;
  317.         IF Patt > 1 THEN
  318.           IF SpeedLk AND (t1=0) THEN DoLoop2;
  319.           ELSIF t2 > delay2 THEN
  320.             t2 := 0;
  321.             DoLoop2;
  322.             delay2 := delay2 + delinc2;
  323.             IF delay2 > Maxdelay THEN delinc2:= -(5 + INTEGER(Random(20)))
  324.             ELSIF delay2 < Mindelay THEN delinc2:= (5 + INTEGER(Random(20)))
  325.             END;
  326.           END;
  327.         END;
  328.       UNTIL Quit;
  329.  
  330.       DisconnectMenu (wp);
  331.       (* Close the window and screen  *)
  332.       CloseWindow (wp);
  333.       CloseScreen (sp);
  334.       FreeRaster(TRplane,width,height);
  335.     END;
  336.   END; (* IF *)
  337.   ReturnWBStartUpMsg;
  338. END Tunnel.
  339.  
  340.