------------------------------------------------------------------------------ -- GtkAda - Ada95 binding for the Gimp Toolkit -- -- -- -- Copyright (C) 2000-2018, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Numerics.Discrete_Random; with Glib; use Glib; with Cairo; use Cairo; with Cairo.Pattern; use Cairo.Pattern; with Cairo.Png; use Cairo.Png; with Cairo.Region; use Cairo.Region; with Cairo.Surface; use Cairo.Surface; with Pango.Cairo; use Pango.Cairo; with Gdk.Cairo; use Gdk.Cairo; with Gdk.Event; use Gdk.Event; with Gdk.RGBA; use Gdk.RGBA; with Gtk.Arrow; use Gtk.Arrow; with Gtk.Box; use Gtk.Box; with Gtk.Button; use Gtk.Button; with Gtk.Check_Button; use Gtk.Check_Button; with Gtk.Enums; use Gtk.Enums; with Gtk.Frame; use Gtk.Frame; with Gtk.Handlers; use Gtk.Handlers; with Gtk.Scrolled_Window; use Gtk.Scrolled_Window; with Gtk.Widget; use Gtk.Widget; with Gtkada.Canvas; use Gtkada.Canvas; with Gtk.Spin_Button; use Gtk.Spin_Button; with Gtk.Label; use Gtk.Label; with Gtk.Adjustment; use Gtk.Adjustment; with Pango.Layout; use Pango.Layout; package body Create_Canvas is Max_Size : constant := 400; -- Size of the canvas; Item_Width : constant Gint := 50; Item_Height : constant Gint := 40; ---------------------------------------------------------------- -- Redefine our own item type, since we want to provide our own -- graphics. ---------------------------------------------------------------- type Display_Item_Record is new Canvas_Item_Record with record Canvas : Interactive_Canvas; Color : Gdk.RGBA.Gdk_RGBA; Title : Gdk.RGBA.Gdk_RGBA; W, H : Gint; Num : Positive; end record; type Display_Item is access all Display_Item_Record'Class; procedure Initialize (Item : access Display_Item_Record'Class; Canvas : access Interactive_Canvas_Record'Class); -- Initialize Item with a random size and color. -- Canvas must have been realized procedure Draw (Item : access Display_Item_Record; Cr : Cairo_Context); -- Draw the item to the double-buffer ----------------------------------------------------------- -- A new non-rectangular item, with a hole in the middle -- ----------------------------------------------------------- type Hole_Item_Record is new Display_Item_Record with null record; procedure Draw (Item : access Hole_Item_Record; Cr : Cairo_Context); function Point_In_Item (Item : access Hole_Item_Record; X, Y : Glib.Gint) return Boolean; -- Override the inherited subprograms ---------------------- -- A resizable item -- ---------------------- type Resizable_Item_Record is new Display_Item_Record with null record; type Resizable_Item is access all Resizable_Item_Record'Class; procedure Draw (Item : access Resizable_Item_Record; Cr : Cairo.Cairo_Context); function On_Button_Click (Item : access Resizable_Item_Record; Event : Gdk.Event.Gdk_Event_Button) return Boolean; -- Override the inherited subprograms ---------------------------------------------------- -- Our own canvas, with optional background image -- ---------------------------------------------------- type Image_Canvas_Record is new Interactive_Canvas_Record with record Background : Cairo_Pattern := Null_Pattern; Draw_Grid : Boolean := True; end record; type Image_Canvas is access all Image_Canvas_Record'Class; procedure Draw_Background (Canvas : access Image_Canvas_Record; Cr : Cairo.Cairo_Context); -- Draw the background image procedure Draw_Grid (Canvas : access Image_Canvas_Record; Cr : Cairo.Cairo_Context); -- Draw the background grid ----------------------------- -- Misc. types and variables ----------------------------- package Canvas_Cb is new Gtk.Handlers.Callback (Interactive_Canvas_Record); package Canvas_User_Cb is new Gtk.Handlers.User_Callback (Gtk_Widget_Record, Image_Canvas); procedure Add_Canvas_Link (Canvas : access Interactive_Canvas_Record'Class; Item1, Item2 : access Canvas_Item_Record'Class; Text : String := ""); -- Add a link between Item1 and Item2 Max_Colors : constant := 20; Zoom_Levels : constant array (Positive range <>) of Gdouble := (0.1, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 2.0, 3.0, 4.0); Start_Spin, End_Spin, Num_Spin : Gtk_Spin_Button; Num_Items_Label, Num_Links_Label : Gtk_Label; Layout : Pango_Layout; type Color_Type is range 1 .. Max_Colors; package Color_Random is new Ada.Numerics.Discrete_Random (Color_Type); package Items_Random is new Ada.Numerics.Discrete_Random (Positive); use Items_Random; subtype Coordinate_Type is Gint range Default_Grid_Size + 1 .. Max_Size; package Coordinate_Random is new Ada.Numerics.Discrete_Random (Coordinate_Type); use Coordinate_Random; subtype Zoom_Type is Gint range 1 .. 2; package Zoom_Random is new Ada.Numerics.Discrete_Random (Zoom_Type); use Zoom_Random; type String_Access is access String; Color_Names : constant array (Color_Type) of String_Access := (new String'("forest green"), new String'("red"), new String'("blue"), new String'("yellow"), new String'("peach puff"), new String'("azure"), new String'("seashell"), new String'("lavender"), new String'("grey"), new String'("turquoise"), new String'("khaki"), new String'("tan"), new String'("orange red"), new String'("MediumPurple"), new String'("ivory1"), new String'("DeepSkyBlue1"), new String'("burlywood1"), new String'("wheat1"), new String'("orange1"), new String'("pink")); Colors : array (Color_Type) of Gdk_RGBA; Items_List : array (1 .. 500) of Canvas_Item; Last_Item : Positive; Last_Link : Positive; Item_Gen : Items_Random.Generator; Gen : Coordinate_Random.Generator; Color_Gen : Color_Random.Generator; Zoom_Gen : Zoom_Random.Generator; -- Note: All the generators above are intentionally not reset, so that -- we can get the same events every time and thus can reproduce behaviors. ---------- -- Help -- ---------- function Help return String is begin return "An @bInteractive_Canvas@B is an interactive widgets, on which" & " you can put items that the user will be able to manipulate" & " dynamically with the mouse." & ASCII.LF & "As you can see in this demo, the items can be linked together, and" & " the items remain connected when they are moved." & ASCII.LF & "The canvas also support @bscrolling@B, if put in a " & " @bGtk_Scrolled_Window@B, as you can see if you move the items" & " outside of the visible part of the canvas." & "There is a small area on each side of the canvas. If you leave the" & " mouse in this area while dragging an item, the canvas will" & " keep scrolling until the mouse is moved outside of this area." & ASCII.LF & "The canvas provides @bzooming@B capabilities. Try clicking on the" & " two arrow buttons at the top of this demo." & ASCII.LF & "The canvas includes a simple @blayout scheme@B, that can be" & " overriden with more complex algorithms. Items are stored in a" & " graph structure, tha includes a number of useful algorithms for" & " layout: topological sort,..." & ASCII.LF & "@bNon-rectangular items@B can also be used, see for instance the" & " two items 2 and 4 in the default layout." & ASCII.LF & "You can also redefine your own @btype of links@B. By default, links" & " are either straight or arc links, that may optionaly have arrows" & " on either end."; end Help; --------------------------- -- Draw_To_Double_Buffer -- --------------------------- procedure Draw (Item : access Display_Item_Record; Cr : Cairo_Context) is begin Gdk.Cairo.Set_Source_RGBA (Cr, Item.Color); Cairo.Rectangle (Cr, 0.5, 0.5, Gdouble (Item.W) - 1.0, Gdouble (Item.H) - 1.0); Cairo.Fill (Cr); Gdk.Cairo.Set_Source_RGBA (Cr, Item.Title); Rectangle (Cr, 0.5, 0.5, Gdouble (Item.W) - 1.0, Gdouble (Item.H) - 1.0); Cairo.Stroke (Cr); Set_Text (Layout, "Item" & Positive'Image (Display_Item (Item).Num)); Cairo.Move_To (Cr, 10.0, 10.0); Pango.Cairo.Show_Layout (Cr, Layout); end Draw; ---------- -- Draw -- ---------- procedure Draw (Item : access Resizable_Item_Record; Cr : Cairo_Context) is Rect : constant Cairo_Rectangle_Int := Get_Coord (Item); W : constant Gdouble := Gdouble (Rect.Width); H : constant Gdouble := Gdouble (Rect.Height); Arrow : constant Gdouble := 4.0; begin Cairo.Save (Cr); Set_Source_RGBA (Cr, Item.Color); Rectangle (Cr, 0.5, 0.5, W - 2.0 * Arrow - 1.0, H - 1.0); Cairo.Fill (Cr); Gdk.Cairo.Set_Source_RGBA (Cr, Item.Title); Rectangle (Cr, 0.5, 0.5, W - 2.0 * Arrow - 1.0, H - 1.0); Cairo.Stroke (Cr); Cairo.Restore (Cr); Cairo.Translate (Cr, W - Arrow - 0.5, 0.0); Cairo.Move_To (Cr, -Arrow / 2.0, Arrow + 0.5); Cairo.Line_To (Cr, 0.0, 0.5); Cairo.Line_To (Cr, Arrow / 2.0, Arrow + 0.5); Cairo.Stroke (Cr); Cairo.Move_To (Cr, -Arrow / 2.0, H - Arrow - 0.5); Cairo.Line_To (Cr, 0.0, H - 1.0); Cairo.Line_To (Cr, Arrow / 2.0, H - Arrow - 0.5); Cairo.Stroke (Cr); Cairo.Move_To (Cr, 0.0, 0.5); Cairo.Line_To (Cr, 0.0, H - 0.5); Cairo.Stroke (Cr); Cairo.Move_To (Cr, -Arrow, 0.5); Cairo.Line_To (Cr, Arrow, 0.5); Cairo.Stroke (Cr); Cairo.Move_To (Cr, -Arrow, H - 0.5); Cairo.Line_To (Cr, Arrow, H - 0.5); Cairo.Stroke (Cr); end Draw; ---------- -- Draw -- ---------- procedure Draw (Item : access Hole_Item_Record; Cr : Cairo_Context) is Item_Width : constant Gdouble := Gdouble (Get_Coord (Item).Width); Item_Height : constant Gdouble := Gdouble (Get_Coord (Item).Height); Item_Width_10 : constant Gdouble := Item_Width / 2.0 - 10.0; Item_Height_10 : constant Gdouble := Item_Height / 2.0 - 10.0; begin -- The trick to drawing non-rectangular items is to change the clip mask -- of the graphic context before calling the inherited subprogram. Cairo.Set_Fill_Rule (Cr, Cairo_Fill_Rule_Even_Odd); Cairo.Rectangle (Cr, 0.0, 0.0, Item_Width, Item_Height); Cairo.Rectangle (Cr, Item_Width_10, Item_Height_10, 20.0, 20.0); Clip (Cr); Cairo.Set_Fill_Rule (Cr, Cairo_Fill_Rule_Winding); Draw (Display_Item_Record (Item.all)'Access, Cr); Gdk.Cairo.Set_Source_RGBA (Cr, Item.Title); Cairo.Rectangle (Cr, Item_Width_10 - 0.5, Item_Height_10 - 0.5, 21.0, 21.0); Cairo.Stroke (Cr); end Draw; --------------------- -- On_Button_Click -- --------------------- function On_Button_Click (Item : access Resizable_Item_Record; Event : Gdk.Event.Gdk_Event_Button) return Boolean is Rect : constant Cairo_Rectangle_Int := Get_Coord (Item); begin if Event.The_Type = Button_Press and then Event.Button = 1 then if Gint (Event.Y) > Rect.Height - 4 then return True; end if; elsif Event.The_Type = Motion_Notify then if Event.Y > 4.0 then Set_Screen_Size (Item, Get_Coord (Item).Width, Gint (Event.Y)); end if; return True; end if; return False; end On_Button_Click; --------------------- -- Draw_Background -- --------------------- procedure Draw_Background (Canvas : access Image_Canvas_Record; Cr : Cairo.Cairo_Context) is begin if Canvas.Background /= Null_Pattern then Cairo.Save (Cr); Cairo.Set_Source (Cr, Canvas.Background); Cairo.Paint (Cr); Cairo.Restore (Cr); else Cairo.Save (Cr); Gdk.Cairo.Set_Source_RGBA (Cr, (0.8, 0.8, 0.8, 1.0)); Cairo.Paint (Cr); Cairo.Restore (Cr); end if; end Draw_Background; --------------- -- Draw_Grid -- --------------- procedure Draw_Grid (Canvas : access Image_Canvas_Record; Cr : Cairo.Cairo_Context) is begin if Canvas.Draw_Grid then Draw_Grid (Interactive_Canvas_Record (Canvas.all)'Access, Cr); end if; end Draw_Grid; ------------------- -- Point_In_Item -- ------------------- function Point_In_Item (Item : access Hole_Item_Record; X, Y : Glib.Gint) return Boolean is W : constant Gint := Get_Coord (Item).Width / 2; H : constant Gint := Get_Coord (Item).Height / 2; X2 : constant Gint := X - Get_Coord (Item).X; Y2 : constant Gint := Y - Get_Coord (Item).Y; begin if X2 >= W - 10 and then X2 <= W + 10 and then Y2 >= H - 10 and then Y2 <= H + 10 then return False; else return Point_In_Item (Display_Item_Record (Item.all)'Access, X, Y); end if; end Point_In_Item; ---------------- -- Initialize -- ---------------- procedure Initialize (Item : access Display_Item_Record'Class; Canvas : access Interactive_Canvas_Record'Class) is begin Item.Canvas := Interactive_Canvas (Canvas); Item.Color := Colors (Color_Random.Random (Color_Gen)); Item.Title := (0.0, 0.0, 0.0, 1.0); Item.W := Item_Width * Random (Zoom_Gen); Item.H := Item_Height * Random (Zoom_Gen); Item.Num := Last_Item; if Last_Item <= Items_List'Last then Items_List (Item.Num) := Canvas_Item (Item); end if; Last_Item := Last_Item + 1; Set_Screen_Size (Item, Item.W, Item.H); Set_Text (Num_Items_Label, Positive'Image (Last_Item - 1) & " items"); end Initialize; --------------------- -- Add_Random_Item -- --------------------- procedure Add_Random_Item (Canvas : access Interactive_Canvas_Record'Class) is Item : constant Display_Item := new Display_Item_Record; begin Initialize (Item, Canvas); Put (Canvas, Item, Random (Gen), Random (Gen)); Refresh_Canvas (Canvas); Show_Item (Canvas, Item); end Add_Random_Item; ----------- -- Clear -- ----------- procedure Clear (Canvas : access Interactive_Canvas_Record'Class) is function Remove_Internal (Canvas : access Interactive_Canvas_Record'Class; Item : access Canvas_Item_Record'Class) return Boolean is begin Remove (Canvas, Item); return True; end Remove_Internal; begin For_Each_Item (Canvas, Remove_Internal'Unrestricted_Access); Refresh_Canvas (Canvas); Last_Item := 1; Last_Link := 1; Set_Text (Num_Items_Label, Positive'Image (Last_Item - 1) & " items"); Set_Text (Num_Links_Label, Positive'Image (Last_Link - 1) & " links"); end Clear; --------------- -- Add_Items -- --------------- procedure Add_Items (Canvas : access Interactive_Canvas_Record'Class) is Max : constant Positive := Last_Item + Positive (Get_Value_As_Int (Num_Spin)) - 1; begin for J in Last_Item .. Max loop Add_Random_Item (Canvas); Add_Canvas_Link (Canvas, Items_List (J), Items_List (Random (Item_Gen) mod J + 1)); Add_Canvas_Link (Canvas, Items_List (J), Items_List (Random (Item_Gen) mod J + 1)); end loop; Refresh_Canvas (Canvas); end Add_Items; --------------------- -- Add_Single_Item -- --------------------- procedure Add_Single_Item (Canvas : access Interactive_Canvas_Record'Class; With_Link : Boolean) is Item : constant Display_Item := new Display_Item_Record; Num : constant Positive := Positive (Get_Value_As_Int (Start_Spin)); begin Initialize (Item, Canvas); if With_Link and then Num < Last_Item then Add_Canvas_Link (Canvas, Item, Item, "0"); Add_Canvas_Link (Canvas, Items_List (Num), Item, "1"); Add_Canvas_Link (Canvas, Items_List (Num), Item, "2"); end if; Put (Canvas, Item); Refresh_Canvas (Canvas); Show_Item (Canvas, Item); end Add_Single_Item; ------------------------------- -- Add_Single_Item_With_Link -- ------------------------------- procedure Add_Single_Item_With_Link (Canvas : access Interactive_Canvas_Record'Class) is begin Add_Single_Item (Canvas, True); end Add_Single_Item_With_Link; ----------------------------- -- Add_Single_Item_No_Link -- ----------------------------- procedure Add_Single_Item_No_Link (Canvas : access Interactive_Canvas_Record'Class) is begin Add_Single_Item (Canvas, False); end Add_Single_Item_No_Link; --------------------- -- Add_Canvas_Link -- --------------------- procedure Add_Canvas_Link (Canvas : access Interactive_Canvas_Record'Class; Item1, Item2 : access Canvas_Item_Record'Class; Text : String := "") is Link : constant Canvas_Link := new Canvas_Link_Record; begin Add_Link (Canvas, Link, Item1, Item2, Both_Arrow, Text); Last_Link := Last_Link + 1; Set_Text (Num_Links_Label, Positive'Image (Last_Link - 1) & " links"); end Add_Canvas_Link; ----------------- -- Remove_Link -- ----------------- procedure Remove_Link (Canvas : access Interactive_Canvas_Record'Class) is It1, It2 : Canvas_Item; function Remove_Internal (Canvas : access Interactive_Canvas_Record'Class; Link : access Canvas_Link_Record'Class) return Boolean is pragma Warnings (Off, Canvas); begin if (Canvas_Item (Get_Src (Link)) = It1 and then Canvas_Item (Get_Dest (Link)) = It2) or else (Canvas_Item (Get_Src (Link)) = It2 and then Canvas_Item (Get_Dest (Link)) = It1) then Remove_Link (Canvas, Link); return False; end if; return True; end Remove_Internal; Num1 : constant Positive := Positive (Get_Value_As_Int (Start_Spin)); Num2 : constant Positive := Positive (Get_Value_As_Int (End_Spin)); begin if Num1 < Last_Item and then Num2 < Last_Item then It1 := Items_List (Num1); It2 := Items_List (Num2); For_Each_Link (Canvas, Remove_Internal'Unrestricted_Access); Refresh_Canvas (Canvas); end if; end Remove_Link; ------------- -- Zoom_In -- ------------- procedure Zoom_In (Canvas : access Interactive_Canvas_Record'Class) is begin for J in Zoom_Levels'First .. Zoom_Levels'Last - 1 loop if Zoom_Levels (J) = Get_Zoom (Canvas) then Zoom (Canvas, Zoom_Levels (J + 1), 0.2); end if; end loop; end Zoom_In; -------------- -- Zoom_Out -- -------------- procedure Zoom_Out (Canvas : access Interactive_Canvas_Record'Class) is begin for J in Zoom_Levels'First + 1 .. Zoom_Levels'Last loop if Zoom_Levels (J) = Get_Zoom (Canvas) then Zoom (Canvas, Zoom_Levels (J - 1), 0.2); end if; end loop; end Zoom_Out; ------------------- -- Initial_Setup -- ------------------- procedure Initial_Setup (Canvas : access Interactive_Canvas_Record'Class) is Item1, Item2, Item3, Item4 : Display_Item; Item5 : Resizable_Item; Link : Canvas_Link; begin Color_Random.Reset (Color_Gen); Item1 := new Display_Item_Record; Initialize (Item1, Canvas); Put (Canvas, Item1, 10, 10); Item2 := new Hole_Item_Record; Initialize (Item2, Canvas); Put (Canvas, Item2, 70, 240); Item3 := new Display_Item_Record; Initialize (Item3, Canvas); Put (Canvas, Item3, 200, 10); Item4 := new Hole_Item_Record; Initialize (Item4, Canvas); Put (Canvas, Item4, 280, 170); Item5 := new Resizable_Item_Record; Initialize (Item5, Canvas); Set_Screen_Size (Item5, 30, 30); Put (Canvas, Item5, 200, 170); Add_Canvas_Link (Canvas, Item1, Item1, "Self 1->1"); Add_Canvas_Link (Canvas, Item3, Item1, "From3->1"); Add_Canvas_Link (Canvas, Item1, Item4, "From1->4(1)"); Add_Canvas_Link (Canvas, Item1, Item4, "From1->4(2)"); Add_Canvas_Link (Canvas, Item2, Item3, "From2->3"); Add_Canvas_Link (Canvas, Item2, Item4, "From2->4"); Add_Canvas_Link (Canvas, Item3, Item4, "From3->4(1)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item3, Item4, Start_Arrow, "From3->4(2)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item4, Item3, End_Arrow, "From3->4(3)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item3, Item4, Both_Arrow, "From3->4(4)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item4, Item3, Both_Arrow, "From3->4(5)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item3, Item4, Both_Arrow, "From3->4(6)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item2, Item2, No_Arrow, "Self 2->2 (1)"); Link := new Canvas_Link_Record; Add_Link (Canvas, Link, Item2, Item2, Start_Arrow, "Self 2->2 (2)"); Last_Link := Last_Link + 7; Set_Text (Num_Links_Label, Positive'Image (Last_Link - 1) & " links"); end Initial_Setup; ------------------ -- Toggle_Align -- ------------------ procedure Toggle_Align (Align : access Gtk_Widget_Record'Class; Canvas : Image_Canvas) is begin Align_On_Grid (Canvas, Get_Active (Gtk_Check_Button (Align))); end Toggle_Align; ---------------------- -- Toggle_Draw_Grid -- ---------------------- procedure Toggle_Draw_Grid (Align : access Gtk_Widget_Record'Class; Canvas : Image_Canvas) is begin Canvas.Draw_Grid := Get_Active (Gtk_Check_Button (Align)); Refresh_Canvas (Canvas); end Toggle_Draw_Grid; ----------------------- -- Toggle_Orthogonal -- ----------------------- procedure Toggle_Orthogonal (Align : access Gtk_Widget_Record'Class; Canvas : Image_Canvas) is begin Set_Orthogonal_Links (Canvas, Get_Active (Gtk_Check_Button (Align))); Refresh_Canvas (Canvas); end Toggle_Orthogonal; ------------------------ -- Background_Changed -- ------------------------ procedure Background_Changed (Bg_Draw : access Gtk_Widget_Record'Class; Canvas : Image_Canvas) is Surface : Cairo_Surface; begin if Get_Active (Gtk_Check_Button (Bg_Draw)) then Surface := Cairo.Png.Create_From_Png ("background.png"); Canvas.Background := Cairo.Pattern.Create_For_Surface (Surface); Cairo.Pattern.Set_Extend (Canvas.Background, Cairo_Extend_Repeat); Destroy (Surface); else if Canvas.Background /= Null_Pattern then Destroy (Canvas.Background); Canvas.Background := Null_Pattern; end if; end if; Refresh_Canvas (Canvas); end Background_Changed; --------- -- Run -- --------- procedure Run (Frame : access Gtk.Frame.Gtk_Frame_Record'Class) is Canvas : Image_Canvas; Box, Bbox, Bbox2, Bbox3, Spin_Box, Small : Gtk_Box; Button : Gtk_Button; Arrow : Gtk_Arrow; Scrolled : Gtk_Scrolled_Window; Label : Gtk_Label; Adj : Gtk_Adjustment; F : Gtk_Frame; Align : Gtk_Check_Button; Success : Boolean; begin Last_Item := Items_List'First; Last_Link := 1; Gtk_New_Vbox (Box, Homogeneous => False); Add (Frame, Box); Gtk_New_Hbox (Bbox, Homogeneous => True); Pack_Start (Box, Bbox, Expand => False, Fill => False); Gtk_New_Hbox (Bbox2, Homogeneous => True); Pack_Start (Box, Bbox2, Expand => False, Fill => False); Gtk_New_Hbox (Bbox3, Homogeneous => True); Pack_Start (Box, Bbox3, Expand => False, Fill => False); Gtk_New_Hbox (Spin_Box, Homogeneous => True); Pack_Start (Box, Spin_Box, Expand => False, Fill => False); Gtk_New (F); Pack_Start (Box, F); Gtk_New (Scrolled); Set_Policy (Scrolled, Policy_Automatic, Policy_Automatic); Add (F, Scrolled); Canvas := new Image_Canvas_Record; Initialize (Canvas); Add (Scrolled, Canvas); Align_On_Grid (Canvas, False); Gtk_New (Button); Gtk_New (Arrow, Arrow_Up, Shadow_Out); Add (Button, Arrow); Pack_Start (Bbox, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Zoom_In'Access), Canvas); Gtk_New (Button); Gtk_New (Arrow, Arrow_Down, Shadow_Out); Add (Button, Arrow); Pack_Start (Bbox, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Zoom_Out'Access), Canvas); Gtk_New (Button, "Random"); Pack_Start (Bbox, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Add_Random_Item'Access), Canvas); Gtk_New (Button, "Add One"); Pack_Start (Bbox, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Add_Single_Item_No_Link'Access), Canvas); Gtk_New (Button, "Clear"); Pack_Start (Bbox, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Clear'Access), Canvas); Gtk_New (Button, "Remove Link Start->End"); Pack_Start (Bbox2, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Remove_Link'Access), Canvas); Gtk_New (Button, "Add multiple Items"); Pack_Start (Bbox2, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Add_Items'Access), Canvas); Gtk_New (Button, "Add with Link->Start"); Pack_Start (Bbox2, Button, Expand => False, Fill => True); Canvas_Cb.Object_Connect (Button, "clicked", Canvas_Cb.To_Marshaller (Add_Single_Item_With_Link'Access), Canvas); Gtk_New (Align, "Align on grid"); Set_Active (Align, Get_Align_On_Grid (Canvas)); Pack_Start (Bbox3, Align, Expand => False, Fill => True); Canvas_User_Cb.Connect (Align, "toggled", Canvas_User_Cb.To_Marshaller (Toggle_Align'Access), Canvas); Gtk_New (Align, "Draw grid"); Set_Active (Align, Canvas.Draw_Grid); Pack_Start (Bbox3, Align, Expand => False, Fill => True); Canvas_User_Cb.Connect (Align, "toggled", Canvas_User_Cb.To_Marshaller (Toggle_Draw_Grid'Access), Canvas); Gtk_New (Align, "Orthogonal links"); Set_Active (Align, Get_Orthogonal_Links (Canvas)); Pack_Start (Bbox3, Align, Expand => False, Fill => True); Canvas_User_Cb.Connect (Align, "toggled", Canvas_User_Cb.To_Marshaller (Toggle_Orthogonal'Access), Canvas); Gtk_New (Align, "draw background"); Set_Active (Align, Canvas.Background /= Null_Pattern); Pack_Start (Bbox3, Align, Expand => True, Fill => True); Canvas_User_Cb.Connect (Align, "toggled", Canvas_User_Cb.To_Marshaller (Background_Changed'Access), Canvas); Background_Changed (Align, Canvas); Gtk_New (Num_Items_Label, "0 items"); Pack_Start (Spin_Box, Num_Items_Label, Expand => False, Fill => False); Gtk_New (Num_Links_Label, "0 links"); Pack_Start (Spin_Box, Num_Links_Label, Expand => False, Fill => False); Gtk_New_Hbox (Small, Homogeneous => False); Gtk_New (Label, "Add:"); Pack_Start (Small, Label, Expand => False, Fill => False); Gtk_New (Adj, 10.0, 1.0, 300.0, 1.0, 30.0); Gtk_New (Num_Spin, Adj, 0.5, 0); Pack_Start (Small, Num_Spin, Expand => False, Fill => False); Pack_Start (Spin_Box, Small, Expand => False, Fill => False); Gtk_New_Hbox (Small, Homogeneous => False); Gtk_New (Label, "Start:"); Pack_Start (Small, Label, Expand => False, Fill => False); Gtk_New (Adj, 1.0, 1.0, 300.0, 1.0, 30.0); Gtk_New (Start_Spin, Adj, 0.5, 0); Pack_Start (Small, Start_Spin, Expand => False, Fill => False); Pack_Start (Spin_Box, Small, Expand => False, Fill => False); Gtk_New_Hbox (Small, Homogeneous => False); Gtk_New (Label, "End:"); Pack_Start (Small, Label, Expand => False, Fill => False); Gtk_New (Adj, 2.0, 1.0, 300.0, 1.0, 30.0); Gtk_New (End_Spin, Adj, 0.5, 0); Pack_Start (Small, End_Spin, Expand => False, Fill => False); Pack_Start (Spin_Box, Small, Expand => False, Fill => False); Realize (Canvas); -- Initialize the colors. They no longer need to be allocated in -- gtk3. for J in Color_Names'Range loop Parse (Colors (J), Color_Names (J).all, Success); end loop; Layout := Create_Pango_Layout (Frame); Initial_Setup (Canvas); Show_All (Frame); end Run; end Create_Canvas;