home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d0xx / d094 / modulatools.lha / ModulaTools / Examples / BigTest.mod < prev    next >
Encoding:
Text File  |  1987-08-23  |  11.9 KB  |  350 lines
  1. (******************************************************************************)
  2. (*                                                                            *)
  3. (*    I originally intended for this test to be another simple demonstration  *)
  4. (* of some of the features of ModulaTools. However, the versatility of the    *)
  5. (* module got the best of me, and I kept adding capabilities as I thought of  *)
  6. (* them. As a result, this may not seem as simple a demo as the others.       *)
  7. (*    Even so, an examination of the procedures below should illustrate the   *)
  8. (* ease in which new features may be added to your program. Trying to achieve *)
  9. (* the same functionality without ModulaTools would easily require several    *)
  10. (* times as much code as shown below, and it wouldn't include the protection  *)
  11. (* against illegal inputs that ModulaTools does. It's your choice...         *)
  12. (*                                                                            *)
  13. (******************************************************************************)
  14.  
  15. MODULE Test;
  16.  
  17. FROM DiskFontLibrary IMPORT AvailFontsHeader, AvailFontsHeaderPtr, AvailFont,
  18.                             OpenDiskFont;
  19. FROM GraphicsLibrary IMPORT Jam1, DrawingModes, DrawingModeSet;
  20. FROM InOut           IMPORT Read, Write, WriteInt, WriteString, WriteLn;
  21. FROM Intuition       IMPORT ScreenPtr, MenuFlags, MenuFlagSet, Menu,
  22.                             MenuPtr, MenuItem, MenuItemPtr, IntuiMessagePtr,
  23.                             IDCMPFlags, IDCMPFlagSet, WindowPtr, WindowFlags,
  24.                             WindowFlagSet, IntuitionText, IntuitionTextPtr;
  25. FROM Menus           IMPORT SetMenuStrip, HighComp;
  26. FROM Screens         IMPORT CloseScreen;
  27. FROM Storage         IMPORT DestroyHeap;
  28. FROM Strings         IMPORT String;
  29. FROM SYSTEM          IMPORT ADR, BYTE, NULL;
  30. FROM Text            IMPORT TextAttr, TextAttrPtr, TextFontPtr, 
  31.                             RemFont, CloseFont;
  32. FROM Views           IMPORT Modes, ModeSet;
  33. FROM Windows         IMPORT CloseWindow;
  34. FROM ModulaTools     IMPORT OpenGraphics, CloseGraphics, CreateScreen,
  35.                             CreateWindow, InitializeMenuStrip, DestroyMenuStrip,
  36.                             AddMenu, AddItem, AddSubItem, FirstMenu, SelectText,
  37.                             ChoiceType, GotMessage, GetMenuChoice, ViewFeatures,
  38.                             ItemOn, NoKey, RightJustify, TextDrawMode, TextPen,
  39.                             HiResScreen, NewItemColumn, CurrentItem, Checkable, 
  40.                             FillPen, FrontTextPen, BackTextPen, AutoIndent,
  41.                             WindowFeatures, CurrentFont, VerPixPerChar, Left,
  42.                             GetAndSortAllFonts, ReturnFontResourcesToSystem;
  43.  
  44. CONST
  45.    MaxFonts = 6;              (* MaxFonts+1 = maximum number of fonts to open *)
  46.  
  47. VAR
  48.    UserScreen  : ScreenPtr;
  49.    UserWindow  : WindowPtr;
  50.    IMessage    : IntuiMessagePtr;
  51.    finished    : BOOLEAN;        (* logical variable for event loop. (What??) *)
  52.    WindowTitle : String;
  53.    ScreenTitle : String;
  54.    MenuChoice  : ChoiceType;
  55.    FontBuffer  : AvailFontsHeaderPtr;
  56.    AttrStore   : ARRAY[0..MaxFonts] OF TextAttrPtr;      (* storage space for *)
  57.    FontStore   : ARRAY[0..MaxFonts] OF TextFontPtr;      (* font information  *)
  58.    TotalFonts  : CARDINAL;
  59.    i           : CARDINAL;
  60.  
  61.  
  62.  
  63.    PROCEDURE CreateMenuWindow;
  64.  
  65.    BEGIN
  66.  
  67.       INCL(ViewFeatures, Hires);                 (* High-resolution Screen *)
  68.       ScreenTitle := "MenuScreen";
  69.       UserScreen  := CreateScreen (0, 0, 640, 200, 3, ScreenTitle);
  70.  
  71.       WindowTitle := "Push down the little menu-button on the mouse, please...";
  72.       FillPen     := TextPen;                   (* pen used to draw border *)
  73.       TextPen     := 2;                         (* pen used to draw text   *)
  74.       EXCL(WindowFeatures, WindowClose);        (* no close gadget         *)
  75.       EXCL(WindowFeatures, WindowDrag);         (* no drag  gadget         *)
  76.       EXCL(WindowFeatures, WindowDepth);        (* no depth gadget         *)
  77.       UserWindow  := CreateWindow (0, 0, 640, 200, WindowTitle, UserScreen);
  78.  
  79.    END CreateMenuWindow;
  80.  
  81.   
  82.  
  83.    PROCEDURE CreateDrawingModesMenu;
  84.  
  85.    BEGIN
  86.  
  87.       AddMenu("Drawing Modes");
  88.  
  89.          TextDrawMode := DrawingModeSet{Jam2};
  90.          SelectText   := "Replace             ";
  91.          AddItem("DrawingModeSet{Jam2}", NoKey, ItemOn, 0);
  92.  
  93.          TextDrawMode := Jam1;
  94.          SelectText   := "OverwriteOverwriteOverwrite";
  95.          AddItem("Jam1", NoKey, ItemOn, 0);
  96.  
  97.          TextDrawMode := DrawingModeSet{Complement};
  98.          AddItem("DrawingModeSet{Complement}", NoKey, ItemOn, 0);
  99.  
  100.          TextDrawMode := DrawingModeSet{InverseVid};
  101.          SelectText   := "OverwriteOverwriteOverwrite";
  102.          AddItem("DrawingModeSet{InverseVid}", NoKey, ItemOn, 0);
  103.  
  104.          INCL(TextDrawMode, Jam2);
  105.          SelectText   := "Replace                         ";
  106.          AddItem("DrawingModeSet{Jam2, InverseVid}", NoKey, ItemOn, 0);
  107.  
  108.    END CreateDrawingModesMenu;
  109.  
  110.  
  111.  
  112.    PROCEDURE CreateColorsMenu;
  113.  
  114.  
  115.     (* This procedure changes the color of the alternate text in a MenuItem *)
  116.  
  117.       PROCEDURE NewSelectColor(NewTextPen : INTEGER);
  118.  
  119.       VAR
  120.          dummyIText : IntuitionTextPtr;
  121.  
  122.       BEGIN
  123.          dummyIText := IntuitionTextPtr(CurrentItem^.SelectFill);
  124.          dummyIText^.FrontPen := BYTE(NewTextPen);
  125.       END NewSelectColor;
  126.  
  127.  
  128.    BEGIN
  129.  
  130.       TextDrawMode := DrawingModeSet{Jam2};
  131.       AutoIndent   := TRUE;           (* Align second Item with other two. *)
  132.       AddMenu("Colors");
  133.  
  134.          SelectText   := "Pen #4 ";
  135.          FrontTextPen := 1;
  136.          AddItem("Pen #1 ", "1", ItemOn+Checkable, 4);
  137.          NewSelectColor(4);
  138.  
  139.          SelectText   := "Pen #5 ";
  140.          FrontTextPen := 2;
  141.          AddItem("Pen #2 ", "2", ItemOn, 0);
  142.          NewSelectColor(5);
  143.  
  144.          SelectText   := "Pen #6 ";
  145.          FrontTextPen := 3;
  146.          AddItem("Pen #3 ", "3", ItemOn+Checkable, 1);
  147.          NewSelectColor(6);
  148.  
  149.    END CreateColorsMenu;
  150.  
  151.  
  152.  
  153.    PROCEDURE CreateIntuitionBugMenu;
  154.  
  155.    BEGIN
  156.  
  157.       FrontTextPen := TextPen;               (* same as before Colors Menu *)
  158.       AutoIndent   := FALSE;     (* checkable Items are indented anyway... *)
  159.       RightJustify := FALSE;     (* don't align Items with Menu right-edge *)
  160.  
  161.       AddMenu("Intuition bug? (Select an Item...)");
  162.          Left := -50;                                   (* optional *)
  163.          AddItem("#1",  "a",  ItemOn+Checkable,  0);
  164.          AddItem("#2",  "b",  ItemOn+Checkable,  0);
  165.          AddItem("#3",  "c",  ItemOn+Checkable,  0);
  166.          AddItem("#4",  "d",  ItemOn+Checkable,  0);
  167.          AddItem("#5",  "e",  ItemOn+Checkable,  0);
  168.          AddItem("#6",  "f",  ItemOn+Checkable,  0);
  169.          AddItem("#7",  "g",  ItemOn+Checkable,  0);
  170.          AddItem("#8",  "h",  ItemOn+Checkable,  0);
  171.          NewItemColumn := TRUE;
  172.          AddItem("#9",  "i",  ItemOn+Checkable,  0);
  173.          AddItem("#10", "j",  ItemOn+Checkable,  0);
  174.          AddItem("#11", "k",  ItemOn+Checkable,  0);
  175.          AddItem("#12", "l",  ItemOn+Checkable,  0);
  176.          AddItem("#13", "m",  ItemOn+Checkable,  0);
  177.          AddItem("#14", "n",  ItemOn+Checkable,  0);
  178.          AddItem("#15", "o",  ItemOn+Checkable,  0);
  179.          AddItem("#16", "p",  ItemOn+Checkable,  0);
  180.          NewItemColumn := TRUE;
  181.          AddItem("#17", "q",  ItemOn+Checkable,  0);
  182.          AddItem("#18", "r",  ItemOn+Checkable,  0);
  183.          AddItem("#19", "s",  ItemOn+Checkable,  0);
  184.          AddItem("#20", "t",  ItemOn+Checkable,  0);
  185.          AddItem("#21", "u",  ItemOn+Checkable,  0);
  186.          AddItem("#22", "v",  ItemOn+Checkable,  0);
  187.          AddItem("#23", "w",  ItemOn+Checkable,  0);
  188.          AddItem("#24", "x",  ItemOn+Checkable,  0);
  189.          NewItemColumn := TRUE;
  190.          AddItem("#25", "y",  ItemOn+Checkable,  0);
  191.          AddItem("#26", "z",  ItemOn+Checkable,  0);
  192.  
  193.    END CreateIntuitionBugMenu;
  194.  
  195.  
  196.  
  197.    PROCEDURE CreateSartreMenu;
  198.  
  199.    BEGIN
  200.  
  201.       RightJustify := TRUE;         (* Item select-box same size as Menu's   *)
  202.       AddMenu("Screw Sartre...");
  203.          FOR i := 0 TO TotalFonts DO
  204.             CurrentFont   := AttrStore[i];           (* font for Item text   *)
  205.             VerPixPerChar := AttrStore[i]^.taYSize;  (* font height          *)
  206.             AddItem("Exit", NoKey,  ItemOn,  0);
  207.          END; (* FOR i *)
  208.  
  209.    END CreateSartreMenu;
  210.  
  211.  
  212.  
  213. (* This procedure waits for the user to choose an Item from the Sartre Menu  *)
  214.  
  215.    PROCEDURE ProcessIntuitionMessages;
  216.  
  217.    CONST
  218.       SartreMenu = 3;
  219.  
  220.    BEGIN
  221.  
  222.       finished := FALSE;
  223.       WHILE NOT (finished) DO
  224.  
  225.          IF (GotMessage (IMessage, UserWindow)) THEN
  226.             IF (MenuPick IN IMessage^.Class) THEN
  227.  
  228.                GetMenuChoice (IMessage^.Code, FirstMenu, MenuChoice);
  229.  
  230.                IF (MenuChoice.MenuChosen = SartreMenu) THEN
  231.                   finished := TRUE;
  232.                END; (* WITH MenuChoice^ *)
  233.  
  234.             END; (* IF MenuPick *)
  235.          END; (* IF GotMessage *)
  236.  
  237.       END; (* WHILE NOT finished *)
  238.  
  239.    END ProcessIntuitionMessages;
  240.  
  241.  
  242.  
  243. (* This procedure opens several fonts for use in the "Screw Sartre..." Menu *)
  244.  
  245.    PROCEDURE GimmeNewFonts () : BOOLEAN;
  246.    
  247.    BEGIN
  248.  
  249.       (* $T-  Compiler thinks afhAvailFonts has one element *) 
  250.  
  251.       IF (GetAndSortAllFonts(FontBuffer)) THEN     (* get new fonts: *)
  252.          WITH FontBuffer^ DO                       (* still painful  *)
  253.  
  254.             TotalFonts := afhNumEntries DIV 2;    (* avoid duplicate fonts *)
  255.             IF (TotalFonts > MaxFonts) THEN TotalFonts := MaxFonts; END;
  256.  
  257.             FOR i := 0 TO TotalFonts DO
  258.                AttrStore[i]  := ADR( afhAvailFonts[2*i].afAttr );
  259.                FontStore[i]  := OpenDiskFont (AttrStore[i]^);
  260.             END; (* FOR i *)
  261.  
  262.          END; (* FontBuffer^ *)
  263.          RETURN TRUE;
  264.  
  265.       ELSE
  266.          RETURN FALSE;
  267.       END; (* IF GetAndSortAllFonts *)
  268.  
  269.       (* $T+  turn range checking back on *)
  270.  
  271.    END GimmeNewFonts;
  272.  
  273.  
  274.  
  275. (* This little piggy closes the fonts opened above. If no other process is *)
  276. (* accessing them, the fonts will be removed from the system-font list.    *)
  277.  
  278.    PROCEDURE GetRidOfFonts;
  279.  
  280.    VAR
  281.       WhoCares : LONGINT;
  282.  
  283.    BEGIN
  284.       FOR i := 0 TO TotalFonts DO
  285.          CloseFont (FontStore[i]^);
  286.          WhoCares := RemFont (FontStore[i]^);
  287.       END; (* FOR i *)
  288.       ReturnFontResourcesToSystem (FontBuffer);
  289.    END GetRidOfFonts;
  290.  
  291.   
  292. BEGIN
  293.  
  294.    WriteLn;
  295.    WriteString("Looking for Fonts...are you there, Fonts?");
  296.    WriteLn; WriteLn;
  297.  
  298.    IF GimmeNewFonts() THEN                  (* identify all available fonts *)
  299.       WriteString("Apparently so...");
  300.    ELSE
  301.       WriteString("Apparently not...");
  302.    END; (* IF GimmeNewFonts *)
  303.    WriteLn; WriteLn;
  304.  
  305.    IF OpenGraphics() THEN (* open libraries and initialize needed variables *)
  306.  
  307.       CreateMenuWindow;
  308.  
  309.       IF (UserWindow <> NULL) THEN
  310.  
  311.          InitializeMenuStrip;       (* initialize more needed variables     *)
  312.  
  313.          HiResScreen  := TRUE;      (* The Menu routines need to know this. *)
  314.          FrontTextPen := TextPen;
  315.          BackTextPen  := FillPen;   (* make (Sub)Item background invisible; *)
  316.  
  317.          CreateDrawingModesMenu;
  318.          CreateColorsMenu;          (* link menus into current MenuStrip    *)
  319.          CreateIntuitionBugMenu;
  320.          CreateSartreMenu;
  321.  
  322.          SetMenuStrip(UserWindow, FirstMenu^);
  323.  
  324.          ProcessIntuitionMessages;         (* ...until user chooses to exit *)
  325.  
  326.          GetRidOfFonts;                    (* free memory allotted to fonts *)
  327.  
  328.          DestroyMenuStrip(UserWindow); (* free memory allotted to MenuStrip *)
  329.          CloseWindow (UserWindow);
  330.  
  331.       ELSE
  332.          WriteString ("No Window allocated..."); WriteLn;
  333.       END; (* IF UserWindow *)
  334.  
  335.       IF (UserScreen <> NULL) THEN
  336.          CloseScreen (UserScreen);
  337.       ELSE
  338.          WriteString ("No Screen allocated..."); WriteLn;
  339.       END; (* IF UserScreen *)
  340.  
  341.       CloseGraphics ();                    (* close appropriate libraries   *)
  342.  
  343.    ELSE
  344.       WriteString ("Graphics didn't open properly...");
  345.    END; (* IF OpenGraphics *)
  346.    
  347.    DestroyHeap;          (* ensure that all memory allocated is deallocated *)
  348.      
  349. END Test.
  350.