------------------------------------------------------------------------------- -- -- -- Ada Interface to the X Window System and Motif(tm)/Lesstif -- -- Copyright (c) 1996-2002 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 -- 03 Feb 2002 H.-F. Vogt: add fallback resources -- 02 Mar 2002 H.-F. Vogt: replace System.Unsigned_Types by -- Interfaces.C -- ------------------------------------------------------------------------------- with Ada.Text_Io, Interfaces.C, X_Lib.Cursor, X_Toolkit.Shell, 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.Label.Toggle_Button, Xm_Widgets.Primitive.Separator, Fallback, Mandel_Global; use Interfaces.C, X_Lib, X_Toolkit, 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.Label.Toggle_Button, Xm_Widgets.Primitive.Separator, Mandel_Global; procedure Mandel is procedure Init_File_Menu is Menu, Pane : Widget; Wid_List : Widget_List; begin Pane := Xm_Create_Pulldown_Menu (The_Menu_Bar, "file_pane"); Wid_List := Null_Widget_List; Append (Wid_List, Xm_Create_Push_Button (Pane, "file_exit")); Xt_Manage_Children (Wid_List); 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 (Element (Wid_List, 1), Xm_Widgets.Primitive.Label.Push_Button.Xm_N_Activate_Callback, Quit_CB'Access); end Init_File_Menu; procedure Init_Image_Menu is begin Calc_Toggle := Xm_Create_Toggle_Button (The_Menu_Bar, "calc_but"); Xt_Manage_Child (Calc_Toggle); end Init_Image_Menu; procedure Init_Help_Menu is Menu, Pane : Widget; Wid_List : Widget_List; begin Pane := Xm_Create_Pulldown_Menu (The_Menu_Bar, "help_pane"); Wid_List := Null_Widget_List; Append (Wid_List, Xm_Create_Push_Button (Pane, "help_about")); Xt_Manage_Children (Wid_List); 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 (Element (Wid_List, 1), 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_Image_Menu; Init_Help_Menu; end Init_Menu_Bar; procedure Init_Work_Area is GC_Val : X_Lib.X_GC_Values; GC_Mask : Xt_GC_Mask; Col : X_Lib.X_Color; Count : Natural; begin The_Draw := Xt_Create_Managed_Widget ("draw", Xm_Drawing_Area_Widget_Class, The_Main); -- define the cursor indicating the calculation in progress Working_Cursor := X_Lib.Cursor.X_Create_Font_Cursor (Display, X_Lib.Cursor.XC_watch); -- get a colormap Colormap := X_Lib.X_Default_Colormap_Of_Screen (Screen); -- get all colors (5x5x5 cube + black) Count := 1; Color_Table (Count) := X_Lib.X_Black_Pixel_Of_Screen (Screen); Count := Count + 1; Col.Flags := (Do_Red | Do_Green | Do_Blue => True); for I in 1 .. Cube_Side loop for J in 1 .. Cube_Side loop for K in 1 .. Cube_Side loop Col.Red := unsigned_short (I) * 2**Shift_Count; Col.Green := unsigned_short (J) * 2**Shift_Count; Col.Blue := unsigned_short (K) * 2**Shift_Count; X_Lib.X_Alloc_Color (Display, Colormap, Col); Color_Table (Count) := Col.Pix; Count := Count + 1; end loop; end loop; end loop; -- create the graphics context GC_Mask := (GC_Foreground => True, others => False); for I in 1 .. Cube_Side*Cube_Side*Cube_Side+1 loop GC_Val.Foreground := Color_Table (I); GC_Table (I) := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); end loop; GC_Mask := (GC_Function => True, others => False); GC_Val.GX_Function := GX_Copy; GC_Copy := Xt_Get_GC (The_Draw, GC_Mask, GC_Val); end Init_Work_Area; -- -- part of the initialization which needs the widget to be -- realized -- procedure Init_Work_Area_2 is Width, Height : Dimension; begin Xt_App_Lock (App_Con); Argl := Null_Arg_List; Append_Get (Argl, Xm_N_Width, Width); Append_Get (Argl, Xm_N_Height, Height); Xt_Get_Values (The_Draw, Argl); Pixmap := X_Lib.X_Create_Pixmap (Display, X_Lib.X_Root_Window_Of_Screen (Screen), Width, Height, X_Lib.X_Default_Depth_Of_Screen (Screen)); Xt_App_Unlock (App_Con); Set_Size (Width, Height); -- install the callbacks Xt_Add_Callback (The_Draw, Xm_N_Expose_Callback, Expose_CB'Access); Xt_Add_Callback (The_Draw, Xm_N_Resize_Callback, Resize_CB'Access); end Init_Work_Area_2; begin X_Lib.X_Init_Threads; Xt_Toolkit_Thread_Initialize; Xt_Open_Application (Appshell, App_Con, "Mandelbrot", W_Class => X_Toolkit.Shell.Session_Shell_Widget_Class, Fallback_Resources => Fallback.Mandel_Fallback); -- set default size Argl := Null_Arg_List; Append_Set (Argl, Xm_N_Width, Dimension'(500)); Append_Set (Argl, Xm_N_Height, Dimension'(400)); Xt_Set_Values (Appshell, Argl); Display := Xt_Display (Appshell); Screen := Xt_Screen (Appshell); The_Main := Xm_Create_Main_Window (Appshell, "mainwin"); Xt_Manage_Child (The_Main); Init_Menu_Bar; 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); Initialize_Threads; Init_Work_Area_2; -- install the callbacks Xt_Add_Callback (Calc_Toggle, Xm_Widgets.Primitive.Label.Toggle_Button.Xm_N_Value_Changed_Callback, Calculate_CB'Access); Xt_App_Main_Loop (App_Con); end Mandel;