home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adapm_15.zip / menu.adb < prev    next >
Text File  |  1994-03-18  |  21KB  |  561 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                               PM Bindings                                --
  4. --                                                                          --
  5. --                                Menu                                      --
  6. --                                                                          --
  7. --   Vers .1           A Simple Menu testing program                        --
  8. --                                                                          --
  9. --                            $Revision: .1 $                               --
  10. --                                                                          --
  11. --     Copyright (c) 1994 Dimensional Media Systems, All Rights Reserved    --
  12. --                                                                          --
  13. --   The PM bindings are free software; you can redistribute them and/or    --
  14. --   modify them under terms of the GNU General Public License as published --
  15. --   by the Free Software Foundation; either version 2, or (at your         --
  16. --   option) any later version.  The PM bindings are distributed in the     --
  17. --   hope that they will be useful, but WITH OUT ANY WARRANTY; without even --
  18. --   the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR    --
  19. --   PURPOSE.  See the GNU General Public License for more details.  You    --
  20. --   should have received a copy of the GNU General Public License          --
  21. --   distributed with The PM bindings; see file COPYING.  If not, write to  --
  22. --   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25. --                                                                          --
  26. --   For more information about these PM bindings and their usage with GNAT --
  27. --   you can contact Bill Yow at                                            --
  28. --                                                                          --  
  29. --      Dimensional Media Systems (DMS)                                     --
  30. --      1522 Festival Dr.                                                   --
  31. --      Houston TX, 77062                                                   --
  32. --      Phone - (713) 488-7050                                              --
  33. --      Email - Byow@mci.com                                                --
  34. --                                                                          --
  35. ------------------------------------------------------------------------------
  36.  
  37. with Win;
  38. with GPI;
  39. with Text_Io;
  40. with Pm_Types;
  41. with Dos;
  42.  
  43. procedure Menu is
  44.  
  45.   Hab            : Win.Anchor_Block_Handle_Type;
  46.   Queue          : Win.Queue_Handle_Type; 
  47.  
  48.   Queue_Message  : Win.Queue_Message_Pointer_Type;
  49.  
  50.   Button_Pressed : Win.MB_Response_Type;
  51.  
  52.   Frame_Cf       : Win.Frame_Control_Flags_Type;
  53.   New_Win        : Win.Handle_Pointer_Type;
  54.   Pop_Up_Menu    : Win.Handle_Type := Win.Null_Window;
  55.   Frame_Win      : Win.Handle_Type; 
  56.  
  57.   Successful     : Boolean;
  58.   Window_Style   : Win.Class_Styles_Type := (others => False);
  59.  
  60.   Key_Info       : Win.Key_Press_Info_Type;
  61.  
  62.   Point          : Win.Point_Type := (10, 350);
  63.   Added          : Boolean := False;
  64.  
  65.   Id_Window      : constant Win.Id_Type         := 200;
  66.   Id_Pop_Up      : constant Win.Id_Type         := 201;
  67.   Id_Draw        : constant Win.Command_Id_Type := 300;
  68.   Id_Lines       : constant Win.Command_Id_Type := 301;
  69.   Id_Arcs        : constant Win.Command_Id_Type := 302;
  70.   Id_Rectangles  : constant Win.Command_Id_Type := 303;
  71.   Id_Clear       : constant Win.Command_Id_Type := 304;
  72.  
  73.   Id_Added       : constant Win.Command_Id_Type := 310;
  74.  
  75.   Obj_Buf    : Dos.Object_Buffer_Type (1 .. 100);
  76.   Empty_Str  : String (1 .. 1) := " ";
  77.   Results    : Dos.Result_Codes_Type;
  78.   Run_Pgm    : String (1 .. 22) := "c:\pm_binding\menu.exe";  
  79.   Dos_Result : Dos.Api_Return_Code;
  80.   Launch     : Boolean := False;
  81.  
  82.   ------------------------------------------------------------------
  83.  
  84.    procedure Draw_Arcs (Window : Win.Handle_Type) is
  85.       Ps           : Win.Ps_Type; 
  86.      begin
  87.  
  88.        Ps := Win.Get_Ps (Window);
  89.  
  90.        GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  91.        GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  92.        GPI.Set_Color (Ps, GPI.Clr_Blue);
  93.        GPI.Char_String_At (
  94.                               Ps    => Ps,
  95.                               Point => (400, 350),
  96.                               Text  => "Arcs");
  97.           
  98.             --A Circle
  99.        GPI.Set_Color (Ps, GPI.Clr_White);
  100.        Gpi.Full_Arc (
  101.                  Ps            => Ps,
  102.                  Center        => (420, 75),
  103.                  Arc_Params    => (1, 1, 0, 0), 
  104.                  Outline_Style => Gpi.Dro_Outline,
  105.                  Multiplier    => 50);
  106.  
  107.             --A Width Ellipse
  108.        GPI.Set_Color (Ps, GPI.Clr_Brown);
  109.        Gpi.Full_Arc (
  110.                  Ps            => Ps,
  111.                  Center        => (420, 200),
  112.                  Arc_Params    => (1, 2, 0, 0), 
  113.                  Outline_Style => Gpi.Dro_Fill,
  114.                  Multiplier    => 25);
  115.  
  116.             --A Tall Ellipse
  117.        GPI.Set_Color (Ps, GPI.Clr_Yellow);
  118.        Gpi.Full_Arc (
  119.                  Ps            => Ps,
  120.                  Center        => (420, 305),
  121.                  Arc_Params    => (2, 1, 0, 0), 
  122.                  Outline_Style => Gpi.Dro_Outline_Fill,
  123.                  Multiplier    => 25);
  124.  
  125.        Win.Release_Ps (Ps);
  126.     end Draw_Arcs;
  127.  
  128.   ------------------------------------------------------------------
  129.  
  130.     procedure Draw_Rectangles (Window : in Win.Handle_Type) is
  131.         Ps           : Win.Ps_Type; 
  132.       begin
  133.  
  134.         Ps := Win.Get_Ps (Window);
  135.  
  136.         GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  137.         GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  138.         GPI.Set_Color (Ps, GPI.Clr_Blue);
  139.         GPI.Char_String_At (
  140.                               Ps    => Ps,
  141.                               Point => (200, 350),
  142.                               Text  => "Rectangles");
  143.           
  144.         GPI.Set_Color (Ps, GPI.Clr_Red);
  145.         Gpi.Box (Ps            => Ps,
  146.                     Start_Corner    => (200, 50),
  147.                     End_Corner      => (300, 125),
  148.                     Outline_Style   => Gpi.Dro_Fill,
  149.                     Horz_Rounding   => 0,
  150.                     Vert_Rounding   => 0);
  151.  
  152.         GPI.Set_Color (Ps, GPI.Clr_Blue);
  153.         Gpi.Box (Ps            => Ps,
  154.                     Start_Corner  => (200, 175),
  155.                     End_Corner    => (300, 250),
  156.                     Outline_Style => Gpi.Dro_Outline,
  157.                     Horz_Rounding => 10,
  158.                     Vert_Rounding => 10);
  159.                     
  160.         GPI.Set_Color (Ps, GPI.Clr_Dark_Green);
  161.         Gpi.Box (Ps            => Ps,
  162.                     Start_Corner  => (200, 265),
  163.                     End_Corner    => (300, 340),
  164.                     Outline_Style => Gpi.Dro_Outline_Fill,
  165.                     Horz_Rounding => 30,
  166.                     Vert_Rounding => 30);
  167.  
  168.         Win.Release_Ps (Ps);
  169.  
  170.    end Draw_Rectangles;
  171.  
  172.   -------------------------------------------------------
  173.  
  174.    procedure Draw_Lines (Window : in Win.Handle_Type) is
  175.         Ps           : Win.Ps_Type; 
  176.  
  177.        use Win;
  178.      begin
  179.  
  180.        Ps := Win.Get_Ps (Window);
  181.  
  182.        GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  183.        GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  184.        GPI.Set_Color (Ps, GPI.Clr_Blue);
  185.        GPI.Char_String_At (
  186.                            Ps    => Ps,
  187.                            Point => (60, 350),
  188.                            Text  => "Lines");
  189.           
  190.        GPI.Set_Color (Ps, GPI.Clr_Pink);
  191.  
  192.        for I in 1 .. 35 loop
  193.           GPI.Line (Ps          => Ps,
  194.                     Start_Point => (50, 50),
  195.                     End_Point   => (X => 150 - (Win.Pixel_Type (I) * 3), 
  196.                                     Y => 70 + (Win.Pixel_Type (I) * 8)));
  197.        end loop;
  198.  
  199.        Win.Release_Ps (Ps);
  200.  
  201.    end Draw_Lines;
  202.  
  203.   ------------------------------------------------------------------
  204.  
  205.     procedure Check_Menu_Item (Item_Id    : in Win.Command_ID_Type;
  206.                                By_Pointer : in Boolean) is
  207.  
  208.       Menu_Window    : Win.Handle_Type := Win.Null_Window;
  209.       Result         : Boolean;
  210.       Menu_Data      : Win.Menu_Item_Type;
  211.       Submenu_Window : Win.Handle_Type := Win.Null_Window;
  212.  
  213.     begin
  214.  
  215.       Menu_Window := Win.Window_From_Id (Frame_Win, Win.Fid_Menu);
  216.  
  217.       Result      := Win.Check_Menu_Item (
  218.                        Menu    => Menu_Window,
  219.                        Item_Id => Item_Id,
  220.                        Check   => By_Pointer);
  221.  
  222.       Result      := Win.Enable_Menu_Item (
  223.                        Menu    => Menu_Window,
  224.                        Item_Id => Item_Id,
  225. --                       Check   => By_Pointer);
  226.                        Enable   => By_Pointer);
  227.  
  228.  
  229.       Menu_Data := Win.Query_Menu_Item (
  230.                      Menu    => Menu_Window,
  231.                      Item_Id => ID_Draw);
  232.  
  233.       Text_Io.Put ("Position   => "); 
  234.       Text_io.Put_Line (Win.Menu_Position_Type'Image (Menu_Data.Position));
  235.       Text_Io.Put ("Style      => ");
  236.       Text_Io.Put_Line (Win.Menu_Style_Type'Image (Menu_Data.Style));
  237.       Text_Io.Put_Line ("Attributes:");
  238.       for I in Menu_Data.Attributes'range loop
  239.         if Menu_Data.Attributes (I) then
  240.           Text_Io.Put ("  ");
  241.           Text_Io.Put_Line (Win.Menu_Attribute_Type'Image (I));
  242.         end if;
  243.       end loop;
  244.       Text_Io.Put ("Item Id    => ");
  245.       Text_Io.Put_Line (Win.Command_Id_Type'Image (Menu_Data.Item_Id));
  246.  
  247.       if Added then
  248.          null;
  249.          Win.Delete_Menu_Item (
  250.              Menu    => Menu_Window,
  251.              Item_Id => Id_Added);
  252.          Added := False;
  253.       else
  254.          Submenu_Window        := Menu_Data.Sub_Menu;
  255.          Menu_Data.Style       := Win.Mis_Text;
  256.          Menu_Data.Sub_Menu    := Win.Null_Window;
  257.          Menu_Data.Item_Id     := Id_Added;
  258.          Menu_Data.Position    := 2;
  259.          Menu_data.Item_Handle := Win.Null_Bitmap;
  260.          Menu_Data.Attributes := (others => False);
  261.  
  262.          Win.Insert_Menu_Item (
  263.               Menu      => Submenu_Window,
  264.               Menu_Data => Menu_Data,
  265.               Text      => "Added Menu Item");
  266.          Added := True;
  267.       end if;  
  268.  
  269.     end Check_Menu_Item;
  270.  
  271.   ------------------------------------------------------------------
  272.  
  273.     procedure Erase_Screen (Window : in Win.Handle_Type) is 
  274.         Ps : Win.Ps_Type; 
  275.      begin
  276.  
  277.        Ps := Win.Get_Ps (Window);
  278.        Gpi.Erase (Ps);
  279.        Win.Release_Ps (Ps);
  280.  
  281.        Check_Menu_Item (Id_Lines, False);
  282.        Check_Menu_Item (Id_Arcs, False);
  283.        Check_Menu_Item (Id_Rectangles, False);
  284.  
  285.      end Erase_Screen;
  286.  
  287.   ------------------------------------------------------------------
  288.  
  289.    procedure Process_Menu (Command_Id : in Win.Command_Id_Type;
  290.                            For_Window : in Win.Handle_Type;
  291.                            By_Pointer : in Boolean) is
  292.      begin
  293.  
  294.        case Command_Id is
  295.  
  296.          when Id_Lines      => Draw_Lines (For_Window);
  297. --                               Check_Menu_Item (Id_Lines, By_Pointer);
  298.                                  Launch := True;
  299.  
  300.          when Id_Arcs       => Draw_Arcs  (For_Window);
  301.                                Check_Menu_Item (Id_Arcs, By_Pointer);
  302.  
  303.          when Id_Rectangles => Draw_Rectangles (For_Window);
  304.                                Check_Menu_Item (Id_Rectangles, By_Pointer);
  305.  
  306.          when Id_Clear      => Erase_Screen (For_Window);
  307.  
  308.          when others        => null;
  309.        end case;
  310.  
  311.      end Process_Menu;
  312.  
  313.   ------------------------------------------------------------------
  314.  
  315.   function Win_Test_Handler (Window  : Win.Handle_Type;
  316.                              Message : Win.Message_Type;
  317.                              MP1     : Win.Parameter_Type;
  318.                              MP2     : Win.Parameter_Type) 
  319.                                            return Pm_Types.U_Long is
  320.     Result       : Boolean;
  321.     Ps           : Win.Ps_Type; 
  322.  
  323.     Str          : String (1 .. 1);
  324.  
  325.     Gpi_Results  : Gpi.Status_Type;
  326.     Command_Info : Win.Command_Info_Type;
  327.  
  328.     Point        : Win.Point_Type;
  329.     Options      : Win.Pop_Up_Options_Type;
  330.  
  331.     use Win;
  332.    begin
  333.  
  334.      case Message is
  335.  
  336.       when Win.Wm_Button_1_Down => 
  337.            
  338.            Ps := Win.Get_Ps (Window);
  339.            GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  340.            GPI.Set_Background_Color (Ps, GPI.Clr_Pale_Gray);
  341.            GPI.Set_Color (Ps, GPI.Clr_Blue);
  342.            GPI.Char_String_At (
  343.                               Ps    => Ps,
  344.                               Point => Win.Pointer_Is (MP1),
  345.                               Text  => "Hello from GNAT");
  346.            Win.Release_Ps (Ps);
  347.  
  348.            return 1;
  349.  
  350.       when Win.Wm_Button_2_Down => 
  351.  
  352.             if Win.Is_Null (Pop_Up_Menu) then
  353.                Pop_Up_Menu := Win.Load_Menu (
  354.                                Owner_Window => Window,
  355.                                Resource     => Null,
  356.                                Menu_Id      => ID_Pop_Up); 
  357.             end if;
  358.  
  359.             if Win.Is_Null (Pop_Up_Menu) then
  360.                Text_io.Put_Line ("Pop menu does not exist");
  361.             else
  362.  
  363.                Options := (others => False);
  364.                Options (Win.Pu_Position_On_Item) := True;
  365.                Options (Win.Pu_Mouse_Button_1)   := True;
  366.                Options (Win.Pu_Keyboard)         := True;
  367.  
  368.                Point   := Win.Pointer_Is (MP1);
  369.  
  370.                Result := Win.Pop_Up_Menu (
  371.                      Window       => Window,
  372.                      Frame_Window => Frame_Win,
  373.                      Menu_Window  => Pop_Up_Menu,
  374.                      X            => Point.X,
  375.                      Y            => Point.Y,
  376.                      Item_Id      => Id_Arcs,
  377.                      Options      => Options);
  378.  
  379.                if Result then 
  380.                   Text_Io.Put_Line ("It should have worked");
  381.                else
  382.                   Text_Io.Put_Line ("It Failed");
  383.                end if;
  384.  
  385.             end if;
  386.  
  387.             return 1;
  388.  
  389.       when Win.Wm_Char => 
  390.            Key_Info := Win.Key_Info_Is (Mp1, Mp2);
  391.  
  392.            if (Key_Info.Flags (Win.Kc_Char) and then
  393.                not Key_Info.Flags (Win.Kc_Virtual_Key)) or else
  394.                 (Key_Info.Flags (Win.Kc_Virtual_Key) and then
  395.                    Key_Info.Virtual_Key = Win.Vk_Space and then
  396.                     not Key_Info.Flags (Win.Kc_Key_Up)) then
  397.  
  398.              Str (1) := Character'Val (Integer (Key_Info.Character_Code));
  399.  
  400.              Ps := Win.Get_Ps (Window);
  401.  
  402.              GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  403.              GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  404.              GPI.Char_String_At (
  405.                               Ps    => Ps,
  406.                               Point => Point,
  407.                               Text  => Str);
  408.              Win.Release_Ps (Ps);
  409.  
  410.              Point.X := Point.X + 11;
  411.  
  412.              if Point.X > 200 then
  413.                 Point.X := 10;
  414.                 Point.Y := Point.Y - 18;
  415.              end if;
  416.  
  417.            elsif key_Info.Flags (Win.Kc_Virtual_Key) and then
  418.                  not Key_Info.Flags (Win.Kc_Key_Up) then
  419.              null;
  420.            end if;
  421.  
  422.            return Win.Default_Window_Procedure (Window, Message, Mp1, Mp2);
  423.  
  424.       when Win.Wm_Command => 
  425.  
  426.          Command_Info := Win.Command_Info_Is (Mp1, Mp2);
  427.  
  428.          case Command_Info.Source is
  429.  
  430.            when Win.Cmd_Src_Menu =>
  431.              Process_Menu (Command_Info.Id, Window, Command_Info.By_Pointer);
  432.  
  433.            when Win.Cmd_Src_Accelerator =>
  434.              Process_Menu (Command_Info.Id, Window, Command_Info.By_Pointer);
  435.  
  436.            when others => null;
  437.          end case;
  438.  
  439.   
  440.          return 1;
  441.  
  442.       when Win.Wm_Erase_Background => 
  443.            return 1;
  444.  
  445.       when Win.Wm_Close =>
  446.         Result := Win.Post_Message (Window, Win.Wm_Quit, 0, 0);
  447.  
  448.       when others => 
  449.             return Win.Default_Window_Procedure (Window, Message, Mp1, Mp2);
  450.      end case;
  451.  
  452.      return 0;
  453.  
  454.    end Win_Test_Handler; 
  455.  
  456.   ------------------------------------------------------------------
  457.  
  458.    procedure Show_Error (Message : String) is
  459.      begin
  460.        Button_Pressed := Win.Message_Box (
  461.                         Parent_Window  => Win.Desktop_Window,
  462.                         Request_Owner  => Win.Null_Window,
  463.                         Message        => Message,
  464.                         Title          => " Error ",
  465.                         Help_Id        => 1,
  466.                         Buttons        => Win.MB_Ok,
  467.                         Icons          => Win.Mb_Icon_Hand, 
  468.                         Default_Action => Win.Mb_Default_On_Button_1);
  469.      end Show_Error;
  470.  
  471.   ------------------------------------------------------------------
  472.  
  473.    use Pm_Types;
  474.  
  475.   begin
  476.  
  477.     New_Win       := new Win.Handle_Type;
  478.     Queue_Message := new Win.Queue_Message_Type;
  479.  
  480.     Win.Initialize (Win.System_Default, Hab);
  481.  
  482.     Win.Create_Message_Queue (Hab, Win.System_Default, Queue);    
  483.  
  484.     Window_Style (Win.Cs_Size_Redraw) := True;
  485.  
  486.     Win.Register_Class (
  487.                         Anchor_Block    => Hab,
  488.                         Class_Name      => "My_Window_Class",
  489.                         Message_Handler => Win_Test_Handler'access,
  490.                         Class_Style     => Window_Style,
  491.                         Extra_Storage   => 0); 
  492.  
  493.     Frame_CF := 
  494.        (Win.Fcf_Title_Bar     => True,
  495.         Win.Fcf_System_Menu   => True,
  496.         Win.Fcf_Min_Max       => True,
  497.         Win.Fcf_Sizing_Border => True,
  498.         Win.Fcf_Task_List     => True,
  499.         Win.Fcf_Menu          => True,
  500.         Win.Fcf_Accel_Table   => True,
  501.         others                => False);
  502.  
  503.     Frame_Win := Win.Create_Standard_Window (
  504.              Parent_Window       => Win.Desktop_Window,
  505.              Window_Styles       => Win.Use_Class_Styles,
  506.              Frame_Control_Flags => Frame_CF,
  507.              Class_Name          => "My_Window_Class",
  508.              Window_Title        => "An OS/2 Window created by GNAT!",
  509.              Class_Style         => Window_Style,
  510.              Resource            => null, 
  511.              Resource_ID         => 200,
  512.              New_Window          => New_Win);
  513.  
  514.     if Win.Is_Null (Frame_Win) then
  515.        Show_Error ("The window was not created");
  516.     else
  517.  
  518.        Win.Set_Window_Position (
  519.                Window           => Frame_Win,
  520.                Behind_Window    => Win.Top_Window,
  521.                X                => 20,
  522.                Y                => 20,
  523.                Width            => 600,
  524.                Height           => 430,
  525.                Position_Options => Win.Show_Window);
  526.  
  527.        loop
  528.  
  529.           exit when not Win.Get_Message 
  530.                          (Hab, Queue_Message, Win.Null_Window, 0, 0);
  531.  
  532.         if Launch then
  533.           Launch := false;
  534.           Dos_Result :=  Dos.Exec_Program (
  535.                   Object_Buffer   => Obj_Buf,
  536.                   Exec_Flag       => Dos.Exec_ASync,
  537.                   Arguments       => Empty_Str,
  538.                   Enviorment      => Empty_Str,
  539.                   Return_Codes    => Results,
  540.                   Program         => Run_Pgm);
  541.  
  542.           Text_Io.Put ("Result   => ");
  543.           Text_Io.Put_Line (Dos.Api_Return_Code'Image (Dos_Result));                  
  544.           Text_io.Put ("Term     => ");
  545.           Text_Io.Put_Line (Pm_Types.U_Long'Image (Results.Dos_Terminate));
  546.           Text_io.Put ("C_Result => ");
  547.           Text_Io.Put_Line (Pm_Types.U_Long'Image (Results.Result));
  548.         end if;
  549.              
  550.  
  551.           Win.Dispatch_Message (Hab, Queue_Message);
  552.  
  553.        end loop;
  554.  
  555.     end if;
  556.  
  557.     Win.Destroy_Message_Queue (Queue);
  558.     Win.Terminate_App (Hab);
  559.  
  560.   end Menu;
  561.