------------------------------------------------------------------------------- -- -- -- 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: -- 25.1.98 adapted to adabindx 0.5 -- 26 Jan 2002 H.-F. Vogt: simplified the task (no start/stop any longer) -- admittedly the new method is quite brutal (abort..), -- but with the old method a deadlock occured that I -- don't understand and thus couldn't resolve -- So let's use this method until someone explains me -- how to do it in a better way -- 02 Mar 2002 H.-F. Vogt: replaced System.Unsigned_Types by Interfaces.C -- -- ------------------------------------------------------------------------------- with Ada.Characters.Latin_1, Ada.Numerics.Generic_Elementary_Functions, Ada.Text_Io, Ada.Unchecked_Deallocation, Interfaces.C, X_Lib.Cursor, Xm_Widgets.Primitive.Label.Toggle_Button, Xm_Widgets.Manager.Bulletin_Board.Message_Box, Xm_Widgets.Manager.Drawing_Area; use Interfaces.C, Xm_Widgets.Primitive.Label, Xm_Widgets.Manager.Bulletin_Board.Message_Box; package body Mandel_Global is package Real_Functions is new Ada.Numerics.Generic_Elementary_Functions (Real); use Real_Functions; procedure Free is new Ada.Unchecked_Deallocation (Calculate_Mandel, Calculate_Mandel_Access); -- locally needed Variables -- W, H : X_Lib.Dimension; Scale : Real; procedure Set_Size (Width, Height : in X_Lib.Dimension) is Tmp_Scale : Real; begin W := Width; H := Height; Scale := (R_Max-R_Min) / Real (W); Tmp_Scale := (I_Max-I_Min) / Real (H); if Scale < Tmp_Scale then Scale := Tmp_Scale; end if; end Set_Size; protected Output is procedure Put (S : in String); procedure Put_Line (S : in String); end Output; protected body Output is procedure Put (S : in String) is begin Ada.Text_Io.Put (S); Ada.Text_Io.Flush; end Put; procedure Put_Line (S : in String) is begin Ada.Text_Io.Put_Line (S); Ada.Text_Io.Flush; end Put_Line; end Output; protected Task_Counter is procedure Increment; procedure Decrement; function Current_Value return Natural; procedure Set_Value (Value : in Natural); private Counter : Natural := 0; end Task_Counter; protected body Task_Counter is procedure Actualize_Global_Status (Running : Boolean) is begin Xm_Widgets.Primitive.Label.Toggle_Button.Xm_Toggle_Button_Set_State (Calc_Toggle, Running, False); if Running then X_Lib.Cursor.X_Define_Cursor (Display, Xt_Window (The_Draw), Working_Cursor); else X_Lib.Cursor.X_Undefine_Cursor (Display, Xt_Window (The_Draw)); end if; X_Lib.X_Flush (Display); end Actualize_Global_Status; procedure Increment is begin Counter := Counter + 1; Output.Put_Line ("running tasks: " & Natural'Image (Counter)); if Counter = 1 then -- must just have been switched on Actualize_Global_Status (True); end if; end Increment; procedure Decrement is begin Counter := Counter - 1; Output.Put_Line ("running tasks: " & Natural'Image (Counter)); if Counter < 1 then -- must just have been switched on Actualize_Global_Status (False); end if; end Decrement; function Current_Value return Natural is begin return Counter; end Current_Value; procedure Set_Value (Value : in Natural) is begin if Counter > 0 and then Value < 1 then Actualize_Global_Status (False); end if; if Counter < 1 and then Value > 0 then Actualize_Global_Status (True); end if; Counter := Value; end Set_Value; end Task_Counter; function Iteration (XR, YI : in X_Lib.Position; Scale : in Real) return Natural is X_Re : constant Real := R_Min + Real (XR) * Scale; Y_Im : constant Real := I_Min + Real (YI) * Scale; Infinity : constant := 1000.0; Iter : Natural := 0; X, Y : Real := 0.0; Dummy : Real; begin loop Dummy := X; X := X*X - Y*Y + X_Re; Y := 2.0*Dummy*Y + Y_Im; Iter := Iter + 1; exit when (X*X+Y*Y > Infinity) or else (Iter >= Max_Iterations); end loop; return Iter; end Iteration; task body Calculate_Mandel is I, J : X_Lib.Position; begin J := X_Lib.Position (Offset); Task_Counter.Increment; loop -- Output.Put_Line ("task " & Our_Task_ID'Image (Task_ID) & " is working"); I := 0; Outer_Loop: loop for K in 1 .. 10 loop exit Outer_Loop when I >= X_Lib.Position (W); X_Lib.X_Draw_Point (Display, Pixmap, GC_Table ((Iteration (I, J, Scale) - 1) mod Num_Colors + 1), I, J); I := I + 1; end loop; delay Duration'Small; end loop Outer_Loop; if Xt_Is_Realized (The_Draw) then X_Lib.X_Copy_Area (Display, Pixmap, Xt_Window (The_Draw), GC_Copy, 0, 0, W, H, 0, 0); end if; J := J + X_Lib.Position (Jump); if J >= X_Lib.Position (H) then Task_Counter.Decrement; exit; end if; delay Duration'Small; end loop; end Calculate_Mandel; procedure Start_Calculation is begin -- first ensure that the tasks don't already exist -- for I in Task_List'Range loop if Task_List (I) /= null then abort Task_List (I).all; Free (Task_List (I)); Task_List (I) := null; end if; end loop; Task_Counter.Set_Value (0); for I in Task_List'Range loop Task_List (I) := new Calculate_Mandel (I, X_Lib.Dimension (I-Task_List'First), X_Lib.Dimension (Num_Tasks)); end loop; end Start_Calculation; procedure Stop_Calculation is begin for I in Task_List'Range loop if Task_List (I) /= null then Output.Put_Line ("time to stop for task " & Our_Task_ID'Image (I)); abort Task_List (I).all; Free (Task_List (I)); Task_List (I) := null; Output.Put_Line ("task " & Our_Task_ID'Image (I) & " should have stopped now"); end if; end loop; Task_Counter.Set_Value (0); end Stop_Calculation; procedure Initialize_Threads is begin null; end Initialize_Threads; procedure Calculate_CB (W : in Widget; Closure : in Xt_Pointer; Call_Data : in Xt_Pointer) is begin if Xm_Widgets.Primitive.Label.Toggle_Button.Xm_Toggle_Button_Get_State (Calc_Toggle) then Start_Calculation; else Stop_Calculation; end if; end Calculate_CB; procedure About_CB (W : in Widget; Closure : in Xt_Pointer; Call_Data : in Xt_Pointer) is use Ada.Characters.Latin_1; Button : Widget; About_Text : constant String := "Mandel -- a Mandelbrot set generator" & LF & "demonstrating use of multithreaded programming" & LF & "(c)1997-2002 Hans-Frieder Vogt" & LF & "(example program for Ada binding to X and Motif(tm))"; About_String : Xm_String; begin if About_Dialog = Null_Widget then About_Dialog := Xm_Create_Information_Dialog (Appshell, "about_dialog"); About_String := Xm_String_Create_L_To_R (About_Text, Xm_String_ISO8859_1); Argl := Null_Arg_List; Append_Set (Argl, Xm_N_Message_String, About_String); Xt_Set_Values (About_Dialog, Argl); Xm_String_Free (About_String); Button := Xt_Name_To_Widget (About_Dialog, Cancel_Button_Name); Xt_Unmanage_Child (Button); Button := Xt_Name_To_Widget (About_Dialog, Help_Button_Name); Xt_Unmanage_Child (Button); Xt_Manage_Child (About_Dialog); else if not Xt_Is_Managed (About_Dialog) then Xt_Manage_Child (About_Dialog); end if; end if; end About_CB; procedure Quit_CB (W : in Widget; Closure : in Xt_Pointer; Call_Data : in Xt_Pointer) is begin Stop_Calculation; Xt_App_Set_Exit_Flag (App_Con); end Quit_CB; procedure Expose_CB (W : in Widget; Closure : in Xt_Pointer; Call_Data : in Xt_Pointer) is use Xm_Widgets.Manager.Drawing_Area, X_Lib; CB_Struct : Xm_Drawing_Area_Callback_Struct_Access; Event : X_Event_Pointer; begin CB_Struct := To_Callback_Struct (Call_Data); Event := CB_Struct.Event; if Event.Ev_Type /= Expose then return; end if; if Xt_Is_Realized (The_Draw) then X_Lib.X_Copy_Area (Display, Pixmap, Xt_Window (The_Draw), GC_Copy, X_Lib.Position (Event.X_Expose.X), X_Lib.Position (Event.X_Expose.Y), X_Lib.Dimension (Event.X_Expose.Width), X_Lib.Dimension (Event.X_Expose.Height), X_Lib.Position (Event.X_Expose.X), X_Lib.Position (Event.X_Expose.Y)); end if; end Expose_CB; procedure Resize_CB (W : in Widget; Closure : in Xt_Pointer; Call_Data : in Xt_Pointer) is use Xm_Widgets.Manager.Drawing_Area, X_Lib; Width, Height : X_Lib.Dimension; begin Argl := Null_Arg_List; Append_Get (Argl, Xm_N_Width, Width); Append_Get (Argl, Xm_N_Height, Height); Xt_Get_Values (The_Draw, Argl); Output.Put_Line ("Resize_CB called, new size: " & X_Lib.Dimension'Image (Width) & " x " & X_Lib.Dimension'Image (Height)); if Task_Counter.Current_Value > 0 then Stop_Calculation; end if; X_Lib.X_Free_Pixmap (Display, Pixmap); 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)); Set_Size (Width, Height); -- I prefer to have my windows resized with the contents visible -- this leads to very frequent repaints. So don't automatically repaint -- -- Start_Calculation; end Resize_CB; end Mandel_Global;