------------------------------------------------------------------------------- -- -- -- Ada Interface to the X Window System and Motif(tm)/Lesstif -- -- Copyright (c) 1996-2000 Hans-Frieder Vogt -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- See the GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the -- -- Free Software Foundation, Inc., -- -- 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- X Window System is copyrighted by the X Consortium -- -- Motif(tm) is copyrighted by the Open Software Foundation, Inc. -- -- -- -- -- ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- -- HISTORY: -- June 20, 1998 begin of history -- 20 Jan 2002 H.-F. Vogt: add popup menu as an alternative to the -- menu bar (new resource show_menu) -- comment out X_Lib.Tasking, because it seems -- not to be necessary -- ------------------------------------------------------------------------------- with Ada.Text_Io, Ada.Characters.Latin_1, X_Command_Line, X_Strings, -- X_Lib.Tasking, X_Lib, X_Toolkit.Resource, Xm_Widgets.Manager.Row_Column, Xm_Widgets.Manager.Drawing_Area, Xm_Widgets.Manager.Scrolled_Window.Main_Window, Xm_Widgets.Primitive.Label.Cascade_Button, Xm_Widgets.Primitive.Label.Push_Button, Xm_Widgets.Primitive.Separator, Clock_Global, Fallback; use Ada.Text_Io, Ada.Characters.Latin_1, X_Command_Line, X_Lib, X_Toolkit, X_Toolkit.Resource, Xm_Widgets, Xm_Widgets.Manager.Row_Column, Xm_Widgets.Manager.Drawing_Area, Xm_Widgets.Manager.Scrolled_Window.Main_Window, Xm_Widgets.Primitive.Label, Xm_Widgets.Primitive.Label.Cascade_Button, Xm_Widgets.Primitive.Label.Push_Button, Xm_Widgets.Primitive.Separator, Clock_Global; with System, Unchecked_Conversion, X_Lib.Resource, String_List; procedure Clock is type App_Res is record S_Finger : Pixel; M_Finger : Pixel; H_Finger : Pixel; Markings : Pixel; Shadow : Pixel; Show_Menu : Xt_Boolean; end record; App_Resources : App_Res; type X_String_Array is array (Natural range <>) of X_Strings.X_String; Default_Colors : constant X_String_Array (1 .. 5) := (X_Strings.To_X_String ("SteelBlue4"), X_Strings.To_X_String ("SteelBlue3"), X_Strings.To_X_String ("SteelBlue2"), X_Strings.To_X_String ("MistyRose4"), X_Strings.To_X_String ("ivory3")); Show_Menu_Default : constant Xt_Boolean := False; function To_Xt_Pointer is new Unchecked_Conversion (X_Strings.X_String, Xt_Pointer); type Resource_Rec_Array is array (Natural range <>) of Resource_Rec; App_Res_Array : constant Resource_Rec_Array := ((To_Resource_String ("s_finger"), To_Resource_String ("S_Finger"), Xt_R_Pixel, Pixel'Size, App_Resources.S_Finger'Position, Xt_R_String, To_Xt_Pointer (Default_Colors (1))), (To_Resource_String ("m_finger"), To_Resource_String ("M_Finger"), Xt_R_Pixel, Pixel'Size, App_Resources.M_Finger'Position, Xt_R_String, To_Xt_Pointer (Default_Colors (2))), (To_Resource_String ("h_finger"), To_Resource_String ("H_Finger"), Xt_R_Pixel, Pixel'Size, App_Resources.H_Finger'Position, Xt_R_String, To_Xt_Pointer (Default_Colors (3))), (To_Resource_String ("markings"), To_Resource_String ("Markings"), Xt_R_Pixel, Pixel'Size, App_Resources.Markings'Position, Xt_R_String, To_Xt_Pointer (Default_Colors (4))), (To_Resource_String ("shadow"), To_Resource_String ("Shadow"), Xt_R_Pixel, Pixel'Size, App_Resources.Shadow'Position, Xt_R_String, To_Xt_Pointer (Default_Colors (5))), (To_Resource_String ("show_menu"), To_Resource_String ("Show_Menu"), Xt_R_Boolean, Xt_Boolean'Size, App_Resources.Show_Menu'Position, Xt_R_Boolean, To_Xt_Pointer (Show_Menu_Default'Address))); Res_List : Resource_List; procedure Init_File_Menu is Menu, Pane, Exit_Btn : Widget; begin Pane := Xm_Create_Pulldown_Menu (The_Menu_Bar, "file_pane"); Exit_Btn := Xm_Create_Push_Button (Pane, "file_exit"); Xt_Manage_Child (Exit_Btn); Argl := Null_Arg_List; Append_Set (Argl, Xm_Widgets.Primitive.Label.Cascade_Button.Xm_N_Sub_Menu_Id, Pane); Menu := Xm_Create_Cascade_Button (The_Menu_Bar, "file_menu", Argl); Xt_Manage_Child (Menu); -- install the callbacks Xt_Add_Callback (Exit_Btn, Xm_Widgets.Primitive.Label.Push_Button.Xm_N_Activate_Callback, Quit_CB'Access); end Init_File_Menu; procedure Init_Help_Menu is Menu, Pane, About_Btn : Widget; begin Pane := Xm_Create_Pulldown_Menu (The_Menu_Bar, "help_pane"); About_Btn := Xm_Create_Push_Button (Pane, "help_about"); Xt_Manage_Child (About_Btn); Argl := Null_Arg_List; Append_Set (Argl, Xm_Widgets.Primitive.Label.Cascade_Button.Xm_N_Sub_Menu_Id, Pane); Menu := Xm_Create_Cascade_Button (The_Menu_Bar, "help_menu", Argl); Xt_Manage_Child (Menu); Argl := Null_Arg_List; Append_Set (Argl, Xm_N_Menu_Help_Widget, Menu); Xt_Set_Values (The_Menu_Bar, Argl); Xt_Add_Callback (About_Btn, Xm_Widgets.Primitive.Label.Push_Button.Xm_N_Activate_Callback, About_CB'Access); end Init_Help_Menu; procedure Init_Menu_Bar is begin The_Menu_Bar := Xm_Create_Menu_Bar (The_Main, "menubar"); -- Xt_Manage_Child (The_Menu_Bar); Init_File_Menu; Init_Help_Menu; end Init_Menu_Bar; procedure Init_Work_Area is GC_Val : X_GC_Values; GC_Mask : Xt_GC_Mask; begin The_Draw := Xt_Create_Managed_Widget ("draw", Xm_Drawing_Area_Widget_Class, The_Main); -- get the graphics context GC_Val.Fill_Style := Stippled; GC_Mask := (GC_Foreground | GC_Fill_Style => True, others => False); -- for markings GC_Val.Foreground := App_Resources.Markings; GC_Marks := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); -- for second finger GC_Val.Foreground := App_Resources.S_Finger; GC_Sec := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); -- for minute finger GC_Val.Foreground := App_Resources.M_Finger; GC_Min := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); -- for hour finger GC_Val.Foreground := App_Resources.H_Finger; GC_Hour := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); -- for shadow of the fingers GC_Val.Foreground := App_Resources.Shadow; GC_Shadow := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); -- install the callbacks Xt_Add_Callback (The_Draw, Xm_N_Expose_Callback, Expose_Clock_CB'Access); Xt_Add_Callback (The_Draw, Xm_N_Resize_Callback, Resize_Clock_CB'Access); Xt_Add_Callback (The_Draw, Xm_N_Input_Callback, Input_CB'Access); end Init_Work_Area; begin -- X_Lib.Tasking.Resource.Seize; X_Lib.X_Init_Threads; Xt_Toolkit_Thread_Initialize; Xt_App_Initialize (Appshell, App_Con, "AdaClock", Fallback_Resources => Fallback.AdaClock_Fallback); -- get the application resources for I in App_Res_Array'Range loop Append (Res_List, App_Res_Array (I)); end loop; Xt_Get_Application_Resources (Appshell, To_Xt_Pointer (App_Resources'Address), Res_List); Display := Xt_Display (Appshell); The_Main := Xm_Create_Main_Window (Appshell, "mainwin"); Xt_Manage_Child (The_Main); Init_Menu_Bar; -- only show menu bar if show_menu resource was set -- if App_Resources.Show_Menu = Xt_Boolean'(True) then Xt_Manage_Child (The_Menu_Bar); end if; Init_Work_Area; Xm_Main_Window_Set_Areas (The_Main, The_Menu_Bar, Null_Widget, Null_Widget, Null_Widget, The_Draw); Xt_Realize_Widget (Appshell); Timer_ID := Xt_App_Add_Time_Out (App_Con, 1000, Timeout_CB'Access, Null_Xt_Pointer); -- to be sure it is called at least once Resize_Clock; Xt_App_Main_Loop (App_Con); -- X_Lib.Tasking.Resource.Release; exception when Leave_Program => null; end Clock;