home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adapm_15.zip / pm_hello.adb < prev    next >
Text File  |  1994-12-06  |  14KB  |  384 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                               PM Bindings                                --
  4. --                                                                          --
  5. --                                PM_Hello                                  --
  6. --                                                                          --
  7. --   Vers .1           A Simple hello world test program.                   --
  8. --                                                                          --
  9. --   Vers .11          Added Character handling                             --
  10. --   Vers .12          Added some attribute controls                        --
  11. --   Vers .13          Added Line, Box and Arc routines.                    --
  12. --                                                                          --
  13. --                                                                          --
  14. --                            $Revision: .13 $                              --
  15. --                                                                          --
  16. --     Copyright (c) 1994 Dimensional Media Systems, All Rights Reserved    --
  17. --                                                                          --
  18. --   The PM bindings are free software; you can redistribute them and/or    --
  19. --   modify them under terms of the GNU General Public License as published --
  20. --   by the Free Software Foundation; either version 2, or (at your         --
  21. --   option) any later version.  The PM bindings are distributed in the     --
  22. --   hope that they will be useful, but WITH OUT ANY WARRANTY; without even --
  23. --   the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR    --
  24. --   PURPOSE.  See the GNU General Public License for more details.  You    --
  25. --   should have received a copy of the GNU General Public License          --
  26. --   distributed with The PM bindings; see file COPYING.  If not, write to  --
  27. --   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  --
  28. --                                                                          --
  29. ------------------------------------------------------------------------------
  30. --                                                                          --
  31. --   For more information about these PM bindings and their usage with GNAT --
  32. --   you can contact Bill Yow at                                            --
  33. --                                                                          --  
  34. --      Dimensional Media Systems (DMS)                                     --
  35. --      1522 Festival Dr.                                                   --
  36. --      Houston TX, 77062                                                   --
  37. --      Phone - (713) 488-7050                                              --
  38. --      Email - Byow@mci.com                                                --
  39. --                                                                          --
  40. ------------------------------------------------------------------------------
  41.  
  42. with Win;
  43. with GPI;
  44. with Text_Io;
  45. with Pm_Types;
  46.  
  47. procedure Pm_Hello is
  48.  
  49.   Hab            : Win.Anchor_Block_Handle_Type := Win.Null_Anchor_Block;
  50.   Queue          : Win.Queue_Handle_Type; 
  51.  
  52.   Queue_Message  : Win.Queue_Message_Pointer_Type;
  53.  
  54.   Button_Pressed : Win.MB_Response_Type;
  55.  
  56.   Frame_Cf       : Win.Frame_Control_Flags_Type;
  57.   New_Win        : Win.Handle_Pointer_Type;
  58.   Frame_Win      : Win.Handle_Type; 
  59.  
  60.   Successful     : Boolean;
  61.   Window_Style   : Win.Class_Styles_Type := (others => False);
  62.  
  63.   Key_Info       : Win.Key_Press_Info_Type;
  64.  
  65.   Point          : Win.Point_Type := (10, 350);
  66.  
  67.  
  68.   Error_File     : Text_Io.File_Type;
  69.  
  70.   ------------------------------------------------------------------
  71.  
  72.   procedure Error_Write (Str : String) is
  73.     begin
  74.       Text_Io.Put_Line (Error_File, Str);
  75.     end Error_Write;
  76.  
  77.   ------------------------------------------------------------------
  78.  
  79.   function Win_Test_Handler (Window  : Win.Handle_Type;
  80.                              Message : Win.Message_Type;
  81.                              MP1     : Win.Parameter_Type;
  82.                              MP2     : Win.Parameter_Type) return 
  83.                                                     Pm_Types.U_Long is
  84.     Result      : Boolean;
  85.     Ps          : Win.Ps_Type; 
  86.  
  87.     Str         : String (1 .. 1);
  88.  
  89.     Gpi_Results : Gpi.Status_Type;
  90.  
  91.     use Win;
  92.    begin
  93.  
  94.      case Message is
  95.  
  96.       when Win.Wm_Button_1_Down => 
  97.            
  98.            Ps := Win.Get_Ps (Window);
  99.            GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  100.            GPI.Set_Background_Color (Ps, GPI.Clr_Pale_Gray);
  101.            GPI.Set_Color (Ps, GPI.Clr_Blue);
  102.            GPI.Char_String_At (
  103.                               Ps    => Ps,
  104.                               Point => Win.Pointer_Is (MP1),
  105.                               Text  => "Hello from GNAT");
  106.            Win.Release_Ps (Ps);
  107.  
  108.            return 1;
  109.  
  110.       when Win.Wm_Button_2_Down => 
  111.  
  112.            Ps := Win.Get_Ps (Window);
  113.  
  114.            GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  115.            GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  116.            GPI.Set_Color (Ps, GPI.Clr_Blue);
  117.            GPI.Char_String_At (
  118.                               Ps    => Ps,
  119.                               Point => (60, 380),
  120.                               Text  => "Lines");
  121.           
  122.            GPI.Set_Color (Ps, GPI.Clr_Pink);
  123.  
  124.            for I in 1 .. 35 loop
  125.               GPI.Line (Ps          => Ps,
  126.                         Start_Point => (50, 50),
  127.                         End_Point   => (X => 150 - (Win.Pixel_Type (I) * 3), 
  128.                                         Y => 120 + (Win.Pixel_Type (I) * 8)));
  129.            end loop;
  130.  
  131.  
  132.            GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  133.            GPI.Set_Color (Ps, GPI.Clr_Blue);
  134.            GPI.Char_String_At (
  135.                               Ps    => Ps,
  136.                               Point => (225, 380),
  137.                               Text  => "Boxes");
  138.           
  139.            GPI.Set_Color (Ps, GPI.Clr_Red);
  140.            Gpi.Box (Ps            => Ps,
  141.                     Start_Corner    => (200, 50),
  142.                     End_Corner      => (300, 125),
  143.                     Outline_Style   => Gpi.Dro_Fill,
  144.                     Horz_Rounding   => 0,
  145.                     Vert_Rounding   => 0);
  146.  
  147.            GPI.Set_Color (Ps, GPI.Clr_Blue);
  148.            Gpi.Box (Ps            => Ps,
  149.                     Start_Corner  => (200, 175),
  150.                     End_Corner    => (300, 250),
  151.                     Outline_Style => Gpi.Dro_Outline,
  152.                     Horz_Rounding => 10,
  153.                     Vert_Rounding => 10);
  154.                     
  155.            GPI.Set_Color (Ps, GPI.Clr_Dark_Green);
  156.            Gpi.Box (Ps            => Ps,
  157.                     Start_Corner  => (200, 275),
  158.                     End_Corner    => (300, 350),
  159.                     Outline_Style => Gpi.Dro_Outline_Fill,
  160.                     Horz_Rounding => 30,
  161.                     Vert_Rounding => 30);
  162.  
  163.  
  164.            GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  165.            GPI.Set_Color (Ps, GPI.Clr_Blue);
  166.            GPI.Char_String_At (
  167.                               Ps    => Ps,
  168.                               Point => (400, 380),
  169.                               Text  => "Arcs");
  170.           
  171.             --A Circle
  172.             GPI.Set_Color (Ps, GPI.Clr_White);
  173.             Gpi.Full_Arc (
  174.                  Ps            => Ps,
  175.                  Center        => (420, 75),
  176.                  Arc_Params    => (1, 1, 0, 0), 
  177.                  Outline_Style => Gpi.Dro_Outline,
  178.                  Multiplier    => 50);
  179.  
  180.             --A Width Ellipse
  181.             GPI.Set_Color (Ps, GPI.Clr_Brown);
  182.             Gpi.Full_Arc (
  183.                  Ps            => Ps,
  184.                  Center        => (420, 200),
  185.                  Arc_Params    => (1, 2, 0, 0), 
  186.                  Outline_Style => Gpi.Dro_Fill,
  187.                  Multiplier    => 25);
  188.  
  189.             --A Tall Ellipse
  190.             GPI.Set_Color (Ps, GPI.Clr_Yellow);
  191.             Gpi.Full_Arc (
  192.                  Ps            => Ps,
  193.                  Center        => (420, 325),
  194.                  Arc_Params    => (2, 1, 0, 0), 
  195.                  Outline_Style => Gpi.Dro_Outline_Fill,
  196.                  Multiplier    => 25);
  197.  
  198.             Win.Release_Ps (Ps);
  199.  
  200.             return 1;
  201.  
  202.       when Win.Wm_Char => 
  203.            Key_Info := Win.Key_Info_Is (Mp1, Mp2);
  204.  
  205.            if (Key_Info.Flags (Win.Kc_Char) and then
  206.                not Key_Info.Flags (Win.Kc_Virtual_Key)) or else
  207.                 (Key_Info.Flags (Win.Kc_Virtual_Key) and then
  208.                    Key_Info.Virtual_Key = Win.Vk_Space and then
  209.                     not Key_Info.Flags (Win.Kc_Key_Up)) then
  210.  
  211.              Str (1) := Character'Val (Integer (Key_Info.Character_Code));
  212.  
  213.              Ps := Win.Get_Ps (Window);
  214.  
  215.              GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  216.              GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  217.              GPI.Char_String_At (
  218.                               Ps    => Ps,
  219.                               Point => Point,
  220.                               Text  => Str);
  221.              Win.Release_Ps (Ps);
  222.  
  223.              Point.X := Point.X + 11;
  224.  
  225.              if Point.X > 200 then
  226.                 Point.X := 10;
  227.                 Point.Y := Point.Y - 18;
  228.              end if;
  229.  
  230.            elsif key_Info.Flags (Win.Kc_Virtual_Key) and then
  231.                  not Key_Info.Flags (Win.Kc_Key_Up) then
  232.  
  233.              Ps := Win.Get_Ps (Window);
  234.  
  235.              GPI.Set_Background_Mix (Ps, GPI.Bm_Overpaint);
  236.              GPI.Set_Background_Color (Ps, GPI.Clr_Background);
  237.              GPI.Char_String_At (
  238.                   Ps    => Ps,
  239.                   Point => (250, Point.Y),
  240.                   Text  => "                                          ");
  241.              GPI.Char_String_At (
  242.                    Ps    => Ps,
  243.                    Point => (250, Point.Y),
  244.                    Text  => Win.Virtual_Key_Type'Image (Key_Info.Virtual_Key));
  245.              Win.Release_Ps (Ps);
  246.              
  247.              Point.Y := Point.Y - 18;
  248.  
  249.              if Point.Y < 10 then
  250.                Point.Y := 350;
  251.              end if;
  252.  
  253.            end if;
  254.  
  255.            return 1;
  256.  
  257.       when Win.Wm_Erase_Background => 
  258.            return 1;
  259.  
  260.       when Win.Wm_Close =>
  261.         Result := Win.Post_Message (Window, Win.Wm_Quit, 0, 0);
  262.  
  263.       when others => 
  264.         return Win.Default_Window_Procedure (Window, Message, Mp1, Mp2);
  265.      end case;
  266.  
  267.      return 0;
  268.  
  269.    end Win_Test_Handler; 
  270.  
  271.   ------------------------------------------------------------------
  272.  
  273.    procedure Show_Error (Message : String) is
  274.      begin
  275.        Button_Pressed := Win.Message_Box (
  276.                         Parent_Window  => Win.Desktop_Window,
  277.                         Request_Owner  => Win.Null_Window,
  278.                         Message        => Message,
  279.                         Title          => " Error ",
  280.                         Help_Id        => 1,
  281.                         Buttons        => Win.MB_Ok,
  282.                         Icons          => Win.Mb_Icon_Hand, 
  283.                         Default_Action => Win.Mb_Default_On_Button_1);
  284.      end Show_Error;
  285.  
  286.   ------------------------------------------------------------------
  287.  
  288.    use Pm_Types;
  289.  
  290.   begin
  291.  
  292.     Text_Io.Create (Error_File, Text_Io.Out_File, "Errors.txt");
  293.     Error_Write ("H1");
  294.  
  295.     New_Win       := new Win.Handle_Type;
  296.  
  297.     Error_Write ("H2");
  298.  
  299.     Queue_Message := new Win.Queue_Message_Type;
  300.  
  301.     Error_Write ("H3");
  302.  
  303. --    Win.Initialize (Win.System_Default, Hab);
  304.  
  305.     Error_Write ("H4");
  306.  
  307.     Win.Create_Message_Queue (Hab, Win.System_Default, Queue);    
  308.  
  309.     Error_Write ("H5");
  310.  
  311.     Window_Style (Win.Cs_Size_Redraw) := True;
  312.  
  313.     Error_Write ("H6");
  314.  
  315.     Win.Register_Class (
  316.                         Anchor_Block    => Hab,
  317.                         Class_Name      => "My_Window_Class",
  318.                         Message_Handler => Win_Test_Handler'access,
  319.                         Class_Style     => Window_Style,
  320.                         Extra_Storage   => 0); 
  321.  
  322.     Error_Write ("H7");
  323.  
  324.     Frame_CF := 
  325.        (Win.Fcf_Title_Bar     => True,
  326.         Win.Fcf_System_Menu   => True,
  327.         Win.Fcf_Min_Max       => True,
  328.         Win.Fcf_Sizing_Border => True,
  329.         Win.Fcf_Task_List     => True,
  330.         others                => False);
  331.  
  332.     Error_Write ("H8");
  333.  
  334.     Frame_Win := Win.Create_Standard_Window (
  335.              Parent_Window       => Win.Desktop_Window,
  336.              Window_Styles       => Win.Use_Class_Styles,
  337.              Frame_Control_Flags => Frame_CF,
  338.              Class_Name          => "My_Window_Class",
  339.              Window_Title        => "An OS/2 Window created by GNAT!",
  340.              Class_Style         => Window_Style,
  341.              Resource            => null, 
  342.              Resource_ID         => 1,
  343.              New_Window          => New_Win);
  344.  
  345.     Error_Write ("H9");
  346.  
  347.     if Win.Is_Null (Frame_Win) then
  348.        Show_Error ("The window was not created");
  349.     else
  350.  
  351.        Win.Set_Window_Position (
  352.                Window           => Frame_Win,
  353.                Behind_Window    => Win.Top_Window,
  354.                X                => 20,
  355.                Y                => 20,
  356.                Width            => 600,
  357.                Height           => 430,
  358.                Position_Options => Win.Show_Window);
  359.  
  360.     Error_Write ("H10");
  361.  
  362.     Text_Io.Close (Error_File);
  363.  
  364.        loop
  365.  
  366.           exit when not Win.Get_Message (Hab, Queue_Message, 
  367.                                           Win.Null_Window, 0, 0);
  368.           Win.Dispatch_Message (Hab, Queue_Message);
  369.  
  370.        end loop;
  371.  
  372.     end if;
  373.  
  374.     Win.Destroy_Message_Queue (Queue);
  375.     Win.Terminate_App (Hab);
  376.  
  377.  
  378.   end Pm_Hello;
  379.  
  380.  
  381.  
  382.  
  383.  
  384.