1------------------------------------------------------------------------------ 2-- GtkAda - Ada95 binding for Gtk+/Gnome -- 3-- -- 4-- Copyright (C) 1998-2000 E. Briot, J. Brobecker and A. Charlet -- 5-- Copyright (C) 1998-2015, AdaCore -- 6-- -- 7-- This library is free software; you can redistribute it and/or modify it -- 8-- under terms of the GNU General Public License as published by the Free -- 9-- Software Foundation; either version 3, or (at your option) any later -- 10-- version. This library is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 13-- -- 14-- As a special exception under Section 7 of GPL version 3, you are granted -- 15-- additional permissions described in the GCC Runtime Library Exception, -- 16-- version 3.1, as published by the Free Software Foundation. -- 17-- -- 18-- You should have received a copy of the GNU General Public License and -- 19-- a copy of the GCC Runtime Library Exception along with this program; -- 20-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 21-- <http://www.gnu.org/licenses/>. -- 22-- -- 23------------------------------------------------------------------------------ 24 25with Ada.Numerics; use Ada.Numerics; 26with Ada.Numerics.Generic_Elementary_Functions; 27with Interfaces.C.Strings; use Interfaces.C.Strings; 28with System; 29with Unchecked_Deallocation; 30with GNAT.IO; use GNAT.IO; 31 32with Cairo; use Cairo; 33with Cairo.Image_Surface; use Cairo.Image_Surface; 34with Cairo.Pattern; use Cairo.Pattern; 35with Cairo.Region; use Cairo.Region; 36with Cairo.Surface; use Cairo.Surface; 37with Pango.Cairo; use Pango.Cairo; 38 39with Glib; use Glib; 40with Glib.Graphs; use Glib.Graphs; 41with Glib.Main; use Glib.Main; 42with Glib.Object; use Glib.Object; 43 44with Gdk; use Gdk; 45with Gdk.Cairo; use Gdk.Cairo; 46with Gdk.Color; use Gdk.Color; 47with Gdk.Cursor; use Gdk.Cursor; 48with Gdk.Event; use Gdk.Event; 49with Gdk.Rectangle; use Gdk.Rectangle; 50with Gdk.RGBA; use Gdk.RGBA; 51with Gdk.Window; use Gdk.Window; 52with Gdk.Types; use Gdk.Types; 53with Gdk.Types.Keysyms; use Gdk.Types.Keysyms; 54 55with Gtk.Adjustment; use Gtk.Adjustment; 56with Gtk.Arguments; use Gtk.Arguments; 57with Gtk.Enums; use Gtk.Enums; 58with Gtk.Handlers; 59with Gtk.Main; 60with Gtk.Widget; use Gtk.Widget; 61 62with Gtkada.Bindings; use Gtkada.Bindings; 63with Gtkada.Handlers; use Gtkada.Handlers; 64 65with Pango.Font; use Pango.Font; 66with Pango.Layout; use Pango.Layout; 67 68-- TODO: 69-- - would be nice to have a pixbuf item directly (for alpha layers) 70 71package body Gtkada.Canvas is 72 73 package Double_Elementary_Functions is new 74 Ada.Numerics.Generic_Elementary_Functions (Gdouble); 75 use Double_Elementary_Functions; 76 77 use type Gdk.Gdk_Window; 78 use type System.Address; 79 80 Traces : constant Boolean := False; 81 82 Class_Record : Ada_GObject_Class := Uninitialized_Class; 83 -- This pointer will keep a pointer to the C 'class record' for 84 -- gtk. To avoid allocating memory for each widget, this may be done 85 -- only once, and reused. 86 -- ??? This is a global variable. 87 88 Timeout_Between_Scrolls : constant := 50; 89 -- Time between two scrollings when the mouse is in the bounding box. 90 91 Scrolling_Margin : constant := 10; 92 -- Width and height of the surrounding box in which "infinite" 93 -- scrolling is started (it will continue while the mouse is kept in this 94 -- area or moved outside of the canvas) 95 96 Scrolling_Amount_Min : constant Gdouble := 10.0; 97 Scrolling_Amount_Max : constant Gdouble := 20.0; 98 Scrolling_Amount_Increase : constant Gdouble := 1.05; -- +5% every step 99 -- Number of pixels to scroll while the mouse is in the surrounding 100 -- box. This is the initial value, and will keep increasing while the mouse 101 -- is left in the box. 102 103 Links_Threshold_While_Moving : constant := 20; 104 -- Maximal number of links that are drawn while moving an item. This is 105 -- used to make the canvas still usable when there are lots of links to a 106 -- given item. 107 108 Signals : constant chars_ptr_array := 109 (1 => New_String (String (Signal_Background_Click)), 110 2 => New_String (String (Signal_Item_Selected)), 111 3 => New_String (String (Signal_Zoomed)), 112 4 => New_String (String (Signal_Set_Scroll_Adjustments)), 113 5 => New_String (String (Signal_Item_Unselected)), 114 6 => New_String (String (Signal_Item_Moved))); 115 -- Array of the signals created for this widget 116 117 type Bounds_Modification_Mode is (Grow_Only, Clamp, Do_Not_Change); 118 -- Grow_Only : the bounds of the canvas may grow but should not shrink 119 -- Clamp : the bounds get adjusted to the current item requisitions 120 -- Do_Not_Change: no modification is made to the bounds of the canvas 121 122 ----------------- 123 -- Subprograms -- 124 ----------------- 125 -- Note: Some callbacks take Gtk_Widget_Record parameters, so that we can 126 -- reuse the callbacks in Gtkada.Handlers, and thus save a lot of space 127 -- in the GtkAda library. 128 129 procedure Free is new Unchecked_Deallocation (String, String_Access); 130 131 package Canvas_Timeout is 132 new Glib.Main.Generic_Sources (Interactive_Canvas); 133 134 function On_Draw 135 (Canv : access Gtk_Widget_Record'Class; 136 Cr : Cairo_Context) return Boolean; 137 -- Handle the "draw" events for a canvas. 138 139 procedure Canvas_Destroyed 140 (Canvas : access Gtk_Widget_Record'Class); 141 -- Called when the canvas is being destroyed. All the items and links 142 -- are removed, and the double-buffer is freed 143 144 procedure Size_Allocate 145 (Canv : access Gtk_Widget_Record'Class; Args : Gtk_Args); 146 -- When the item is resized. 147 148 function Button_Pressed 149 (Canv : access Gtk_Widget_Record'Class; 150 Event : Gdk_Event) return Boolean; 151 -- Called when the user has pressed the mouse button in the canvas. 152 -- This tests whether an item was selected. 153 154 function Button_Release 155 (Canv : access Gtk_Widget_Record'Class; 156 Event : Gdk_Event) return Boolean; 157 -- Called when the user has released the mouse button. 158 -- If an item was selected, this refreshed the canvas. 159 160 function Button_Motion 161 (Canv : access Gtk_Widget_Record'Class; 162 Event : Gdk_Event) return Boolean; 163 -- Called when the user moves the mouse while a button is pressed. 164 -- If an item was selected, the item is moved. 165 166 function Key_Press 167 (Canv : access Gtk_Widget_Record'Class; 168 Event : Gdk_Event) return Boolean; 169 -- Handle key events, to provide scrolling through Page Up, Page Down, and 170 -- arrow keys. 171 172 function Canvas_To_World_Length 173 (Self : not null access Interactive_Canvas_Record'Class; 174 Length_Canvas : Gdouble) return Gdouble; 175 function Canvas_To_World_X 176 (Self : not null access Interactive_Canvas_Record'Class; 177 X_Canvas : Gdouble) return Gdouble; 178 function Canvas_To_World_Y 179 (Self : not null access Interactive_Canvas_Record'Class; 180 Y_Canvas : Gdouble) return Gdouble; 181 -- Convert from canvas coordinates to world coordinates. 182 183 function World_To_Canvas_X 184 (Self : not null access Interactive_Canvas_Record'Class; 185 X_World : Gdouble) return Gdouble; 186 function World_To_Canvas_Length 187 (Self : not null access Interactive_Canvas_Record'Class; 188 Length_World : Gdouble) return Gdouble; 189 function World_To_Canvas_Y 190 (Self : not null access Interactive_Canvas_Record'Class; 191 Y_World : Gdouble) return Gdouble; 192 -- Converts from world coordinates to canvas coordinates 193 194 procedure Mouse_To_World 195 (Canvas : access Interactive_Canvas_Record'Class; 196 Event : Gdk_Event; 197 X_World : out Gdouble; 198 Y_World : out Gdouble); 199 -- Convert from mouse coordinates to world coordinates. 200 201 function Get_Actual_Coordinates 202 (Self : not null access Interactive_Canvas_Record'Class; 203 Item : not null access Canvas_Item_Record'Class) 204 return Cairo_Rectangle_Int; 205 -- Return the actual world coordinate for an item (including an extra 206 -- offset to add when we are dragging that item). 207 208 procedure Draw_Area 209 (Canvas : access Interactive_Canvas_Record'Class; 210 Rect : Cairo_Rectangle_Int; 211 Cr : Cairo_Context); 212 213 procedure Draw_Orthogonal_Link 214 (Canvas : access Interactive_Canvas_Record'Class; 215 Cr : Cairo_Context; 216 Link : access Canvas_Link_Record'Class; 217 Show_Annotation : Boolean); 218 -- Draw a link on the screen, as possibly several orthogonal lines. 219 -- This link includes both an arrow head on its destination, and an 220 -- optional text displayed approximatively in its middle. 221 222 procedure Draw_Straight_Link 223 (Canvas : access Interactive_Canvas_Record'Class; 224 Cr : Cairo_Context; 225 Link : access Canvas_Link_Record'Class; 226 Show_Annotation : Boolean); 227 -- Draw Link on the screen as a straight line. 228 -- This link includes both an arrow head on its destination, and an 229 -- optional text displayed approximatively in its middle. 230 231 procedure Draw_Arc_Link 232 (Canvas : access Interactive_Canvas_Record'Class; 233 Cr : Cairo_Context; 234 Link : access Canvas_Link_Record'Class; 235 Offset : Gint; 236 Show_Annotation : Boolean); 237 -- Draw Link on the screen. 238 -- The link is drawn as a curved link (ie there is an extra handle in its 239 -- middle). 240 -- This link includes both an arrow head on its destination, and an 241 -- optional text displayed approximatively in its middle. 242 243 procedure Draw_Self_Link 244 (Canvas : access Interactive_Canvas_Record'Class; 245 Cr : Cairo_Context; 246 Link : access Canvas_Link_Record'Class; 247 Offset : Gint; 248 Show_Annotation : Boolean); 249 -- Draw a link when its source and destination items are the same 250 251 procedure Update_Adjustments 252 (Canvas : access Interactive_Canvas_Record'Class; 253 Behavior : Bounds_Modification_Mode := Clamp); 254 -- Update the adjustments of the canvas. 255 -- The bounds for the adjustments are automatically computed, given the 256 -- list of items in it. 257 258 procedure Draw_Arrow_Head 259 (Canvas : access Interactive_Canvas_Record'Class; 260 Cr : Cairo_Context; 261 X_Canvas : Gdouble; 262 Y_Canvas : Gdouble; 263 Angle : Gdouble); 264 -- Draw an arrow head at the position (X, Y) on the canvas. The position 265 -- is given in pixels, and should include zoom processing. 266 -- Angle is the angle of the main axis of the arrow. 267 268 procedure Draw_Annotation 269 (Canvas : access Interactive_Canvas_Record'Class; 270 Cr : Cairo_Context; 271 X_Canvas : Gdouble; 272 Y_Canvas : Gdouble; 273 Link : access Canvas_Link_Record'Class); 274 -- Print an annotation on the canvas. 275 -- The annotation is centered around (X, Y), in pixels. These coordinates 276 -- should already include zoom processing. 277 278 procedure Set_Scroll_Adjustments 279 (Canvas : access Gtk_Widget_Record'Class); 280 -- Change the two adjustments used for the canvas (in a callback) 281 282 procedure Scrolled (Canvas : access Gtk_Widget_Record'Class); 283 -- Called everytime the value of one of the adjustments is changed. 284 285 procedure Get_Bounding_Box 286 (Canvas : access Interactive_Canvas_Record'Class; 287 X_Min, X_Max, Y_Min, Y_Max : out Gdouble); 288 -- Find the smallest bounding box for all the items in the canvas. 289 -- Note that this does not include links, which might thus be found 290 -- outside of this box. 291 -- The returned values are in world coordinates 292 293 procedure Test_Scrolling_Box 294 (Canvas : access Interactive_Canvas_Record'Class; 295 Mouse_X_In_Canvas, Mouse_Y_In_Canvas : Gdouble; 296 X_Scroll : out Gdouble; 297 Y_Scroll : out Gdouble); 298 -- We keep moving the selection (and scrolling the canvas) as long as the 299 -- mouse remains in a surrounding box around the canvas, or even outside 300 -- the canvas. This is done even if the mouse doesn't move, so at to make 301 -- it easier to move items. This subprogram tests whether the pointer is 302 -- found in that box, and returns the extra scrolling that should be 303 -- done. (0, 0) is returned if the mouse is not in that box. 304 -- (Mouse_X_In_Canvas, Mouse_Y_In_Canvas) are the screen coordinates of the 305 -- mouse in the canvas. 306 307 function Scrolling_Timeout (Canvas : Interactive_Canvas) return Boolean; 308 -- Function called repeatedly while the mouse is in the scrolling box. 309 -- This provides scrolling even when the mouse doesn't move 310 311 procedure Scroll_Canvas_To_Area 312 (Canvas : access Interactive_Canvas_Record'Class; 313 X1, Y1, X2, Y2 : Gdouble; 314 Canvas_X, Canvas_Y : Gdouble := 0.5); 315 -- Scroll the visible area of the canvas so that the given area 316 -- (X1, Y1) .. (X2, Y2) is made visible. 317 -- These are in world coordinates. 318 -- If Ignore_If_Visible is true and the area is already visible, do nothing 319 -- (Canvas_X, Canvas_Y) indicates at which part of the canvas the region 320 -- should be centered. If these are greater than 1.0, minimal scrolling is 321 -- done. 322 323 function Move_Selection 324 (Canvas : access Interactive_Canvas_Record'Class; 325 New_Offset_X_World, New_Offset_Y_World : Gdouble; 326 Behavior : Bounds_Modification_Mode) return Boolean; 327 -- Moves all selected items by a specific amount. 328 -- The move is relative to the initial position of the items, and 329 -- (Delta_X_World, Delta_Y_World) are given in world coordinates. 330 -- Return True if the selection was actually moved, False if for some 331 -- reason nothing happened. 332 -- (Mouse_X_In_Canvas, Mouse_Y_In_Canvas) are the screen coordinates of the 333 -- mouse in the canvas. 334 335 procedure Show_Item 336 (Canvas : access Interactive_Canvas_Record'Class; 337 Item : access Canvas_Item_Record'Class; 338 Canvas_X, Canvas_Y : Gdouble); 339 -- Like Show_Item. 340 -- (Canvas_X, Canvas_Y) are the position in the canvas where the center of 341 -- the item should be put. (0,0) is on the top-left, (1,1) is bottom-right. 342 -- 343 -- Nothing is done if the item is already visible. 344 345 procedure Draw_Dashed_Selection 346 (Canvas : access Interactive_Canvas_Record'Class; 347 Cr : Cairo_Context); 348 -- Draw all the selected items and links with dashed-lines. 349 350 function Zoom_Timeout (Canvas : Interactive_Canvas) return Boolean; 351 -- Timeout function used to provide smooth zooming. 352 353 procedure Zoom_Internal 354 (Canvas : access Interactive_Canvas_Record'Class; Percent : Gdouble); 355 -- Internal function to implement zooming 356 357 function Get_Background_Selection_Rectangle 358 (Canvas : access Interactive_Canvas_Record'Class) return Gdk_Rectangle; 359 -- Return the coordinates of the rectangle representing the background 360 -- selection (when the user clicks in the background and drags the mouse). 361 -- Return coordinates are in world coordinates 362 363 procedure Emit_By_Name_Item 364 (Object : System.Address; 365 Name : String; 366 Param : access Canvas_Item_Record'Class); 367 -- ??? 368 369 function Compute_Line_Pos 370 (Canvas : access Interactive_Canvas_Record'Class) return Gint_Array; 371 -- ??? 372 373 procedure Scroll_Canvas_To_Item 374 (Canvas : access Interactive_Canvas_Record'Class; 375 Item : access Canvas_Item_Record'Class; 376 Canvas_X, Canvas_Y : Gdouble := 0.5); 377 -- Scroll the canvas to the item. This function tries to scroll the canvas 378 -- as little as possible, typically used when the item is moving out of the 379 -- window. 380 381 function Create 382 (Canvas : access Interactive_Canvas_Record'Class) return Cairo_Context; 383 -- ??? 384 385 procedure Get_Visible_World 386 (Canvas : access Interactive_Canvas_Record'Class; 387 X1, Y1, X2, Y2 : out Gdouble); 388 -- Return the world area currently visible in the canvas 389 390 procedure Set_Transform 391 (Self : not null access Interactive_Canvas_Record'Class; 392 Cr : Cairo_Context; 393 X_World : Gdouble := Gdouble'First; 394 Y_World : Gdouble := Gdouble'First); 395 -- Set the transformation matrix for the current settings. 396 -- If x and y are specified, all drawing coordinates from now on become 397 -- relative to that position (convenient for drawing the same thing in 398 -- various locations for instance: pass the location to Set_Transform). 399 400 ---------------------------- 401 -- World_To_Canvas_Length -- 402 ---------------------------- 403 404 function World_To_Canvas_Length 405 (Self : not null access Interactive_Canvas_Record'Class; 406 Length_World : Gdouble) return Gdouble is 407 begin 408 return Length_World * Self.Zoom; 409 end World_To_Canvas_Length; 410 411 ---------------------------- 412 -- Canvas_To_World_Length -- 413 ---------------------------- 414 415 function Canvas_To_World_Length 416 (Self : not null access Interactive_Canvas_Record'Class; 417 Length_Canvas : Gdouble) return Gdouble is 418 begin 419 return Length_Canvas / Self.Zoom; 420 end Canvas_To_World_Length; 421 422 ----------------------- 423 -- World_To_Canvas_X -- 424 ----------------------- 425 426 function World_To_Canvas_X 427 (Self : not null access Interactive_Canvas_Record'Class; 428 X_World : Gdouble) return Gdouble is 429 begin 430 return (X_World - Self.World_X) * Self.Zoom; 431 end World_To_Canvas_X; 432 433 ----------------------- 434 -- World_To_Canvas_Y -- 435 ----------------------- 436 437 function World_To_Canvas_Y 438 (Self : not null access Interactive_Canvas_Record'Class; 439 Y_World : Gdouble) return Gdouble is 440 begin 441 return (Y_World - Self.World_Y) * Self.Zoom; 442 end World_To_Canvas_Y; 443 444 ----------------------- 445 -- Canvas_To_World_X -- 446 ----------------------- 447 448 function Canvas_To_World_X 449 (Self : not null access Interactive_Canvas_Record'Class; 450 X_Canvas : Gdouble) return Gdouble is 451 begin 452 return X_Canvas / Self.Zoom + Self.World_X; 453 end Canvas_To_World_X; 454 455 ----------------------- 456 -- Canvas_To_World_Y -- 457 ----------------------- 458 459 function Canvas_To_World_Y 460 (Self : not null access Interactive_Canvas_Record'Class; 461 Y_Canvas : Gdouble) return Gdouble is 462 begin 463 return Y_Canvas / Self.Zoom + Self.World_Y; 464 end Canvas_To_World_Y; 465 466 ------------------- 467 -- Set_Transform -- 468 ------------------- 469 470 procedure Set_Transform 471 (Self : not null access Interactive_Canvas_Record'Class; 472 Cr : Cairo_Context; 473 X_World : Gdouble := Gdouble'First; 474 Y_World : Gdouble := Gdouble'First) 475 is 476 M : aliased Cairo_Matrix; 477 begin 478 M.Xx := Self.Zoom; 479 M.Xy := 0.0; 480 481 if X_World /= Gdouble'First then 482 M.X0 := Self.World_To_Canvas_X (X_World); 483 else 484 M.X0 := -Self.Zoom * Self.World_X; 485 end if; 486 487 M.Yx := 0.0; 488 M.Yy := Self.Zoom; 489 490 if Y_World /= Gdouble'First then 491 M.Y0 := Self.World_To_Canvas_Y (Y_World); 492 else 493 M.Y0 := -Self.Zoom * Self.World_Y; 494 end if; 495 496 Set_Matrix (Cr, M'Access); 497 end Set_Transform; 498 499 ----------------------- 500 -- Get_Visible_World -- 501 ----------------------- 502 503 procedure Get_Visible_World 504 (Canvas : access Interactive_Canvas_Record'Class; 505 X1, Y1, X2, Y2 : out Gdouble) 506 is 507 X_Ignored, Y_Ignored : Gint; 508 509 Hadj : constant Gtk_Adjustment := Canvas.Get_Hadjustment; 510 Vadj : constant Gtk_Adjustment := Canvas.Get_Vadjustment; 511 512 Window_Width, Window_Height : Gint; 513 Canvas_Width, Canvas_Height : Guint; 514 515 X_Ratio : Gdouble; 516 Y_Ratio : Gdouble; 517 518 Dest_X, Dest_Y : Gint; 519 Result : Boolean; 520 begin 521 Translate_Coordinates 522 (Canvas, 523 Get_Parent (Canvas), 524 0, 0, Dest_X, Dest_Y, Result); 525 526 Get_Geometry 527 (Canvas.Get_Window, 528 X_Ignored, Y_Ignored, 529 Window_Width, Window_Height); 530 531 Canvas.Get_Size (Canvas_Width, Canvas_Height); 532 533 X_Ratio := ((Hadj.Get_Upper - Hadj.Get_Page_Size) - Hadj.Get_Lower); 534 535 if X_Ratio < 0.001 then 536 X1 := Canvas.World_X; 537 else 538 X1 := Canvas.World_X + 539 (Gdouble (Canvas_Width) - Gdouble (Window_Width)) 540 * Hadj.Get_Value / (X_Ratio * Canvas.Zoom); 541 end if; 542 543 Y_Ratio := ((Vadj.Get_Upper - Vadj.Get_Page_Size) - Vadj.Get_Lower); 544 545 if Y_Ratio < 0.001 then 546 Y1 := Canvas.World_Y; 547 else 548 Y1 := Canvas.World_Y 549 + (Gdouble (Canvas_Height) - Gdouble (Window_Height)) 550 * Vadj.Get_Value / (Y_Ratio * Canvas.Zoom); 551 end if; 552 553 X2 := X1 + Gdouble (Window_Width) / Canvas.Zoom; 554 Y2 := Y1 + Gdouble (Window_Height) / Canvas.Zoom; 555 end Get_Visible_World; 556 557 ------------ 558 -- Create -- 559 ------------ 560 561 function Create 562 (Canvas : access Interactive_Canvas_Record'Class) return Cairo_Context 563 is 564 Cr : constant Cairo_Context := Create 565 (Get_Bin_Window (Canvas)); 566 begin 567 Set_Line_Width (Cr, 1.0); 568 return Cr; 569 end Create; 570 571 ----------------------- 572 -- Emit_By_Name_Item -- 573 ----------------------- 574 575 procedure Emit_By_Name_Item 576 (Object : System.Address; 577 Name : String; 578 Param : access Canvas_Item_Record'Class) 579 is 580 procedure Internal 581 (Object : System.Address; 582 Name : String; 583 Param : System.Address); 584 pragma Import (C, Internal, "ada_g_signal_emit_by_name_ptr"); 585 begin 586 Internal (Object, Name, Param.all'Address); 587 end Emit_By_Name_Item; 588 589 -------------------- 590 -- Mouse_To_World -- 591 -------------------- 592 593 procedure Mouse_To_World 594 (Canvas : access Interactive_Canvas_Record'Class; 595 Event : Gdk_Event; 596 X_World : out Gdouble; 597 Y_World : out Gdouble) 598 is 599 X, Y : Gdouble; 600 begin 601 Get_Coords (Event, X, Y); 602 X_World := Canvas_To_World_X (Canvas, X); 603 Y_World := Canvas_To_World_Y (Canvas, Y); 604 end Mouse_To_World; 605 606 --------------------------- 607 -- Get_World_Coordinates -- 608 --------------------------- 609 610 procedure Get_World_Coordinates 611 (Canvas : access Interactive_Canvas_Record'Class; 612 X, Y : out Glib.Gdouble; 613 Width : out Glib.Gdouble; 614 Height : out Glib.Gdouble) 615 is 616 Layout_Width, Layout_Height : Guint; 617 begin 618 X := Canvas.World_X; 619 Y := Canvas.World_Y; 620 Get_Size (Canvas, Layout_Width, Layout_Height); 621 Width := Gdouble (Layout_Width) / Canvas.Zoom; 622 Height := Gdouble (Layout_Height) / Canvas.Zoom; 623 end Get_World_Coordinates; 624 625 -------------- 626 -- Get_Type -- 627 -------------- 628 629 function Get_Type return Glib.GType is 630 Signal_Parameters : constant Signal_Parameter_Types := 631 (1 => (1 => Gdk.Event.Get_Type, 2 => GType_None), 632 2 => (1 => GType_Pointer, 2 => GType_None), 633 3 => (1 => GType_Uint, 2 => GType_None), 634 4 => (1 => Gtk.Adjustment.Get_Type, 2 => Gtk.Adjustment.Get_Type), 635 5 => (1 => GType_Pointer, 2 => GType_None), 636 6 => (1 => GType_Pointer, 2 => GType_None)); 637 -- the parameters for the above signals. 638 -- This must be defined in this function rather than at the 639 -- library-level, or the value of Gdk_Event.Get_Type is not yet 640 -- initialized. 641 begin 642 Initialize_Class_Record 643 (Gtk.Layout.Get_Type, Class_Record, 644 "GtkAdaCanvas", Signals, Signal_Parameters); 645 return Class_Record.The_Type; 646 end Get_Type; 647 648 ------------- 649 -- Gtk_New -- 650 ------------- 651 652 procedure Gtk_New 653 (Canvas : out Interactive_Canvas; Auto_Layout : Boolean := True) is 654 begin 655 Canvas := new Interactive_Canvas_Record; 656 Gtkada.Canvas.Initialize (Canvas, Auto_Layout); 657 end Gtk_New; 658 659 ---------------- 660 -- Initialize -- 661 ---------------- 662 663 procedure Initialize 664 (Canvas : access Interactive_Canvas_Record'Class; 665 Auto_Layout : Boolean := True) is 666 begin 667 G_New (Canvas, Gtkada.Canvas.Get_Type); 668 669 Canvas.Offset_X_World := 0.0; 670 Canvas.Offset_Y_World := 0.0; 671 Canvas.World_X := 0.0; 672 Canvas.World_Y := 0.0; 673 Set_Directed (Canvas.Children, True); 674 Canvas.Auto_Layout := Auto_Layout; 675 676 Return_Callback.Connect 677 (Canvas, Signal_Draw, 678 Return_Callback.To_Marshaller (On_Draw'Access)); 679 Return_Callback.Connect 680 (Canvas, "button_press_event", 681 Return_Callback.To_Marshaller (Button_Pressed'Access)); 682 Return_Callback.Connect 683 (Canvas, "button_release_event", 684 Return_Callback.To_Marshaller (Button_Release'Access)); 685 Return_Callback.Connect 686 (Canvas, "motion_notify_event", 687 Return_Callback.To_Marshaller (Button_Motion'Access)); 688 Return_Callback.Connect 689 (Canvas, "key_press_event", 690 Return_Callback.To_Marshaller (Key_Press'Access)); 691 Widget_Callback.Connect 692 (Canvas, "size_allocate", Size_Allocate'Access); 693 Widget_Callback.Connect 694 (Canvas, "destroy", 695 Widget_Callback.To_Marshaller (Canvas_Destroyed'Access)); 696 697 Widget_Callback.Connect 698 (Canvas, "notify::hadjustment", Set_Scroll_Adjustments'Access); 699 700 Canvas.Annotation_Layout := Create_Pango_Layout (Canvas); 701 702 -- We want to be sure to get all the mouse events, that are required 703 -- for the animation. 704 705 Add_Events 706 (Canvas, 707 Button_Press_Mask 708 or Button_Motion_Mask 709 or Button_Release_Mask 710 or Key_Press_Mask 711 or Key_Release_Mask); 712 Canvas.Set_Can_Focus (True); 713 714 -- Configure with default values 715 Configure (Canvas); 716 end Initialize; 717 718 -------------- 719 -- Get_Vadj -- 720 -------------- 721 722 function Get_Vadj 723 (Canvas : access Interactive_Canvas_Record'Class) return Gtk_Adjustment is 724 begin 725 return Canvas.Get_Vadjustment; 726 end Get_Vadj; 727 728 -------------- 729 -- Get_Hadj -- 730 -------------- 731 732 function Get_Hadj 733 (Canvas : access Interactive_Canvas_Record'Class) return Gtk_Adjustment is 734 begin 735 return Canvas.Get_Hadjustment; 736 end Get_Hadj; 737 738 ---------------------- 739 -- Canvas_Destroyed -- 740 ---------------------- 741 742 procedure Canvas_Destroyed 743 (Canvas : access Gtk_Widget_Record'Class) 744 is 745 C : constant Interactive_Canvas := Interactive_Canvas (Canvas); 746 begin 747 if C.Scrolling_Timeout_Id /= 0 then 748 Remove (C.Scrolling_Timeout_Id); 749 end if; 750 751 Clear (C); 752 753 Unref (C.Annotation_Layout); 754 end Canvas_Destroyed; 755 756 ---------------------------- 757 -- Set_Scroll_Adjustments -- 758 ---------------------------- 759 760 procedure Set_Scroll_Adjustments 761 (Canvas : access Gtk_Widget_Record'Class) 762 is 763 Canv : constant Interactive_Canvas := Interactive_Canvas (Canvas); 764 765 begin 766 Scrolled (Canvas); 767 768 Widget_Callback.Object_Connect 769 (Canv.Get_Hadjustment, "value_changed", 770 Widget_Callback.To_Marshaller (Scrolled'Access), Canv); 771 Widget_Callback.Object_Connect 772 (Canv.Get_Vadjustment, "value_changed", 773 Widget_Callback.To_Marshaller (Scrolled'Access), Canv); 774 775 Update_Adjustments (Canv); 776 end Set_Scroll_Adjustments; 777 778 --------------- 779 -- Configure -- 780 --------------- 781 782 procedure Configure 783 (Canvas : access Interactive_Canvas_Record; 784 Grid_Size : Guint := Default_Grid_Size; 785 Annotation_Font : Pango.Font.Pango_Font_Description := 786 Pango.Font.From_String (Default_Annotation_Font); 787 Arc_Link_Offset : Gint := Default_Arc_Link_Offset; 788 Arrow_Angle : Gint := Default_Arrow_Angle; 789 Arrow_Length : Gint := Default_Arrow_Length; 790 Motion_Threshold : Gdouble := Default_Motion_Threshold; 791 Background : Gdk.RGBA.Gdk_RGBA := Gdk.RGBA.White_RGBA) is 792 begin 793 Canvas.Grid_Size := Grid_Size; 794 795 if Grid_Size < 2 then 796 Canvas.Align_On_Grid := False; 797 end if; 798 799 Set_Font_Description (Canvas.Annotation_Layout, Annotation_Font); 800 801 Canvas.Arc_Link_Offset := Arc_Link_Offset; 802 Canvas.Arrow_Angle := Gdouble (Arrow_Angle) * Pi / 180.0; 803 Canvas.Arrow_Length := Arrow_Length; 804 Canvas.Motion_Threshold := Motion_Threshold; 805 Canvas.Background_Color := Background; 806 end Configure; 807 808 ------------------- 809 -- Size_Allocate -- 810 ------------------- 811 812 procedure Size_Allocate 813 (Canv : access Gtk_Widget_Record'Class; 814 Args : Gtk_Args) 815 is 816 Canvas : constant Interactive_Canvas := Interactive_Canvas (Canv); 817 pragma Unreferenced (Args); 818 begin 819 Update_Adjustments (Canvas); 820 821 if Canvas.Show_Item /= null then 822 Show_Item (Canvas, Canvas.Show_Item, 823 Canvas.Show_Canvas_X, Canvas.Show_Canvas_Y); 824 Canvas.Show_Item := null; 825 end if; 826 end Size_Allocate; 827 828 ------------------- 829 -- Align_On_Grid -- 830 ------------------- 831 832 procedure Align_On_Grid 833 (Canvas : access Interactive_Canvas_Record; 834 Align : Boolean := True) is 835 begin 836 Canvas.Align_On_Grid := (Canvas.Grid_Size >= 2) and then Align; 837 end Align_On_Grid; 838 839 ---------------------- 840 -- Get_Bounding_Box -- 841 ---------------------- 842 843 procedure Get_Bounding_Box 844 (Canvas : access Interactive_Canvas_Record'Class; 845 X_Min, X_Max, Y_Min, Y_Max : out Gdouble) 846 is 847 Current : Vertex_Iterator := First (Canvas.Children); 848 Item : Canvas_Item; 849 850 begin 851 if At_End (Current) then 852 X_Min := 0.0; 853 X_Max := 0.0; 854 Y_Min := 0.0; 855 Y_Max := 0.0; 856 857 else 858 X_Min := Gdouble'Last; 859 X_Max := Gdouble'First; 860 Y_Min := Gdouble'Last; 861 Y_Max := Gdouble'First; 862 863 while not At_End (Current) loop 864 Item := Canvas_Item (Get (Current)); 865 if Item.Visible and then Item.Coord.X /= Gint'First then 866 X_Min := Gdouble'Min 867 (X_Min, Gdouble (Item.Coord.X)); 868 X_Max := Gdouble'Max 869 (X_Max, Gdouble (Item.Coord.X + Item.Coord.Width)); 870 Y_Min := Gdouble'Min 871 (Y_Min, Gdouble (Item.Coord.Y)); 872 Y_Max := Gdouble'Max 873 (Y_Max, Gdouble (Item.Coord.Y + Item.Coord.Height)); 874 875 -- If the item is selected, also include its new position in 876 -- the computation (while we are moving items) 877 878 if (Canvas.Offset_X_World /= 0.0 879 or else Canvas.Offset_Y_World /= 0.0) 880 and then Item.Selected 881 then 882 X_Min := Gdouble'Min 883 (X_Min, Gdouble (Item.Coord.X + Item.Coord.Width) + 884 Canvas.Offset_X_World); 885 X_Max := Gdouble'Max 886 (X_Max, Gdouble (Item.Coord.X) + Canvas.Offset_X_World); 887 Y_Min := Gdouble'Min 888 (Y_Min, Gdouble (Item.Coord.Y + Item.Coord.Height) + 889 Canvas.Offset_Y_World); 890 Y_Max := Gdouble'Max 891 (Y_Max, Gdouble (Item.Coord.Y) + Canvas.Offset_Y_World); 892 end if; 893 end if; 894 895 Next (Current); 896 end loop; 897 898 if X_Min = Gdouble'Last then 899 -- This can happen if there is no visible item: 900 -- in this case, return a box of size 0. 901 X_Min := 0.0; 902 X_Max := 0.0; 903 Y_Min := 0.0; 904 Y_Max := 0.0; 905 end if; 906 907 end if; 908 end Get_Bounding_Box; 909 910 ------------------------ 911 -- Update_Adjustments -- 912 ------------------------ 913 914 procedure Update_Adjustments 915 (Canvas : access Interactive_Canvas_Record'Class; 916 Behavior : Bounds_Modification_Mode := Clamp) 917 is 918 X_Max, Y_Max, X_Min, Y_Min : Gdouble; 919 920 begin 921 -- If the canvas was properly initialized 922 if Get_Realized (Canvas) 923 and then Get_Allocated_Width (Canvas) /= 1 924 then 925 Get_Bounding_Box (Canvas, X_Min, X_Max, Y_Min, Y_Max); 926 927 -- Add some space around this bounding box 928 -- ??? Use a constant 929 X_Min := X_Min - 20.0; 930 Y_Min := Y_Min - 20.0; 931 X_Max := X_Max + 20.0; 932 Y_Max := Y_Max + 20.0; 933 934 case Behavior is 935 when Do_Not_Change => 936 null; 937 938 when Grow_Only => 939 Canvas.World_X := Gdouble'Min (Canvas.World_X, X_Min); 940 Canvas.World_Y := Gdouble'Min (Canvas.World_Y, Y_Min); 941 942 declare 943 Width, Height : Guint; 944 begin 945 Canvas.Get_Size (Width, Height); 946 Canvas.Set_Size 947 (Guint'Max 948 (Guint ((X_Max - X_Min) * Canvas.Zoom), 949 Width), 950 Guint'Max 951 (Guint ((Y_Max - Y_Min) * Canvas.Zoom), 952 Height)); 953 end; 954 955 when Clamp => 956 Canvas.World_X := X_Min; 957 Canvas.World_Y := Y_Min; 958 959 Canvas.Set_Size 960 (Guint ((X_Max - X_Min) * Canvas.Zoom), 961 Guint ((Y_Max - Y_Min) * Canvas.Zoom)); 962 end case; 963 end if; 964 end Update_Adjustments; 965 966 ------------------------------ 967 -- Default_Layout_Algorithm -- 968 ------------------------------ 969 970 procedure Default_Layout_Algorithm 971 (Canvas : access Interactive_Canvas_Record'Class; 972 Graph : Glib.Graphs.Graph; 973 Force : Boolean; 974 Vertical_Layout : Boolean) 975 is 976 pragma Unreferenced (Force); 977 Step : Gint := Gint (Canvas.Grid_Size); 978 Region : Cairo_Region; 979 Items : Vertex_Iterator; 980 Item : Canvas_Item; 981 Links : Edge_Iterator; 982 Src_Item : Canvas_Item := null; 983 X1, X3, Y1, Y3 : Gint; 984 Num : Gint; 985 Coord : aliased Cairo_Rectangle_Int; 986 Status : Cairo_Status; 987 pragma Unreferenced (Status); 988 989 begin 990 if Step = 0 then 991 Step := Gint (Default_Grid_Size); 992 end if; 993 994 -- First, check every item that won't be moved 995 996 Region := Create; 997 Items := First (Graph); 998 while not At_End (Items) loop 999 Item := Canvas_Item (Get (Items)); 1000 if Item.Coord.X /= Gint'First 1001 or else Item.Coord.Y /= Gint'First 1002 then 1003 Status := Union_Rectangle (Region, Item.Coord'Access); 1004 end if; 1005 1006 Next (Items); 1007 end loop; 1008 1009 Items := First (Graph); 1010 while not At_End (Items) loop 1011 Item := Canvas_Item (Get (Items)); 1012 if Item.Coord.X = Gint'First or else Item.Coord.Y = Gint'First then 1013 -- Check if there is any link that has for destination or source 1014 -- the widget we are adding. 1015 1016 Links := First (Canvas.Children, Src => Vertex_Access (Item)); 1017 while not At_End (Links) loop 1018 Src_Item := Canvas_Item (Get_Dest (Get (Links))); 1019 exit when Src_Item /= Item; 1020 Src_Item := null; 1021 Next (Links); 1022 end loop; 1023 1024 if Src_Item = null then 1025 Links := First (Canvas.Children, Dest => Vertex_Access (Item)); 1026 while not At_End (Links) loop 1027 Src_Item := Canvas_Item (Get_Src (Get (Links))); 1028 exit when Src_Item /= Item; 1029 Src_Item := null; 1030 Next (Links); 1031 end loop; 1032 end if; 1033 1034 -- The rule is the following when we have a link to an existing 1035 -- item: We first try to put the new item below the old one, then, 1036 -- if that place is already occupied, to the bottom-right, then 1037 -- the bottom-left, then two down, ... 1038 1039 if Src_Item /= null then 1040 Num := 0; 1041 1042 if Vertical_Layout then 1043 X1 := Src_Item.Coord.X + Src_Item.Coord.Width + Step; 1044 Y3 := Src_Item.Coord.Y; 1045 1046 loop 1047 case Num mod 3 is 1048 when 0 => 1049 Y1 := Y3; 1050 when 1 => 1051 Y1 := Y3 - Step - Item.Coord.Height; 1052 when 2 => 1053 Y1 := Y3 + Step + Item.Coord.Height; 1054 when others => 1055 null; 1056 end case; 1057 1058 Coord := (X1, Y1, Item.Coord.Width, Item.Coord.Height); 1059 exit when 1060 Contains_Rectangle 1061 (Region, Coord'Access) = Cairo_Region_Overlap_Out; 1062 1063 Num := Num + 1; 1064 if Num mod 3 = 0 then 1065 X1 := X1 + 2 * Step; 1066 end if; 1067 end loop; 1068 1069 else 1070 X3 := Src_Item.Coord.X; 1071 Y1 := Src_Item.Coord.Y + Src_Item.Coord.Height + Step; 1072 1073 loop 1074 case Num mod 3 is 1075 when 0 => 1076 X1 := X3; 1077 when 1 => 1078 X1 := X3 - Step - Item.Coord.Width; 1079 when 2 => 1080 X1 := X3 + Step + Item.Coord.Width; 1081 when others => 1082 null; 1083 end case; 1084 1085 Coord := (X1, Y1, Item.Coord.Width, Item.Coord.Height); 1086 exit when 1087 Contains_Rectangle 1088 (Region, Coord'Access) = Cairo_Region_Overlap_Out; 1089 1090 Num := Num + 1; 1091 if Num mod 3 = 0 then 1092 Y1 := Y1 + 2 * Step; 1093 end if; 1094 end loop; 1095 end if; 1096 1097 else 1098 -- Else put the item in the first line, at the first possible 1099 -- location 1100 X1 := Gint (Get_Lower (Canvas.Get_Hadjustment)) + Step; 1101 Y1 := Gint (Get_Lower (Canvas.Get_Vadjustment)) + Step; 1102 1103 loop 1104 Coord := (X1, Y1, Item.Coord.Width, Item.Coord.Height); 1105 exit when 1106 Contains_Rectangle 1107 (Region, Coord'Access) = Cairo_Region_Overlap_Out; 1108 1109 if Vertical_Layout then 1110 Y1 := Y1 + 2 * Step; 1111 else 1112 X1 := X1 + 2 * Step; 1113 end if; 1114 end loop; 1115 end if; 1116 1117 Item.Coord.X := X1; 1118 Item.Coord.Y := Y1; 1119 1120 Status := Union_Rectangle (Region, Item.Coord'Access); 1121 end if; 1122 1123 Next (Items); 1124 end loop; 1125 1126 Destroy (Region); 1127 end Default_Layout_Algorithm; 1128 1129 --------------------- 1130 -- Set_Auto_Layout -- 1131 --------------------- 1132 1133 procedure Set_Auto_Layout 1134 (Canvas : access Interactive_Canvas_Record; 1135 Auto_Layout : Boolean) is 1136 begin 1137 Canvas.Auto_Layout := Auto_Layout; 1138 end Set_Auto_Layout; 1139 1140 ---------------------------- 1141 -- Set_Layout_Orientation -- 1142 ---------------------------- 1143 1144 procedure Set_Layout_Orientation 1145 (Canvas : access Interactive_Canvas_Record; 1146 Vertical_Layout : Boolean := False) 1147 is 1148 begin 1149 Canvas.Vertical_Layout := Vertical_Layout; 1150 end Set_Layout_Orientation; 1151 1152 ------------ 1153 -- Layout -- 1154 ------------ 1155 1156 procedure Layout 1157 (Canvas : access Interactive_Canvas_Record; 1158 Force : Boolean := False) 1159 is 1160 Step : constant Gint := Gint (Canvas.Grid_Size); 1161 Items : Vertex_Iterator; 1162 Item : Canvas_Item; 1163 Min_X, Min_Y : Gint := Gint'Last; 1164 Max_X, Max_Y : Gint := Gint'First; 1165 1166 begin 1167 Canvas.Layout 1168 (Canvas, Canvas.Children, 1169 Force => Force, 1170 Vertical_Layout => Canvas.Vertical_Layout); 1171 1172 Items := First (Canvas.Children); 1173 1174 while not At_End (Items) loop 1175 Item := Canvas_Item (Get (Items)); 1176 Min_X := Gint'Min (Min_X, Item.Coord.X); 1177 Min_Y := Gint'Min (Min_Y, Item.Coord.Y); 1178 Max_X := Gint'Max (Max_X, Item.Coord.X + Item.Coord.Width); 1179 Max_Y := Gint'Max (Max_Y, Item.Coord.Y + Item.Coord.Height); 1180 1181 if Force then 1182 Item.From_Auto_Layout := True; 1183 end if; 1184 1185 Next (Items); 1186 end loop; 1187 1188 Items := First (Canvas.Children); 1189 1190 while not At_End (Items) loop 1191 Item := Canvas_Item (Get (Items)); 1192 1193 -- Normalize the coordinates, so that we stay within Integer'Range. 1194 -- Since this causes unwanted scrolling when new boxes are added, we 1195 -- only do it to keep a safe margin when the user moves a box around, 1196 -- and thus only when absolutly needed. 1197 1198 if Max_X > Gint'Last - 5000 1199 or else Max_Y > Gint'Last - 5000 1200 or else Min_X < Gint'First + 5000 1201 or else Min_Y < Gint'First + 5000 1202 then 1203 if Traces then 1204 Put_Line ("Layout: Changing all items: Min=" 1205 & Gint'Image (Min_X) & Gint'Image (Min_Y) 1206 & " Max=" & Gint'Image (Max_X) & Gint'Image (Max_Y)); 1207 end if; 1208 1209 Item.Coord.X := Item.Coord.X - Min_X; 1210 Item.Coord.Y := Item.Coord.Y - Min_Y; 1211 end if; 1212 1213 if Item.From_Auto_Layout then 1214 if Canvas.Align_On_Grid then 1215 Item.Coord.X := Item.Coord.X - Item.Coord.X mod Step; 1216 Item.Coord.Y := Item.Coord.Y - Item.Coord.Y mod Step; 1217 end if; 1218 end if; 1219 1220 Next (Items); 1221 end loop; 1222 1223 Update_Adjustments (Canvas); 1224 end Layout; 1225 1226 -------------------------- 1227 -- Set_Layout_Algorithm -- 1228 -------------------------- 1229 1230 procedure Set_Layout_Algorithm 1231 (Canvas : access Interactive_Canvas_Record; 1232 Algorithm : Layout_Algorithm) is 1233 begin 1234 if Algorithm /= null then 1235 Canvas.Layout := Algorithm; 1236 end if; 1237 end Set_Layout_Algorithm; 1238 1239 ------------- 1240 -- Move_To -- 1241 ------------- 1242 1243 procedure Move_To 1244 (Canvas : access Interactive_Canvas_Record; 1245 Item : access Canvas_Item_Record'Class; 1246 X, Y : Glib.Gint := Glib.Gint'First) 1247 is 1248 pragma Unreferenced (Canvas); 1249 begin 1250 Item.Coord.X := X; 1251 Item.Coord.Y := Y; 1252 end Move_To; 1253 1254 --------- 1255 -- Put -- 1256 --------- 1257 1258 procedure Put 1259 (Canvas : access Interactive_Canvas_Record; 1260 Item : access Canvas_Item_Record'Class; 1261 X, Y : Gint := Gint'First) is 1262 begin 1263 Add_Vertex (Canvas.Children, Item); 1264 Item.Canvas := Interactive_Canvas (Canvas); 1265 Move_To (Canvas, Item, X, Y); 1266 1267 -- Make sure that the item will be properly moved by the layout 1268 -- algorithm. 1269 Item.From_Auto_Layout := 1270 X = Gint'First and then Y = Gint'First; 1271 1272 if Canvas.Auto_Layout 1273 and then Item.From_Auto_Layout 1274 then 1275 Layout (Canvas); 1276 else 1277 Update_Adjustments (Canvas); 1278 end if; 1279 end Put; 1280 1281 --------------- 1282 -- Set_Items -- 1283 --------------- 1284 1285 procedure Set_Items 1286 (Canvas : access Interactive_Canvas_Record; 1287 Items : Glib.Graphs.Graph) is 1288 begin 1289 Destroy (Canvas.Children); 1290 Canvas.Children := Items; 1291 end Set_Items; 1292 1293 ------------------- 1294 -- For_Each_Item -- 1295 ------------------- 1296 1297 procedure For_Each_Item 1298 (Canvas : access Interactive_Canvas_Record; 1299 Execute : Item_Processor; 1300 Linked_From_Or_To : Canvas_Item := null) 1301 is 1302 Iter : Item_Iterator := Start (Canvas, Linked_From_Or_To); 1303 It : Canvas_Item; 1304 begin 1305 loop 1306 It := Get (Iter); 1307 exit when It = null; 1308 1309 Next (Iter); 1310 exit when not Execute (Canvas, It); 1311 end loop; 1312 end For_Each_Item; 1313 1314 ----------- 1315 -- Start -- 1316 ----------- 1317 1318 function Start 1319 (Canvas : access Interactive_Canvas_Record; 1320 Linked_From_Or_To : Canvas_Item := null; 1321 Selected_Only : Boolean := False) return Item_Iterator 1322 is 1323 Iter : Item_Iterator; 1324 begin 1325 if Linked_From_Or_To = null then 1326 Iter := (Vertex => First (Canvas.Children), 1327 Edge => Null_Edge_Iterator, 1328 Selected_Only => Selected_Only, 1329 Linked_From_Or_To => null); 1330 else 1331 Iter := (Vertex => Null_Vertex_Iterator, 1332 Edge => First (Canvas.Children, 1333 Vertex_Access (Linked_From_Or_To), 1334 Directed => False), 1335 Selected_Only => Selected_Only, 1336 Linked_From_Or_To => Linked_From_Or_To); 1337 end if; 1338 1339 if Iter.Selected_Only 1340 and then Get (Iter) /= null 1341 and then not Get (Iter).Selected 1342 then 1343 Next (Iter); 1344 end if; 1345 1346 return Iter; 1347 end Start; 1348 1349 ---------- 1350 -- Next -- 1351 ---------- 1352 1353 procedure Next (Iter : in out Item_Iterator) is 1354 begin 1355 loop 1356 if Iter.Linked_From_Or_To = null then 1357 Next (Iter.Vertex); 1358 else 1359 Next (Iter.Edge); 1360 end if; 1361 1362 exit when not Iter.Selected_Only 1363 or else Get (Iter) = null 1364 or else Get (Iter).Selected; 1365 end loop; 1366 end Next; 1367 1368 ---------- 1369 -- Next -- 1370 ---------- 1371 1372 function Next (Iter : Item_Iterator) return Item_Iterator is 1373 It : Item_Iterator := Iter; 1374 begin 1375 Next (It); 1376 return It; 1377 end Next; 1378 1379 -------------------- 1380 -- Is_Linked_From -- 1381 -------------------- 1382 1383 function Is_Linked_From (Iter : Item_Iterator) return Boolean is 1384 begin 1385 return Iter.Linked_From_Or_To /= null 1386 and then not At_End (Iter.Edge) 1387 and then Canvas_Item (Get_Src (Get (Iter.Edge))) /= 1388 Iter.Linked_From_Or_To; 1389 end Is_Linked_From; 1390 1391 --------- 1392 -- Get -- 1393 --------- 1394 1395 function Get (Iter : Item_Iterator) return Canvas_Item is 1396 Item : Canvas_Item; 1397 begin 1398 if Iter.Linked_From_Or_To = null then 1399 if At_End (Iter.Vertex) then 1400 return null; 1401 else 1402 return Canvas_Item (Get (Iter.Vertex)); 1403 end if; 1404 1405 else 1406 if At_End (Iter.Edge) then 1407 return null; 1408 end if; 1409 1410 Item := Canvas_Item (Get_Src (Get (Iter.Edge))); 1411 if Item /= Iter.Linked_From_Or_To then 1412 return Item; 1413 end if; 1414 1415 -- If Get_Src was the item, we want to return Dest (which might 1416 -- actually be the item itself). 1417 -- Else, if Get_Src wasn't the item, then Get_Dest is the item, and 1418 -- we do not want to return it. 1419 return Canvas_Item (Get_Dest (Get (Iter.Edge))); 1420 end if; 1421 end Get; 1422 1423 ---------------------------- 1424 -- Get_Actual_Coordinates -- 1425 ---------------------------- 1426 1427 function Get_Actual_Coordinates 1428 (Self : not null access Interactive_Canvas_Record'Class; 1429 Item : not null access Canvas_Item_Record'Class) 1430 return Cairo_Rectangle_Int 1431 is 1432 C : Cairo_Rectangle_Int; 1433 begin 1434 -- During a move, the items that are moved must be moved by the extra 1435 -- offset moved by the mouse. This extra offset is set to 0 when not 1436 -- moving items, so it is safe to add. 1437 if Item.Selected then 1438 C := (Item.Coord.X + Gint (Self.Offset_X_World), 1439 Item.Coord.Y + Gint (Self.Offset_Y_World), 1440 Item.Coord.Width, 1441 Item.Coord.Height); 1442 1443 if Self.Align_On_Grid then 1444 C.X := C.X - C.X mod Gint (Self.Grid_Size); 1445 C.Y := C.Y - C.Y mod Gint (Self.Grid_Size); 1446 end if; 1447 1448 return C; 1449 else 1450 return Item.Coord; 1451 end if; 1452 end Get_Actual_Coordinates; 1453 1454 --------------- 1455 -- Clip_Line -- 1456 --------------- 1457 1458 procedure Clip_Line 1459 (Src : access Canvas_Item_Record; 1460 Canvas : access Interactive_Canvas_Record'Class; 1461 To_X : Gint; 1462 To_Y : Gint; 1463 X_Pos : Gfloat; 1464 Y_Pos : Gfloat; 1465 Side : out Item_Side; 1466 X_Out : out Gint; 1467 Y_Out : out Gint) 1468 is 1469 Rect : constant Cairo_Rectangle_Int := 1470 Get_Actual_Coordinates (Canvas, Src); 1471 Src_X : Gint; 1472 Src_Y : Gint; 1473 Delta_X : Gint; 1474 Delta_Y : Gint; 1475 Offset : Gint; 1476 begin 1477 Src_X := Rect.X + Gint (Gfloat (Rect.Width) * X_Pos); 1478 Src_Y := Rect.Y + Gint (Gfloat (Rect.Height) * Y_Pos); 1479 Delta_X := To_X - Src_X; 1480 Delta_Y := To_Y - Src_Y; 1481 1482 -- Intersection with horizontal sides 1483 1484 if Delta_Y /= 0 then 1485 Offset := (Src_X * To_Y - To_X * Src_Y); 1486 1487 if Delta_Y < 0 then 1488 Side := North; 1489 Y_Out := Rect.Y; 1490 else 1491 Side := South; 1492 Y_Out := Rect.Y + Rect.Height; 1493 end if; 1494 1495 X_Out := (Delta_X * Y_Out + Offset) / Delta_Y; 1496 1497 if Rect.X <= X_Out 1498 and then X_Out <= Rect.X + Rect.Width 1499 then 1500 return; 1501 end if; 1502 end if; 1503 1504 -- Intersection with vertical sides 1505 1506 if Delta_X /= 0 then 1507 Offset := (To_X * Src_Y - Src_X * To_Y); 1508 1509 if Delta_X < 0 then 1510 Side := West; 1511 X_Out := Rect.X; 1512 else 1513 Side := East; 1514 X_Out := Rect.X + Rect.Width; 1515 end if; 1516 1517 Y_Out := (Delta_Y * X_Out + Offset) / Delta_X; 1518 1519 if Rect.Y <= Y_Out 1520 and then Y_Out <= Rect.Y + Rect.Height 1521 then 1522 return; 1523 end if; 1524 end if; 1525 1526 X_Out := 0; 1527 Y_Out := 0; 1528 Side := East; 1529 end Clip_Line; 1530 1531 --------------------- 1532 -- Draw_Arrow_Head -- 1533 --------------------- 1534 1535 procedure Draw_Arrow_Head 1536 (Canvas : access Interactive_Canvas_Record'Class; 1537 Cr : Cairo_Context; 1538 X_Canvas : Gdouble; 1539 Y_Canvas : Gdouble; 1540 Angle : Gdouble) 1541 is 1542 Length : constant Gdouble := Gdouble (Canvas.Arrow_Length); 1543 begin 1544 Move_To (Cr, X_Canvas, Y_Canvas); 1545 Line_To 1546 (Cr, 1547 X_Canvas + Length * Cos (Angle + Canvas.Arrow_Angle), 1548 Y_Canvas + Length * Sin (Angle + Canvas.Arrow_Angle)); 1549 Line_To 1550 (Cr, 1551 X_Canvas + Length * Cos (Angle - Canvas.Arrow_Angle), 1552 Y_Canvas + Length * Sin (Angle - Canvas.Arrow_Angle)); 1553 Close_Path (Cr); 1554 Cairo.Fill (Cr); 1555 end Draw_Arrow_Head; 1556 1557 --------------------- 1558 -- Draw_Annotation -- 1559 --------------------- 1560 1561 procedure Draw_Annotation 1562 (Canvas : access Interactive_Canvas_Record'Class; 1563 Cr : Cairo_Context; 1564 X_Canvas : Gdouble; 1565 Y_Canvas : Gdouble; 1566 Link : access Canvas_Link_Record'Class) 1567 is 1568 W, H : Gint; 1569 begin 1570 if Link.Descr /= null 1571 and then Link.Descr.all /= "" 1572 and then Canvas.Annotation_Layout /= null 1573 then 1574 Set_Text (Canvas.Annotation_Layout, Link.Descr.all); 1575 Get_Pixel_Size (Canvas.Annotation_Layout, W, H); 1576 1577 Cairo.Save (Cr); 1578 Gdk.Cairo.Set_Source_RGBA (Cr, (0.0, 0.0, 0.0, 0.0)); 1579 Cairo.Set_Line_Width (Cr, 1.0); 1580 Cairo.Rectangle 1581 (Cr, 1582 X_Canvas - 0.5, 1583 Y_Canvas - 0.5, 1584 Gdouble (W) + 1.0, 1585 Gdouble (H) + 1.0); 1586 Cairo.Fill (Cr); 1587 Cairo.Restore (Cr); 1588 1589 Cairo.Move_To (Cr, X_Canvas, Y_Canvas); 1590 Pango.Cairo.Show_Layout (Cr, Canvas.Annotation_Layout); 1591 end if; 1592 end Draw_Annotation; 1593 1594 ---------------------- 1595 -- Compute_Line_Pos -- 1596 ---------------------- 1597 1598 function Compute_Line_Pos 1599 (Canvas : access Interactive_Canvas_Record'Class) return Gint_Array 1600 is 1601 type Graph_Range is record 1602 From, To : Gint; 1603 end record; 1604 1605 type Range_Array is array (Positive range <>) of Graph_Range; 1606 type Range_Array_Access is access all Range_Array; 1607 1608 procedure Free is new Unchecked_Deallocation 1609 (Range_Array, Range_Array_Access); 1610 1611 Free_Ranges : Range_Array_Access := new Range_Array (1 .. 1000); 1612 Tmp : Range_Array_Access; 1613 Last_Range : Positive := Free_Ranges'First; 1614 Iter : Vertex_Iterator := First (Canvas.Children); 1615 E : Canvas_Item; 1616 Right : Gint; 1617 begin 1618 Free_Ranges (Free_Ranges'First) := (From => Gint'First, To => Gint'Last); 1619 1620 while not At_End (Iter) loop 1621 E := Canvas_Item (Get (Iter)); 1622 Right := E.Coord.X + E.Coord.Width; 1623 1624 for R in Free_Ranges'First .. Last_Range loop 1625 if Free_Ranges (R).From <= E.Coord.X 1626 and then Free_Ranges (R).To >= E.Coord.X 1627 and then Free_Ranges (R).To <= Right 1628 then 1629 Free_Ranges (R) := 1630 (From => Free_Ranges (R).From, To => E.Coord.X - 1); 1631 1632 elsif Free_Ranges (R).From <= E.Coord.X 1633 and then Free_Ranges (R).To >= Right 1634 then 1635 if Last_Range >= Free_Ranges'Last then 1636 Tmp := new Range_Array (1 .. Free_Ranges'Last * 2); 1637 Tmp (1 .. Free_Ranges'Last) := Free_Ranges.all; 1638 Free (Free_Ranges); 1639 Free_Ranges := Tmp; 1640 end if; 1641 1642 Free_Ranges (R + 1 .. Last_Range + 1) := 1643 Free_Ranges (R .. Last_Range); 1644 Free_Ranges (R + 1) := 1645 (From => Right + 1, To => Free_Ranges (R).To); 1646 Free_Ranges (R) := 1647 (From => Free_Ranges (R).From, To => E.Coord.X - 1); 1648 Last_Range := Last_Range + 1; 1649 1650 elsif Free_Ranges (R).From >= E.Coord.X 1651 and then Free_Ranges (R).From <= Right 1652 and then Free_Ranges (R).To >= Right 1653 then 1654 Free_Ranges (R) := 1655 (From => Right + 1, To => Free_Ranges (R).To); 1656 end if; 1657 1658 exit when Free_Ranges (R).From > Right; 1659 end loop; 1660 1661 Next (Iter); 1662 end loop; 1663 1664 declare 1665 Result : Gint_Array (1 .. Last_Range); 1666 begin 1667 for R in Result'Range loop 1668 -- ??? Should handle vertical layout and horizontal layout 1669 Result (R) := 1670 (Free_Ranges (R).From + Free_Ranges (R).To) / 2; 1671 end loop; 1672 1673 Free (Free_Ranges); 1674 return Result; 1675 end; 1676 end Compute_Line_Pos; 1677 1678 --------------------------- 1679 -- Scroll_Canvas_To_Item -- 1680 ---------------------------- 1681 1682 procedure Scroll_Canvas_To_Item 1683 (Canvas : access Interactive_Canvas_Record'Class; 1684 Item : access Canvas_Item_Record'Class; 1685 Canvas_X, Canvas_Y : Gdouble := 0.5) 1686 is 1687 World : constant Cairo_Rectangle_Int := 1688 Get_Actual_Coordinates (Canvas, Item); 1689 begin 1690 -- If no size was allocated yet, memorize the item for later (see 1691 -- the callback for size_allocate) 1692 1693 if Get_Allocated_Width (Canvas) = 1 1694 or else Get_Allocated_Height (Canvas) = 1 1695 then 1696 Canvas.Show_Item := Canvas_Item (Item); 1697 Canvas.Show_Canvas_X := Canvas_X; 1698 Canvas.Show_Canvas_Y := Canvas_Y; 1699 else 1700 Scroll_Canvas_To_Area 1701 (Canvas, 1702 Gdouble (World.X), 1703 Gdouble (World.Y), 1704 Gdouble (World.X + World.Width), 1705 Gdouble (World.Y + World.Height)); 1706 end if; 1707 end Scroll_Canvas_To_Item; 1708 1709 --------------------------- 1710 -- Scroll_Canvas_To_Area -- 1711 --------------------------- 1712 1713 procedure Scroll_Canvas_To_Area 1714 (Canvas : access Interactive_Canvas_Record'Class; 1715 X1, Y1, X2, Y2 : Gdouble; 1716 Canvas_X, Canvas_Y : Gdouble := 0.5) 1717 is 1718 pragma Unreferenced (Canvas_Y, Canvas_X); 1719 X_Ignored, Y_Ignored : Gint; 1720 Window_Width, Window_Height : Gint; 1721 1722 Canvas_Width, Canvas_Height : Guint; 1723 Percent_X, Percent_Y : Gdouble; 1724 1725 Hadj : constant Gtk_Adjustment := Canvas.Get_Hadjustment; 1726 Vadj : constant Gtk_Adjustment := Canvas.Get_Vadjustment; 1727 1728 X1_Visible, Y1_Visible, X2_Visible, Y2_Visible : Gdouble; 1729 1730 Target_X, Target_Y : Gdouble; 1731 begin 1732 Canvas.Get_Visible_World 1733 (X1_Visible, Y1_Visible, X2_Visible, Y2_Visible); 1734 1735 Get_Geometry 1736 (Canvas.Get_Window, 1737 X_Ignored, Y_Ignored, 1738 Window_Width, Window_Height); 1739 1740 Canvas.Get_Size (Canvas_Width, Canvas_Height); 1741 1742 if X1 < X1_Visible 1743 or else X2 > X2_Visible 1744 then 1745 if X1 < X1_Visible then 1746 Target_X := X1; 1747 else 1748 Target_X := X1_Visible + X2 - X2_Visible; 1749 end if; 1750 1751 Percent_X := (Target_X - Canvas.World_X) / 1752 (Gdouble (Gint (Canvas_Width)) - Gdouble (Window_Width)); 1753 1754 Set_Value 1755 (Hadj, 1756 ((Hadj.Get_Upper - Hadj.Get_Page_Size) - Hadj.Get_Lower) 1757 * Percent_X * Canvas.Zoom); 1758 end if; 1759 1760 if Y1 < Y1_Visible 1761 or else Y2 > Y2_Visible 1762 then 1763 if Y1 < Y1_Visible then 1764 Target_Y := Y1; 1765 else 1766 Target_Y := Y1_Visible + Y2 - Y2_Visible; 1767 end if; 1768 1769 Percent_Y := (Target_Y - Canvas.World_Y) / 1770 (Gdouble (Gint (Canvas_Height)) - Gdouble (Window_Height)); 1771 1772 Set_Value 1773 (Vadj, 1774 ((Vadj.Get_Upper - Vadj.Get_Page_Size) - Vadj.Get_Lower) 1775 * Percent_Y * Canvas.Zoom); 1776 end if; 1777 end Scroll_Canvas_To_Area; 1778 1779 -------------------------- 1780 -- Draw_Orthogonal_Link -- 1781 -------------------------- 1782 1783 procedure Draw_Orthogonal_Link 1784 (Canvas : access Interactive_Canvas_Record'Class; 1785 Cr : Cairo_Context; 1786 Link : access Canvas_Link_Record'Class; 1787 Show_Annotation : Boolean) 1788 is 1789 X1, Y1, Xp1, Yp1, X2, Y2, Xp2, Yp2, X3, Y3 : Gint; 1790 X1_Canvas, Xc1_Canvas, Xc2_Canvas : Gdouble; 1791 X3_Canvas, Yp1_Canvas : Gdouble; 1792 Xp1_Canvas, Y2_Canvas, Y3_Canvas, Y1_Canvas : Gdouble; 1793 Yc1_Canvas, Yc2_Canvas, Yp2_Canvas : Gdouble; 1794 X2_Canvas, Xp2_Canvas : Gdouble; 1795 Xc1, Xc2, Yc1, Yc2 : Gint; 1796 Xarr_End, Yarr_End, Xarr_Start, Yarr_Start : Gdouble; 1797 Angle_Arr_End, Angle_Arr_Start : Gdouble; 1798 Src : constant Canvas_Item := Canvas_Item (Get_Src (Link)); 1799 Dest : constant Canvas_Item := Canvas_Item (Get_Dest (Link)); 1800 Line_Pos : constant Gint_Array := Compute_Line_Pos (Canvas); 1801 1802 Src_World : constant Cairo_Rectangle_Int := 1803 Get_Actual_Coordinates (Canvas, Src); 1804 Dest_World : constant Cairo_Rectangle_Int := 1805 Get_Actual_Coordinates (Canvas, Dest); 1806 1807 begin 1808 X1 := Src_World.X; 1809 Y1 := Src_World.Y; 1810 X2 := Dest_World.X; 1811 Y2 := Dest_World.Y; 1812 1813 Xp1 := X1 + Src.Coord.Width; 1814 Yp1 := Y1 + Src.Coord.Height; 1815 Xp2 := X2 + Dest_World.Width; 1816 Yp2 := Y2 + Dest_World.Height; 1817 1818 Xc1 := (X1 + Xp1) / 2; 1819 1820 if Canvas.Grid_Size > 0 then 1821 Xc1 := Xc1 - Xc1 mod Gint (Canvas.Grid_Size); 1822 end if; 1823 1824 Xc2 := (X2 + Xp2) / 2; 1825 if Canvas.Grid_Size > 0 then 1826 Xc2 := Xc2 - Xc2 mod Gint (Canvas.Grid_Size); 1827 end if; 1828 1829 Yc1 := (Y1 + Yp1) / 2; 1830 Yc2 := (Y2 + Yp2) / 2; 1831 1832 -- The preferred case will be 1833 -- A --- 1834 -- |____ B 1835 -- The separation line should be at equal distance of the center of A 1836 -- and the center of B, so that multiple items lined up in a column 1837 -- above B all have the vertical line at the same location. 1838 -- 1839 -- If the vertical line can be drawn at exact distance of the centers, 1840 -- then we try and display the vertical line at equal distance of the 1841 -- adjacent edges of A and B 1842 1843 X3 := Gint'First; 1844 1845 for L in Line_Pos'Range loop 1846 if Line_Pos (L) >= Xp1 1847 and then Line_Pos (L) <= X2 1848 then 1849 X3 := Line_Pos (L); 1850 exit; 1851 1852 elsif Line_Pos (L) >= Xp2 1853 and then Line_Pos (L) <= X1 1854 then 1855 X3 := Line_Pos (L); 1856 exit; 1857 end if; 1858 end loop; 1859 1860 -- X3 := (X1 + Xp1 + X2 + Xp2) / 4; 1861 -- X3 := X3 - X3 mod Gint (Canvas.Grid_Size); 1862 1863 -- if ((X1 <= X3 and then X3 <= Xp1) 1864 -- or else (X2 <= X3 and then X3 <= Xp2)) 1865 -- and then (Xp1 <= X2 or else Xp2 <= X1) 1866 -- then 1867 -- X3 := (Xp1 + X2) / 2; 1868 -- X3 := X3 - X3 mod Gint (Canvas.Grid_Size); 1869 -- end if; 1870 1871 X1_Canvas := World_To_Canvas_X (Canvas, Gdouble (X1)); 1872 X2_Canvas := World_To_Canvas_X (Canvas, Gdouble (X2)); 1873 Xc1_Canvas := World_To_Canvas_X (Canvas, Gdouble (Xc1)); 1874 Xp1_Canvas := World_To_Canvas_X (Canvas, Gdouble (Xp1)); 1875 Xc2_Canvas := World_To_Canvas_X (Canvas, Gdouble (Xc2)); 1876 Xp2_Canvas := World_To_Canvas_X (Canvas, Gdouble (Xp2)); 1877 1878 Y1_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y1)); 1879 Y2_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y2)); 1880 Yp1_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Yp1)); 1881 Yp2_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Yp2)); 1882 Yc1_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Yc1)); 1883 Yc2_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Yc2)); 1884 1885 if X3 /= Gint'First then 1886 -- if (X3 >= Xp1 and then X3 <= X2) 1887 -- or else (X3 <= X1 and then X3 >= Xp2) 1888 -- then 1889 1890 Yarr_Start := Yc1_Canvas; 1891 Yarr_End := Yc2_Canvas; 1892 1893 X3_Canvas := World_To_Canvas_X (Canvas, Gdouble (X3)); 1894 1895 if X3 >= Xp1 then 1896 Cairo.Move_To (Cr, Xp1_Canvas, Yc1_Canvas + 0.5); 1897 Line_To (Cr, X3_Canvas + 0.5, Yc1_Canvas + 0.5); 1898 Line_To (Cr, X3_Canvas + 0.5, Yc2_Canvas + 0.5); 1899 Line_To (Cr, X2_Canvas, Yc2_Canvas + 0.5); 1900 Cairo.Stroke (Cr); 1901 1902 Xarr_Start := Xp1_Canvas; 1903 Xarr_End := X2_Canvas; 1904 Angle_Arr_Start := 0.0; 1905 Angle_Arr_End := -Ada.Numerics.Pi; 1906 else 1907 Move_To (Cr, X1_Canvas, Yc1_Canvas + 0.5); 1908 Line_To (Cr, X3_Canvas + 0.5, Yc1_Canvas + 0.5); 1909 Line_To (Cr, X3_Canvas + 0.5, Yc2_Canvas + 0.5); 1910 Line_To (Cr, Xp2_Canvas, Yc2_Canvas + 0.5); 1911 Cairo.Stroke (Cr); 1912 1913 Xarr_Start := X1_Canvas; 1914 Xarr_End := Xp2_Canvas; 1915 Angle_Arr_Start := -Ada.Numerics.Pi; 1916 Angle_Arr_End := 0.0; 1917 end if; 1918 1919 -- Third case is when we didn't have enough space to draw the 1920 -- intermediate line. In that case, the layout is similar to 1921 -- A ---- 1922 -- | 1923 -- B 1924 -- with the vertical line drawn at the same location as in the first 1925 -- algorithm. 1926 1927 -- elsif X3 >= Xp1 or else X3 <= X1 then 1928 -- if X3 >= Xp1 then 1929 -- Draw_Line (Window, GC, Xp1, Yc1, X3, Yc1); 1930 -- Xarr_Start := Xp1; 1931 -- Angle_Arr_Start := -Ada.Numerics.Pi; 1932 -- else 1933 -- Draw_Line (Window, GC, X1, Yc1, X3, Yc1); 1934 -- Xarr_Start := X1; 1935 -- Angle_Arr_Start := 0.0; 1936 -- end if; 1937 1938 -- Yarr_Start := Yc1; 1939 -- Xarr_End := X3; 1940 1941 -- if Y2 < Yc1 then 1942 -- Draw_Line (Window, GC, X3, Yc1, X3, Yp2); 1943 -- Yarr_End := Yp2; 1944 -- Angle_Arr_End := Ada.Numerics.Pi / 2.0; 1945 -- else 1946 -- Draw_Line (Window, GC, X3, Yc1, X3, Y2); 1947 -- Yarr_End := Y2; 1948 -- Angle_Arr_End := -Ada.Numerics.Pi / 2.0; 1949 -- end if; 1950 1951 -- Second case is when one of the item is below the other one. In that 1952 -- case, the layout should look like 1953 -- AAA 1954 -- |_ 1955 -- | 1956 -- BB 1957 -- ie the link connects the top side of one item and the bottom side of 1958 -- the other item. 1959 1960 else 1961 -- elsif (X1 <= X2 and then X2 <= Xp1) 1962 -- or else (X2 <= X1 and then X1 <= Xp2) 1963 -- then 1964 Y3 := (Y1 + Yp1 + Y2 + Yp2) / 4; 1965 if Canvas.Grid_Size > 0 then 1966 Y3 := Y3 - Y3 mod Gint (Canvas.Grid_Size); 1967 end if; 1968 1969 Y3_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y3)); 1970 1971 Xarr_Start := Xc1_Canvas; 1972 Xarr_End := Xc2_Canvas; 1973 X3_Canvas := (Xc1_Canvas + Xc2_Canvas) / 2.0; 1974 1975 if Y2 > Y3 then 1976 Move_To (Cr, Xc1_Canvas, Yp1_Canvas); 1977 Line_To (Cr, Xc1_Canvas, Y3_Canvas); 1978 Line_To (Cr, Xc2_Canvas, Y3_Canvas); 1979 Line_To (Cr, Xc2_Canvas, Y2_Canvas); 1980 Cairo.Stroke (Cr); 1981 1982 Yarr_Start := Yp1_Canvas; 1983 Yarr_End := Y2_Canvas; 1984 Angle_Arr_End := -Ada.Numerics.Pi / 2.0; 1985 Angle_Arr_Start := Ada.Numerics.Pi / 2.0; 1986 1987 else 1988 Move_To (Cr, Xc1_Canvas, Y1_Canvas); 1989 Line_To (Cr, Xc1_Canvas, Y3_Canvas); 1990 Line_To (Cr, Xc2_Canvas, Y3_Canvas); 1991 Line_To (Cr, Xc2_Canvas, Yp2_Canvas); 1992 Cairo.Stroke (Cr); 1993 1994 Yarr_Start := Y1_Canvas; 1995 Yarr_End := Yp2_Canvas; 1996 Angle_Arr_End := Ada.Numerics.Pi / 2.0; 1997 Angle_Arr_Start := -Ada.Numerics.Pi / 2.0; 1998 end if; 1999 end if; 2000 2001 if Link.Arrow = End_Arrow or else Link.Arrow = Both_Arrow then 2002 Draw_Arrow_Head (Canvas, Cr, Xarr_End, Yarr_End, Angle_Arr_End); 2003 end if; 2004 2005 if Link.Arrow = Start_Arrow or else Link.Arrow = Both_Arrow then 2006 Draw_Arrow_Head (Canvas, Cr, Xarr_Start, Yarr_Start, Angle_Arr_Start); 2007 end if; 2008 2009 -- Draw the text if any 2010 2011 if Link.Descr /= null and then Show_Annotation then 2012 Draw_Annotation 2013 (Canvas, Cr, X3_Canvas, (Y1_Canvas + Y2_Canvas) / 2.0, Link); 2014 end if; 2015 end Draw_Orthogonal_Link; 2016 2017 ------------------------ 2018 -- Draw_Straight_Line -- 2019 ------------------------ 2020 2021 procedure Draw_Straight_Line 2022 (Link : access Canvas_Link_Record; 2023 Cr : Cairo_Context; 2024 Src_Side : Item_Side; 2025 X1, Y1 : Glib.Gdouble; 2026 Dest_Side : Item_Side; 2027 X2, Y2 : Glib.Gdouble) 2028 is 2029 pragma Unreferenced (Link, Src_Side, Dest_Side); 2030 begin 2031 Cairo.Move_To (Cr, X1, Y1); 2032 Cairo.Line_To (Cr, X2, Y2); 2033 Cairo.Stroke (Cr); 2034 end Draw_Straight_Line; 2035 2036 ------------------------ 2037 -- Draw_Straight_Link -- 2038 ------------------------ 2039 2040 procedure Draw_Straight_Link 2041 (Canvas : access Interactive_Canvas_Record'Class; 2042 Cr : Cairo_Context; 2043 Link : access Canvas_Link_Record'Class; 2044 Show_Annotation : Boolean) 2045 is 2046 X1, Y1, X2, Y2, Xs, Ys, Xd, Yd : Gint; 2047 X1_Canvas, Y1_Canvas, X2_Canvas, Y2_Canvas : Gdouble; 2048 Src : constant Canvas_Item := Canvas_Item (Get_Src (Link)); 2049 Dest : constant Canvas_Item := Canvas_Item (Get_Dest (Link)); 2050 Src_Side, Dest_Side : Item_Side; 2051 2052 Src_Coord : constant Cairo_Rectangle_Int := 2053 Get_Actual_Coordinates (Canvas, Src); 2054 Dest_Coord : constant Cairo_Rectangle_Int := 2055 Get_Actual_Coordinates (Canvas, Dest); 2056 2057 begin 2058 Xs := Src_Coord.X; 2059 Ys := Src_Coord.Y; 2060 Xd := Dest_Coord.X; 2061 Yd := Dest_Coord.Y; 2062 2063 Clip_Line 2064 (Src, Canvas, 2065 Xd + Gint (Gfloat (Dest_Coord.Width) * Link.Dest_X_Pos), 2066 Yd + Gint (Gfloat (Dest_Coord.Height) * Link.Dest_Y_Pos), 2067 X_Pos => Link.Src_X_Pos, 2068 Y_Pos => Link.Src_Y_Pos, 2069 Side => Src_Side, 2070 X_Out => X1, 2071 Y_Out => Y1); 2072 Clip_Line 2073 (Dest, Canvas, 2074 Xs + Gint (Gfloat (Src_Coord.Width) * Link.Src_X_Pos), 2075 Ys + Gint (Gfloat (Src_Coord.Height) * Link.Src_Y_Pos), 2076 X_Pos => Link.Dest_X_Pos, Y_Pos => Link.Dest_Y_Pos, 2077 Side => Dest_Side, X_Out => X2, Y_Out => Y2); 2078 2079 X1_Canvas := World_To_Canvas_X (Canvas, Gdouble (X1)); 2080 Y1_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y1)); 2081 X2_Canvas := World_To_Canvas_X (Canvas, Gdouble (X2)); 2082 Y2_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y2)); 2083 2084 Draw_Straight_Line 2085 (Link, Cr, Src_Side, 2086 X1_Canvas, Y1_Canvas, 2087 Dest_Side, 2088 X2_Canvas, Y2_Canvas); 2089 2090 -- Draw the end arrow head 2091 2092 if Link.Arrow = End_Arrow or else Link.Arrow = Both_Arrow then 2093 if X1 /= X2 then 2094 Draw_Arrow_Head 2095 (Canvas, Cr, X2_Canvas, Y2_Canvas, 2096 Arctan (Y1_Canvas - Y2_Canvas, X1_Canvas - X2_Canvas)); 2097 elsif Y1 > Y2 then 2098 Draw_Arrow_Head 2099 (Canvas, Cr, X2_Canvas, Y2_Canvas, Pi / 2.0); 2100 else 2101 Draw_Arrow_Head 2102 (Canvas, Cr, X2_Canvas, Y2_Canvas, -Pi / 2.0); 2103 end if; 2104 end if; 2105 2106 -- Draw the start arrow head 2107 2108 if Link.Arrow = Start_Arrow or else Link.Arrow = Both_Arrow then 2109 if X1 /= X2 then 2110 Draw_Arrow_Head 2111 (Canvas, Cr, X1_Canvas, Y1_Canvas, 2112 Arctan (Y2_Canvas - Y1_Canvas, X2_Canvas - X1_Canvas)); 2113 elsif Y1 > Y2 then 2114 Draw_Arrow_Head (Canvas, Cr, X1_Canvas, Y1_Canvas, -Pi / 2.0); 2115 else 2116 Draw_Arrow_Head (Canvas, Cr, X1_Canvas, Y1_Canvas, Pi / 2.0); 2117 end if; 2118 end if; 2119 2120 -- Draw the text if any 2121 2122 if Link.Descr /= null and then Show_Annotation then 2123 Draw_Annotation 2124 (Canvas, Cr, 2125 (X1_Canvas + X2_Canvas) / 2.0, 2126 (Y1_Canvas + Y2_Canvas) / 2.0, Link); 2127 end if; 2128 end Draw_Straight_Link; 2129 2130 -------------------- 2131 -- Draw_Self_Link -- 2132 -------------------- 2133 2134 procedure Draw_Self_Link 2135 (Canvas : access Interactive_Canvas_Record'Class; 2136 Cr : Cairo_Context; 2137 Link : access Canvas_Link_Record'Class; 2138 Offset : Gint; 2139 Show_Annotation : Boolean) 2140 is 2141 Right_Angle : constant Gdouble := Pi / 2.0; 2142 Src : constant Canvas_Item := Canvas_Item (Get_Src (Link)); 2143 Xc, Yc : Gdouble; 2144 X1, Y1, X3, Y3, Xc_Canvas, Yc_Canvas, Radius : Gdouble; 2145 Src_World : constant Cairo_Rectangle_Int := 2146 Get_Actual_Coordinates (Canvas, Src); 2147 2148 begin 2149 pragma Assert (Src = Canvas_Item (Get_Dest (Link))); 2150 2151 Xc := Gdouble (Src_World.X + Src_World.Width); 2152 Yc := Gdouble (Src_World.Y); 2153 2154 Radius := World_To_Canvas_Length 2155 (Canvas, Gdouble (Canvas.Arc_Link_Offset / 2 * Offset)); 2156 2157 -- Location of the arrow and the annotation 2158 Xc_Canvas := World_To_Canvas_X (Canvas, Xc); 2159 Yc_Canvas := World_To_Canvas_Y (Canvas, Yc); 2160 X3 := Xc_Canvas - Radius; 2161 Y3 := Yc_Canvas; 2162 X1 := Xc_Canvas; 2163 Y1 := Yc_Canvas + Radius; 2164 2165 Cairo.Move_To (Cr, X3, Y3); 2166 Cairo.Arc (Cr, Xc_Canvas, Yc_Canvas, Radius, Pi, Pi * 0.5); 2167 Cairo.Stroke (Cr); 2168 2169 -- Draw the arrows 2170 2171 if Link.Arrow /= No_Arrow then 2172 Draw_Arrow_Head (Canvas, Cr, X3, Y3, -Right_Angle); 2173 end if; 2174 2175 if Link.Arrow = Both_Arrow then 2176 Draw_Arrow_Head (Canvas, Cr, X1, Y1, 0.0); 2177 end if; 2178 2179 -- Draw the annotations 2180 if Link.Descr /= null and then Show_Annotation then 2181 Draw_Annotation 2182 (Canvas, Cr, 2183 Xc_Canvas + Radius / 2.0, Yc_Canvas + Radius / 2.0, Link); 2184 end if; 2185 end Draw_Self_Link; 2186 2187 ------------------- 2188 -- Draw_Arc_Link -- 2189 ------------------- 2190 2191 procedure Draw_Arc_Link 2192 (Canvas : access Interactive_Canvas_Record'Class; 2193 Cr : Cairo_Context; 2194 Link : access Canvas_Link_Record'Class; 2195 Offset : Gint; 2196 Show_Annotation : Boolean) 2197 is 2198 Angle : Gdouble; 2199 X1, Y1, X2, Y2, X3, Y3 : Gint; 2200 X1_Canvas, Y1_Canvas, X2_Canvas, Y2_Canvas : Gdouble; 2201 X3_Canvas, Y3_Canvas : Gdouble; 2202 Right_Angle : constant Gdouble := Pi / 2.0; 2203 Arc_Offset : constant Gdouble := Gdouble (Canvas.Arc_Link_Offset); 2204 Src : constant Canvas_Item := Canvas_Item (Get_Src (Link)); 2205 Dest : constant Canvas_Item := Canvas_Item (Get_Dest (Link)); 2206 Src_Side, Dest_Side : Item_Side; 2207 2208 Src_World : constant Cairo_Rectangle_Int := 2209 Get_Actual_Coordinates (Canvas, Src); 2210 Dest_World : constant Cairo_Rectangle_Int := 2211 Get_Actual_Coordinates (Canvas, Dest); 2212 2213 begin 2214 X1 := Src_World.X; 2215 Y1 := Src_World.Y; 2216 X3 := Dest_World.X; 2217 Y3 := Dest_World.Y; 2218 2219 -- We will first compute the extra intermediate point between the 2220 -- center of the two items. Once we have this intermediate point, we 2221 -- will be able to use the intersection point between the two items 2222 -- and the two lines from the centers to the middle point. This extra 2223 -- point is used as a control point for the Bezier curve. 2224 2225 X1 := X1 + Gint (Gfloat (Src.Coord.Width) * Link.Src_X_Pos); 2226 Y1 := Y1 + Gint (Gfloat (Src.Coord.Height) * Link.Src_Y_Pos); 2227 X3 := X3 + Gint (Gfloat (Dest.Coord.Width) * Link.Dest_X_Pos); 2228 Y3 := Y3 + Gint (Gfloat (Dest.Coord.Height) * Link.Dest_Y_Pos); 2229 2230 -- Compute the middle point for the arc, and create a dummy item for it 2231 -- that the user can move. 2232 2233 if X1 /= X3 then 2234 Angle := Arctan (Gdouble (Y3 - Y1), Gdouble (X3 - X1)); 2235 elsif Y3 > Y1 then 2236 Angle := Right_Angle; 2237 else 2238 Angle := -Right_Angle; 2239 end if; 2240 2241 if Offset < 0 then 2242 Angle := Angle - Right_Angle; 2243 else 2244 Angle := Angle + Right_Angle; 2245 end if; 2246 2247 X2 := (X1 + X3) / 2 + abs (Offset) * Gint (Arc_Offset * Cos (Angle)); 2248 Y2 := (Y1 + Y3) / 2 + abs (Offset) * Gint (Arc_Offset * Sin (Angle)); 2249 2250 -- Clip to the border of the boxes 2251 2252 Clip_Line 2253 (Src, Canvas, 2254 X2, Y2, Link.Src_X_Pos, Link.Src_Y_Pos, Src_Side, X1, Y1); 2255 Clip_Line 2256 (Dest, Canvas, X2, Y2, Link.Dest_X_Pos, Link.Dest_Y_Pos, 2257 Dest_Side, X3, Y3); 2258 2259 X1_Canvas := World_To_Canvas_X (Canvas, Gdouble (X1)); 2260 Y1_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y1)); 2261 X2_Canvas := World_To_Canvas_X (Canvas, Gdouble (X2)); 2262 Y2_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y2)); 2263 X3_Canvas := World_To_Canvas_X (Canvas, Gdouble (X3)); 2264 Y3_Canvas := World_To_Canvas_Y (Canvas, Gdouble (Y3)); 2265 2266 Cairo.Move_To (Cr, X1_Canvas, Y1_Canvas); 2267 Cairo.Curve_To 2268 (Cr, X1_Canvas, Y1_Canvas, 2269 X2_Canvas, Y2_Canvas, 2270 X3_Canvas, Y3_Canvas); 2271 Cairo.Stroke (Cr); 2272 2273 -- Draw the arrows 2274 2275 if Link.Arrow = End_Arrow or else Link.Arrow = Both_Arrow then 2276 if X3 /= X2 then 2277 Angle := Arctan (Y2_Canvas - Y3_Canvas, X2_Canvas - X3_Canvas); 2278 elsif Y3 > Y2 then 2279 Angle := Right_Angle; 2280 else 2281 Angle := -Right_Angle; 2282 end if; 2283 2284 Draw_Arrow_Head (Canvas, Cr, X3_Canvas, Y3_Canvas, Angle); 2285 end if; 2286 2287 if Link.Arrow = Start_Arrow or else Link.Arrow = Both_Arrow then 2288 if X1 /= X2 then 2289 Angle := Arctan (Y2_Canvas - Y1_Canvas, X2_Canvas - X1_Canvas); 2290 elsif Y2 > Y1 then 2291 Angle := Right_Angle; 2292 else 2293 Angle := -Right_Angle; 2294 end if; 2295 2296 Draw_Arrow_Head (Canvas, Cr, X1_Canvas, Y1_Canvas, Angle); 2297 end if; 2298 2299 -- Draw the annotations, if any, in the middle of the link 2300 if Link.Descr /= null and then Show_Annotation then 2301 X2_Canvas := 0.25 * X1_Canvas + 0.5 * X2_Canvas + 0.25 * X3_Canvas; 2302 Y2_Canvas := 0.25 * Y1_Canvas + 0.5 * Y2_Canvas + 0.25 * Y3_Canvas; 2303 Draw_Annotation (Canvas, Cr, X2_Canvas, Y2_Canvas, Link); 2304 end if; 2305 end Draw_Arc_Link; 2306 2307 --------------- 2308 -- Draw_Link -- 2309 --------------- 2310 2311 procedure Draw_Link 2312 (Canvas : access Interactive_Canvas_Record'Class; 2313 Link : access Canvas_Link_Record; 2314 Cr : Cairo_Context; 2315 Edge_Number : Gint; 2316 Show_Annotation : Boolean := True) 2317 is 2318 begin 2319 Set_Line_Width (Cr, 1.0); 2320 2321 -- Self-referencing links 2322 if Get_Src (Link) = Get_Dest (Link) then 2323 Draw_Self_Link 2324 (Canvas, Cr, Link, Edge_Number, Show_Annotation); 2325 2326 elsif Edge_Number = 1 then 2327 -- The first link in the list is always straight 2328 if Canvas.Orthogonal_Links then 2329 Draw_Orthogonal_Link (Canvas, Cr, Link, Show_Annotation); 2330 else 2331 Draw_Straight_Link (Canvas, Cr, Link, Show_Annotation); 2332 end if; 2333 2334 elsif Edge_Number mod 2 = 1 then 2335 Draw_Arc_Link 2336 (Canvas, Cr, Link, Edge_Number / 2, Show_Annotation); 2337 2338 else 2339 Draw_Arc_Link 2340 (Canvas, Cr, Link, -(Edge_Number / 2), Show_Annotation); 2341 2342 end if; 2343 end Draw_Link; 2344 2345 ------------------ 2346 -- Update_Links -- 2347 ------------------ 2348 2349 procedure Update_Links 2350 (Canvas : access Interactive_Canvas_Record; 2351 Cr : Cairo_Context; 2352 Invert_Mode : Boolean; 2353 From_Selection : Boolean) 2354 is 2355 Current : Edge_Iterator := First (Canvas.Children); 2356 Count : Natural := 0; 2357 L : Canvas_Link; 2358 2359 begin 2360 while not At_End (Current) loop 2361 L := Canvas_Link (Get (Current)); 2362 2363 -- We need to draw all links, since they might traverse the visible 2364 -- area, even though both end items are not visible in this area. 2365 2366 if Canvas_Item (Get_Src (L)).Visible 2367 and then Canvas_Item (Get_Dest (L)).Visible 2368 and then 2369 (not From_Selection 2370 or else Canvas_Item (Get_Src (L)).Selected 2371 or else Canvas_Item (Get_Dest (L)).Selected) 2372 then 2373 Draw_Link 2374 (Canvas, L, Cr, 2375 Gint (Repeat_Count (Current)), 2376 Show_Annotation => not Invert_Mode); 2377 end if; 2378 2379 -- To save time, we limit the number of links that are drawn 2380 -- while moving items. 2381 Count := Count + 1; 2382 exit when From_Selection 2383 and then Count > Links_Threshold_While_Moving; 2384 2385 Next (Current); 2386 end loop; 2387 end Update_Links; 2388 2389 --------------- 2390 -- Draw_Grid -- 2391 --------------- 2392 2393 procedure Draw_Grid 2394 (Canvas : access Interactive_Canvas_Record; 2395 Cr : Cairo_Context) 2396 is 2397 Grid : constant Gdouble := 2398 World_To_Canvas_Length (Canvas, Gdouble (Canvas.Grid_Size)); 2399 Ptrn : Cairo_Pattern; 2400 Surface : Cairo_Surface; 2401 Tmp_Cr : Cairo_Context; 2402 2403 begin 2404 if Grid < 1.0 then 2405 return; 2406 end if; 2407 2408 -- First create a surface that will contain the pattern to duplicate 2409 Surface := Cairo.Surface.Create_Similar 2410 (Cairo.Get_Group_Target (Cr), 2411 Cairo_Content_Color_Alpha, 2412 Gint (Grid), Gint (Grid)); 2413 2414 -- We create a context from the surface 2415 Tmp_Cr := Cairo.Create (Surface); 2416 2417 -- Copy the source color 2418 Set_Source (Tmp_Cr, Cairo.Get_Source (Cr)); 2419 Cairo.Set_Line_Width (Tmp_Cr, 1.0); 2420 Cairo.Set_Line_Cap (Tmp_Cr, Cairo_Line_Cap_Round); 2421 2422 -- Let's draw a single point on the surface 2423 Move_To (Tmp_Cr, 0.5, 0.5); 2424 Line_To (Tmp_Cr, 0.5, 0.5); 2425 Stroke (Tmp_Cr); 2426 Destroy (Tmp_Cr); 2427 2428 -- Now that the surface is drawn, let's create a pattern from it 2429 Ptrn := Cairo.Pattern.Create_For_Surface (Surface); 2430 Cairo.Pattern.Set_Extend (Ptrn, Cairo_Extend_Repeat); 2431 2432 -- And paint the background 2433 Cairo.Save (Cr); 2434 Cairo.Set_Source (Cr, Ptrn); 2435 Cairo.Paint_With_Alpha (Cr, 0.5); 2436 Cairo.Restore (Cr); 2437 2438 Destroy (Ptrn); 2439 Destroy (Surface); 2440 end Draw_Grid; 2441 2442 --------------------- 2443 -- Draw_Background -- 2444 --------------------- 2445 2446 procedure Draw_Background 2447 (Canvas : access Interactive_Canvas_Record; 2448 Cr : Cairo_Context) 2449 is 2450 begin 2451 Cairo.Save (Cr); 2452 Set_Source_RGBA (Cr, Canvas.Background_Color); 2453 Paint (Cr); 2454 Cairo.Restore (Cr); 2455 end Draw_Background; 2456 2457 ---------------------- 2458 -- Get_Bounding_Box -- 2459 ---------------------- 2460 2461 procedure Get_Bounding_Box 2462 (Canvas : access Interactive_Canvas_Record'Class; 2463 Width : out Gdouble; 2464 Height : out Gdouble) 2465 is 2466 X_Min, X_Max, Y_Min, Y_Max : Gdouble; 2467 begin 2468 Get_Bounding_Box (Canvas, X_Min, X_Max, Y_Min, Y_Max); 2469 Width := X_Max - X_Min + 40.0; 2470 Height := Y_Max - Y_Min + 40.0; 2471 end Get_Bounding_Box; 2472 2473 -------------- 2474 -- Draw_All -- 2475 -------------- 2476 2477 procedure Draw_All 2478 (Canvas : access Interactive_Canvas_Record'Class; 2479 Cr : Cairo_Context) 2480 is 2481 Area : Cairo_Rectangle_Int; 2482 X_Min, X_Max, Y_Min, Y_Max : Gdouble; 2483 begin 2484 Get_Bounding_Box (Canvas, X_Min, X_Max, Y_Min, Y_Max); 2485 Area := 2486 (X => Gint (X_Min - 20.0), 2487 Y => Gint (Y_Min - 20.0), 2488 Width => Gint (X_Max - X_Min + 40.0), 2489 Height => Gint (Y_Max - Y_Min + 40.0)); 2490 Draw_Area (Canvas, Area, Cr); 2491 end Draw_All; 2492 2493 --------------- 2494 -- Draw_Area -- 2495 --------------- 2496 2497 procedure Draw_Area 2498 (Canvas : access Interactive_Canvas_Record'Class; 2499 Rect : Cairo_Rectangle_Int) 2500 is 2501 Cr : Cairo_Context; 2502 begin 2503 if not Get_Realized (Canvas) then 2504 return; 2505 end if; 2506 2507 Cr := Create (Canvas); 2508 Draw_Area (Canvas, Rect, Cr); 2509 Destroy (Cr); 2510 end Draw_Area; 2511 2512 ------------- 2513 -- Refresh -- 2514 ------------- 2515 2516 procedure Refresh 2517 (Self : not null access Interactive_Canvas_Record; 2518 Item : access Canvas_Item_Record'Class := null) 2519 is 2520 Cr : Cairo_Context; 2521 begin 2522 if Item = null then 2523 Refresh_Canvas (Self); 2524 else 2525 if Item.Visible then 2526 Cr := Create (Self); 2527 2528 begin 2529 Set_Transform 2530 (Self, Cr, 2531 Gdouble (Item.Coord.X), 2532 Gdouble (Item.Coord.Y)); 2533 2534 -- Clip to the item's area 2535 Cairo.Rectangle 2536 (Cr, 2537 0.0, 0.0, 2538 Gdouble (Item.Coord.Width), 2539 Gdouble (Item.Coord.Height)); 2540 Clip (Cr); 2541 2542 if Item.Selected then 2543 Draw_Selected (Item, Cr); 2544 else 2545 Draw (Item, Cr); 2546 end if; 2547 2548 exception 2549 when E : others => 2550 Gtkada.Bindings.Process_Exception (E); 2551 end; 2552 2553 Destroy (Cr); 2554 end if; 2555 end if; 2556 end Refresh; 2557 2558 --------------- 2559 -- Draw_Area -- 2560 --------------- 2561 2562 procedure Draw_Area 2563 (Canvas : access Interactive_Canvas_Record'Class; 2564 Rect : Cairo_Rectangle_Int; 2565 Cr : Cairo_Context) 2566 is 2567 Item : Canvas_Item; 2568 Tmp : Vertex_Iterator := First (Canvas.Children); 2569 Dest : Cairo_Rectangle_Int; 2570 Inters : Boolean; 2571 2572 begin 2573 -- Clear the canvas 2574 2575 Cairo.Save (Cr); 2576 Cairo.Rectangle 2577 (Cr, 2578 World_To_Canvas_X (Canvas, Gdouble (Rect.X)), 2579 World_To_Canvas_Y (Canvas, Gdouble (Rect.Y)), 2580 World_To_Canvas_Length (Canvas, Gdouble (Rect.Width)), 2581 World_To_Canvas_Length (Canvas, Gdouble (Rect.Height))); 2582 Clip (Cr); 2583 Draw_Background (Canvas, Cr); 2584 Draw_Grid (Canvas, Cr); 2585 Cairo.Restore (Cr); 2586 2587 -- Draw the links first, so that they appear to be below the items. 2588 -- ??? Should redraw only the required links 2589 2590 declare 2591 OX : constant Gdouble := Canvas.Offset_X_World; 2592 OY : constant Gdouble := Canvas.Offset_Y_World; 2593 begin 2594 Canvas.Offset_X_World := 0.0; 2595 Canvas.Offset_Y_World := 0.0; 2596 2597 Update_Links 2598 (Canvas, 2599 Cr, 2600 Invert_Mode => False, 2601 From_Selection => False); 2602 2603 -- Draw each of the items. 2604 2605 while not At_End (Tmp) loop 2606 Item := Canvas_Item (Get (Tmp)); 2607 2608 if Item.Visible then 2609 Intersect 2610 (Rect, 2611 (Item.Coord.X, 2612 Item.Coord.Y, 2613 Item.Coord.Width, 2614 Item.Coord.Height), 2615 Dest, Inters); 2616 2617 if Inters then 2618 Cairo.Save (Cr); 2619 2620 begin 2621 Set_Transform 2622 (Canvas, Cr, 2623 Gdouble (Item.Coord.X), 2624 Gdouble (Item.Coord.Y)); 2625 2626 -- Clip to the item's area 2627 Cairo.Rectangle 2628 (Cr, 2629 0.0, 0.0, 2630 Gdouble (Item.Coord.Width), 2631 Gdouble (Item.Coord.Height)); 2632 Clip (Cr); 2633 2634 if Item.Selected then 2635 Draw_Selected (Item, Cr); 2636 else 2637 Draw (Item, Cr); 2638 end if; 2639 2640 exception 2641 when E : others => 2642 Gtkada.Bindings.Process_Exception (E); 2643 end; 2644 2645 Cairo.Restore (Cr); 2646 end if; 2647 end if; 2648 2649 Next (Tmp); 2650 end loop; 2651 2652 Canvas.Offset_X_World := OX; 2653 Canvas.Offset_Y_World := OY; 2654 end; 2655 2656 if Canvas.Offset_X_World /= 0.0 2657 or else Canvas.Offset_Y_World /= 0.0 2658 then 2659 Draw_Dashed_Selection (Canvas, Cr); 2660 end if; 2661 end Draw_Area; 2662 2663 ------------- 2664 -- On_Draw -- 2665 ------------- 2666 2667 function On_Draw 2668 (Canv : access Gtk_Widget_Record'Class; 2669 Cr : Cairo_Context) return Boolean 2670 is 2671 pragma Unreferenced (Cr); 2672 Canvas : constant Interactive_Canvas := Interactive_Canvas (Canv); 2673 X1, X2, Y1, Y2 : Gdouble; 2674 begin 2675 Get_Visible_World (Canvas, X1, Y1, X2, Y2); 2676 2677 if X1 >= Gdouble (Gint'First) 2678 and then X1 <= Gdouble (Gint'Last) 2679 and then Y1 >= Gdouble (Gint'First) 2680 and then Y1 <= Gdouble (Gint'Last) 2681 then 2682 Draw_Area 2683 (Canvas, 2684 (X => Gint (X1), 2685 Y => Gint (Y1), 2686 Width => Gint (X2 - X1), 2687 Height => Gint (Y2 - Y1))); 2688 end if; 2689 2690 return False; 2691 end On_Draw; 2692 2693 --------------------- 2694 -- Set_Screen_Size -- 2695 --------------------- 2696 2697 procedure Set_Screen_Size 2698 (Item : access Canvas_Item_Record; 2699 Width, Height : Gint) 2700 is 2701 Old_W, Old_H : Gint; 2702 begin 2703 Old_W := Item.Coord.Width; 2704 Old_H := Item.Coord.Height; 2705 2706 Item.Coord.Width := Width; 2707 Item.Coord.Height := Height; 2708 2709 if Item.Canvas /= null 2710 and then (Width /= Old_W or else Height /= Old_H) 2711 then 2712 Refresh_Canvas (Item.Canvas); 2713 end if; 2714 end Set_Screen_Size; 2715 2716 ------------------- 2717 -- Draw_Selected -- 2718 ------------------- 2719 2720 procedure Draw_Selected 2721 (Item : access Canvas_Item_Record; 2722 Cr : Cairo.Cairo_Context) 2723 is 2724 Sel : constant Gdk_RGBA := (0.0, 0.0, 0.0, 0.0); 2725 P : Cairo_Pattern; 2726 2727 begin 2728 -- Use an intermediate group to allow proper compositing 2729 Cairo.Push_Group (Cr); 2730 2731 -- Draw the item 2732 Cairo.Save (Cr); 2733 Draw (Canvas_Item (Item), Cr); 2734 Cairo.Restore (Cr); 2735 2736 Cairo.Set_Operator (Cr, Cairo_Operator_Atop); 2737 Cairo.Rectangle 2738 (Cr, 0.0, 0.0, 2739 Gdouble (Item.Coord.Width), 2740 Gdouble (Item.Coord.Height)); 2741 2742 Set_Source_RGBA (Cr, Sel); 2743 2744 Cairo.Fill (Cr); 2745 2746 P := Cairo.Pop_Group (Cr); 2747 Set_Source (Cr, P); 2748 Paint (Cr); 2749 end Draw_Selected; 2750 2751 --------------- 2752 -- Key_Press -- 2753 --------------- 2754 2755 function Key_Press 2756 (Canv : access Gtk_Widget_Record'Class; 2757 Event : Gdk_Event) return Boolean 2758 is 2759 Canvas : constant Interactive_Canvas := Interactive_Canvas (Canv); 2760 Value : constant Gdouble := Canvas.World_Y; 2761 Upper : constant Gdouble := Get_Upper (Canvas.Get_Vadjustment); 2762 Lower : constant Gdouble := Get_Lower (Canvas.Get_Vadjustment); 2763 Page_Incr : constant Gdouble := Scrolling_Amount_Max; 2764 Page_Size : constant Gdouble := Get_Page_Size (Canvas.Get_Vadjustment); 2765 Step_Incr : constant Gdouble := Scrolling_Amount_Min; 2766 2767 begin 2768 -- Note: we do not need to call Changed on the adjustments below, since 2769 -- we are only modifying the value, not the bounds. 2770 2771 case Get_Key_Val (Event) is 2772 when GDK_Home => 2773 Set_Value (Canvas.Get_Vadjustment, Lower); 2774 return True; 2775 2776 when GDK_End => 2777 Set_Value (Canvas.Get_Vadjustment, Upper - Page_Size); 2778 return True; 2779 2780 when GDK_Page_Up => 2781 if Value >= Lower + Page_Incr then 2782 Set_Value (Canvas.Get_Vadjustment, Value - Page_Incr); 2783 else 2784 Set_Value (Canvas.Get_Vadjustment, Lower); 2785 end if; 2786 return True; 2787 2788 when GDK_Page_Down => 2789 if Value + Page_Incr + Page_Size <= Upper then 2790 Set_Value (Canvas.Get_Vadjustment, Value + Page_Incr); 2791 else 2792 Set_Value (Canvas.Get_Vadjustment, Upper - Page_Size); 2793 end if; 2794 return True; 2795 2796 when GDK_Up | GDK_KP_Up => 2797 if Value - Step_Incr >= Lower then 2798 Set_Value (Canvas.Get_Vadjustment, Value - Step_Incr); 2799 else 2800 Set_Value (Canvas.Get_Vadjustment, Lower); 2801 end if; 2802 Gtk.Handlers.Emit_Stop_By_Name (Canvas, "key_press_event"); 2803 return True; 2804 2805 when GDK_Down | GDK_KP_Down => 2806 if Value + Step_Incr + Page_Size <= Upper then 2807 Set_Value (Canvas.Get_Vadjustment, Value + Step_Incr); 2808 else 2809 Set_Value (Canvas.Get_Vadjustment, Upper - Page_Size); 2810 end if; 2811 Gtk.Handlers.Emit_Stop_By_Name (Canvas, "key_press_event"); 2812 return True; 2813 2814 when GDK_Left | GDK_KP_Left => 2815 if Canvas.World_X - 2816 Get_Step_Increment (Canvas.Get_Hadjustment) >= 2817 Get_Lower (Canvas.Get_Hadjustment) 2818 then 2819 Set_Value (Canvas.Get_Hadjustment, 2820 Canvas.World_X 2821 - Get_Step_Increment (Canvas.Get_Hadjustment)); 2822 else 2823 Set_Value (Canvas.Get_Hadjustment, 2824 Get_Lower (Canvas.Get_Hadjustment)); 2825 end if; 2826 Gtk.Handlers.Emit_Stop_By_Name (Canvas, "key_press_event"); 2827 return True; 2828 2829 when GDK_Right | GDK_KP_Right => 2830 if Canvas.World_X + 2831 Get_Step_Increment (Canvas.Get_Hadjustment) + 2832 Get_Page_Size (Canvas.Get_Hadjustment) <= 2833 Get_Upper (Canvas.Get_Hadjustment) 2834 then 2835 Set_Value (Canvas.Get_Hadjustment, 2836 Canvas.World_X + 2837 Get_Step_Increment (Canvas.Get_Hadjustment)); 2838 else 2839 Set_Value (Canvas.Get_Hadjustment, 2840 Get_Upper (Canvas.Get_Hadjustment) - 2841 Get_Page_Size (Canvas.Get_Hadjustment)); 2842 end if; 2843 Gtk.Handlers.Emit_Stop_By_Name (Canvas, "key_press_event"); 2844 return True; 2845 2846 when others => 2847 null; 2848 end case; 2849 2850 return False; 2851 2852 exception 2853 when others => 2854 return False; 2855 end Key_Press; 2856 2857 ------------------- 2858 -- Point_In_Item -- 2859 ------------------- 2860 2861 function Point_In_Item 2862 (Item : access Canvas_Item_Record; 2863 X, Y : Gint) return Boolean is 2864 begin 2865 return X >= Item.Coord.X 2866 and then X <= Item.Coord.X + Item.Coord.Width 2867 and then Y >= Item.Coord.Y 2868 and then Y <= Item.Coord.Y + Item.Coord.Height; 2869 end Point_In_Item; 2870 2871 ------------------------- 2872 -- Item_At_Coordinates -- 2873 ------------------------- 2874 2875 function Item_At_Coordinates 2876 (Canvas : access Interactive_Canvas_Record; 2877 X, Y : Glib.Gint) return Canvas_Item 2878 is 2879 Tmp : Vertex_Iterator := First (Canvas.Children); 2880 Result : Canvas_Item := null; 2881 Item : Canvas_Item; 2882 begin 2883 -- Keep the last item found, since this is the one on top. 2884 -- ??? Not the most efficient way to search, since we have to traverse 2885 -- the whole list every time. 2886 2887 while not At_End (Tmp) loop 2888 Item := Canvas_Item (Get (Tmp)); 2889 2890 if Item.Visible and then Point_In_Item (Item, X, Y) then 2891 Result := Item; 2892 end if; 2893 2894 Next (Tmp); 2895 end loop; 2896 2897 return Result; 2898 end Item_At_Coordinates; 2899 2900 ------------------------- 2901 -- Item_At_Coordinates -- 2902 ------------------------- 2903 2904 function Item_At_Coordinates 2905 (Canvas : access Interactive_Canvas_Record; 2906 Event : Gdk_Event) 2907 return Canvas_Item 2908 is 2909 X_World, Y_World : Gdouble; 2910 Item : Canvas_Item; 2911 2912 begin 2913 Mouse_To_World (Canvas, Event, X_World, Y_World); 2914 Item := Item_At_Coordinates (Canvas, Gint (X_World), Gint (Y_World)); 2915 return Item; 2916 end Item_At_Coordinates; 2917 2918 ------------------------- 2919 -- Item_At_Coordinates -- 2920 ------------------------- 2921 2922 procedure Item_At_Coordinates 2923 (Canvas : access Interactive_Canvas_Record; 2924 Event : Gdk.Event.Gdk_Event; 2925 Item : out Canvas_Item; 2926 X, Y : out Glib.Gint) 2927 is 2928 X_World, Y_World : Gdouble; 2929 2930 begin 2931 Mouse_To_World (Canvas, Event, X_World, Y_World); 2932 Item := Item_At_Coordinates (Canvas, Gint (X_World), Gint (Y_World)); 2933 if Item /= null then 2934 X := Gint (X_World) - Item.Coord.X; 2935 Y := Gint (Y_World) - Item.Coord.Y; 2936 end if; 2937 end Item_At_Coordinates; 2938 2939 -------------------- 2940 -- Button_Pressed -- 2941 -------------------- 2942 2943 function Button_Pressed 2944 (Canv : access Gtk_Widget_Record'Class; 2945 Event : Gdk_Event) return Boolean 2946 is 2947 Canvas : constant Interactive_Canvas := Interactive_Canvas (Canv); 2948 Cursor : Gdk.Gdk_Cursor; 2949 Handled : Boolean; 2950 X, Y : Gdouble; 2951 2952 begin 2953 if Event.Button.Window /= Get_Bin_Window (Canvas) then 2954 return False; 2955 end if; 2956 2957 Grab_Focus (Canvas); 2958 2959 Mouse_To_World 2960 (Canvas, Event, Canvas.World_X_At_Click, Canvas.World_Y_At_Click); 2961 2962 -- Find the selected item. 2963 2964 Canvas.Item_Press := Item_At_Coordinates (Canvas, Event); 2965 2966 if Traces then 2967 if Canvas.Item_Press /= null then 2968 Get_Coords (Event, X, Y); 2969 Put_Line ("Clicked on Item at world coordinates (" 2970 & Gdouble'Image (Canvas.World_X_At_Click) 2971 & Gdouble'Image (Canvas.World_Y_At_Click) 2972 & ") item=(" 2973 & Gint'Image (Canvas.Item_Press.Coord.X) 2974 & Gint'Image (Canvas.Item_Press.Coord.Y) 2975 & Gint'Image (Canvas.Item_Press.Coord.Width) 2976 & Gint'Image (Canvas.Item_Press.Coord.Height) 2977 & ") mouse=" & Gint'Image (Gint (X)) 2978 & Gint'Image (Gint (Y))); 2979 else 2980 Put_Line ("Clicked outside of item at world coordinates " 2981 & Gdouble'Image (Canvas.World_X_At_Click) 2982 & " " & Gdouble'Image (Canvas.World_Y_At_Click)); 2983 end if; 2984 end if; 2985 2986 -- Button press on the background: clear the selection 2987 if Canvas.Item_Press = null then 2988 if (Get_State (Event) and Primary_Mod_Mask) = 0 then 2989 Clear_Selection (Canvas); 2990 end if; 2991 2992 Widget_Callback.Emit_By_Name (Canvas, "background_click", Event); 2993 Canvas.Background_Press := True; 2994 2995 else 2996 Canvas.Background_Press := False; 2997 2998 if (Get_State (Event) and Primary_Mod_Mask) /= 0 then 2999 if Is_Selected (Canvas, Canvas.Item_Press) then 3000 Remove_From_Selection (Canvas, Canvas.Item_Press); 3001 else 3002 Add_To_Selection (Canvas, Canvas.Item_Press); 3003 end if; 3004 else 3005 Event.Button.X := 3006 Canvas.World_X_At_Click - Gdouble (Canvas.Item_Press.Coord.X); 3007 Event.Button.Y := 3008 Canvas.World_Y_At_Click - Gdouble (Canvas.Item_Press.Coord.Y); 3009 Handled := On_Button_Click (Canvas.Item_Press, Event.Button); 3010 3011 if not Handled then 3012 -- If not handled, then: 3013 -- if the iter was part of a selection, do nothing, 3014 -- if the iter was not part of a selection, clear the selection 3015 -- and select this iter. 3016 3017 if not Canvas.Item_Press.Selected then 3018 Clear_Selection (Canvas); 3019 3020 Add_To_Selection (Canvas, Canvas.Item_Press); 3021 end if; 3022 3023 Canvas.Item_Press := null; 3024 else 3025 return True; 3026 end if; 3027 end if; 3028 end if; 3029 3030 -- Change the cursor to give visual feedback 3031 3032 Gdk_New (Cursor, Fleur); 3033 Set_Cursor (Get_Bin_Window (Canvas), Cursor); 3034 Unref (Cursor); 3035 3036 -- Initialize the move 3037 3038 Canvas.Offset_X_World := 0.0; 3039 Canvas.Offset_Y_World := 0.0; 3040 Canvas.Mouse_Has_Moved := False; 3041 Canvas.Surround_Box_Scroll := Scrolling_Amount_Min; 3042 3043 -- Make sure that no other widget steals the events while we are 3044 -- moving an item. 3045 3046 Canvas.Grab_Add; 3047 3048 return False; 3049 3050 exception 3051 when others => 3052 return False; 3053 end Button_Pressed; 3054 3055 ------------------- 3056 -- Button_Motion -- 3057 ------------------- 3058 3059 function Button_Motion 3060 (Canv : access Gtk_Widget_Record'Class; 3061 Event : Gdk_Event) return Boolean 3062 is 3063 Canvas : constant Interactive_Canvas := 3064 Interactive_Canvas (Canv); 3065 X_Scroll, Y_Scroll : Gdouble; 3066 X, Y : Gdouble; 3067 Dead : Boolean; 3068 pragma Unreferenced (Dead); 3069 3070 Mouse_X_Canvas, Mouse_Y_Canvas : Gdouble; 3071 begin 3072 if Event.Button.Window /= Get_Bin_Window (Canvas) then 3073 return False; 3074 end if; 3075 3076 if Canvas.Item_Press /= null then 3077 declare 3078 New_X, New_Y : Gdouble; 3079 begin 3080 Mouse_To_World (Canvas, Event, New_X, New_Y); 3081 Event.Button.X := New_X - Gdouble (Canvas.Item_Press.Coord.X); 3082 Event.Button.Y := New_Y - Gdouble (Canvas.Item_Press.Coord.Y); 3083 end; 3084 3085 return On_Button_Click (Canvas.Item_Press, Event.Button); 3086 end if; 3087 3088 -- Are we in the scrolling box ? If yes, do not move the item 3089 -- directly, but establish the timeout callbacks that will take care 3090 -- of the scrolling 3091 3092 Get_Coords (Event, X, Y); 3093 Mouse_X_Canvas := X - Canvas.Get_Hadjustment.Get_Value; 3094 Mouse_Y_Canvas := Y - Canvas.Get_Vadjustment.Get_Value; 3095 3096 Test_Scrolling_Box 3097 (Canvas => Canvas, 3098 Mouse_X_In_Canvas => Mouse_X_Canvas, 3099 Mouse_Y_In_Canvas => Mouse_Y_Canvas, 3100 X_Scroll => X_Scroll, 3101 Y_Scroll => Y_Scroll); 3102 3103 if X_Scroll /= 0.0 or else Y_Scroll /= 0.0 then 3104 if Canvas.Scrolling_Timeout_Id = 0 then 3105 if Traces then 3106 Put_Line ("Button_Motion, within the scrolling box," 3107 & " starting timeout"); 3108 end if; 3109 Canvas.Scrolling_Device := Gtk.Main.Get_Current_Event_Device; 3110 Canvas.Scrolling_Timeout_Id := Canvas_Timeout.Timeout_Add 3111 (Timeout_Between_Scrolls, Scrolling_Timeout'Access, Canvas); 3112 end if; 3113 return False; 3114 end if; 3115 3116 if Canvas.Scrolling_Timeout_Id /= 0 then 3117 if Traces then 3118 Put_Line ("Button_Motion, cancel timeout"); 3119 end if; 3120 Remove (Canvas.Scrolling_Timeout_Id); 3121 Canvas.Surround_Box_Scroll := Scrolling_Amount_Min; 3122 Canvas.Scrolling_Timeout_Id := 0; 3123 end if; 3124 3125 -- Find the current mouse position in world coordinates, to find out 3126 -- where to draw the dashed outline. 3127 3128 Mouse_To_World (Canvas, Event, X_Scroll, Y_Scroll); 3129 3130 Dead := Move_Selection 3131 (Canvas, 3132 New_Offset_X_World => X_Scroll - Canvas.World_X_At_Click, 3133 New_Offset_Y_World => Y_Scroll - Canvas.World_Y_At_Click, 3134 Behavior => Do_Not_Change); 3135 3136 return False; 3137 end Button_Motion; 3138 3139 -------------------- 3140 -- Button_Release -- 3141 -------------------- 3142 3143 function Button_Release 3144 (Canv : access Gtk_Widget_Record'Class; 3145 Event : Gdk_Event) return Boolean 3146 is 3147 Canvas : constant Interactive_Canvas := Interactive_Canvas (Canv); 3148 Rect, Coord : Gdk_Rectangle; 3149 Iter : Item_Iterator; 3150 Item : Canvas_Item; 3151 Handled : Boolean; 3152 3153 begin 3154 Canvas.Grab_Remove; 3155 3156 -- Restore the standard cursor 3157 Set_Cursor (Get_Bin_Window (Canvas), null); 3158 3159 if Event.Button.Window /= Get_Bin_Window (Canvas) then 3160 return False; 3161 end if; 3162 3163 if Canvas.Scrolling_Timeout_Id /= 0 then 3164 Remove (Canvas.Scrolling_Timeout_Id); 3165 Canvas.Scrolling_Timeout_Id := 0; 3166 Canvas.Surround_Box_Scroll := Scrolling_Amount_Min; 3167 end if; 3168 3169 if Canvas.Item_Press /= null then 3170 3171 -- Translate the button's coordinates 3172 declare 3173 New_X, New_Y : Gdouble; 3174 begin 3175 Mouse_To_World (Canvas, Event, New_X, New_Y); 3176 Event.Button.X := New_X - Gdouble (Canvas.Item_Press.Coord.X); 3177 Event.Button.Y := New_Y - Gdouble (Canvas.Item_Press.Coord.Y); 3178 end; 3179 3180 Handled := On_Button_Click (Canvas.Item_Press, Event.Button); 3181 Canvas.Item_Press := null; 3182 3183 return Handled; 3184 3185 elsif Canvas.Selected_Count = 0 3186 and then Canvas.Background_Press 3187 then 3188 Widget_Callback.Emit_By_Name (Canvas, "background_click", Event); 3189 3190 -- Select all the items inside the rectangle 3191 3192 Rect := Get_Background_Selection_Rectangle (Canvas); 3193 3194 Iter := Start (Canvas, Selected_Only => False); 3195 while Get (Iter) /= null loop 3196 Coord := Get_Coord (Get (Iter)); 3197 3198 -- Only items fully contained in the rectangle are selected 3199 if Rect.X <= Coord.X 3200 and then Coord.X + Coord.Width <= Rect.X + Rect.Width 3201 and then Rect.Y <= Coord.Y 3202 and then Coord.Y + Coord.Height <= Rect.Y + Rect.Height 3203 then 3204 Add_To_Selection (Canvas, Get (Iter)); 3205 end if; 3206 3207 Next (Iter); 3208 end loop; 3209 3210 Canvas.Offset_X_World := 0.0; 3211 Canvas.Offset_Y_World := 0.0; 3212 3213 Queue_Draw (Canvas); 3214 3215 return True; 3216 3217 elsif Canvas.Mouse_Has_Moved then 3218 Iter := Start (Canvas, Selected_Only => True); 3219 loop 3220 Item := Get (Iter); 3221 exit when Item = null; 3222 3223 Item.Coord := Get_Actual_Coordinates (Canvas, Item); 3224 Item.From_Auto_Layout := False; 3225 3226 Emit_By_Name_Item 3227 (Get_Object (Canvas), "item_moved" & ASCII.NUL, Item); 3228 3229 Next (Iter); 3230 end loop; 3231 3232 Canvas.Offset_X_World := 0.0; 3233 Canvas.Offset_Y_World := 0.0; 3234 3235 -- Scroll the canvas so as to show the first item from the selection 3236 Refresh_Canvas (Canvas); 3237 3238 else 3239 -- If we are reaching this point, this means that there wasn't an 3240 -- item being pressed, and we didn't perform a button pressed move. 3241 -- So if there is an item under the cursor, if this item wasn't 3242 -- already selected, clear the selection. 3243 Item := Item_At_Coordinates (Canvas, Event); 3244 if not Item.Selected then 3245 Clear_Selection (Canvas); 3246 end if; 3247 end if; 3248 3249 Canvas.Item_Press := null; 3250 3251 return False; 3252 3253 exception 3254 when others => 3255 return False; 3256 end Button_Release; 3257 3258 ---------------------------------------- 3259 -- Get_Background_Selection_Rectangle -- 3260 ---------------------------------------- 3261 3262 function Get_Background_Selection_Rectangle 3263 (Canvas : access Interactive_Canvas_Record'Class) return Gdk_Rectangle 3264 is 3265 X : Gint := Gint (Canvas.World_X_At_Click); 3266 Y : Gint := Gint (Canvas.World_Y_At_Click); 3267 W : Gint := Gint (Canvas.Offset_X_World); 3268 H : Gint := Gint (Canvas.Offset_Y_World); 3269 3270 begin 3271 if W < 0 then 3272 W := -W; 3273 X := X - W; 3274 end if; 3275 3276 if H < 0 then 3277 H := -H; 3278 Y := Y - H; 3279 end if; 3280 3281 return (X, Y, W, H); 3282 end Get_Background_Selection_Rectangle; 3283 3284 ------------------------ 3285 -- Test_Scrolling_Box -- 3286 ------------------------ 3287 3288 procedure Test_Scrolling_Box 3289 (Canvas : access Interactive_Canvas_Record'Class; 3290 Mouse_X_In_Canvas, Mouse_Y_In_Canvas : Gdouble; 3291 X_Scroll : out Gdouble; 3292 Y_Scroll : out Gdouble) 3293 is 3294 X_Ignored, Y_Ignored : Gint; 3295 Width, Height : Gint; 3296 Margin : constant Gdouble := 3297 World_To_Canvas_Length (Canvas, Gdouble (Scrolling_Margin)); 3298 begin 3299 Get_Geometry 3300 (Canvas.Get_Window, 3301 X_Ignored, Y_Ignored, 3302 Width, Height); 3303 3304 if Mouse_X_In_Canvas < Margin then 3305 X_Scroll := Canvas_To_World_Length 3306 (Canvas, -Canvas.Surround_Box_Scroll); 3307 elsif Mouse_X_In_Canvas > Gdouble (Width) - Margin then 3308 X_Scroll := Canvas_To_World_Length 3309 (Canvas, Canvas.Surround_Box_Scroll); 3310 else 3311 X_Scroll := 0.0; 3312 end if; 3313 3314 if Mouse_Y_In_Canvas < Margin then 3315 Y_Scroll := Canvas_To_World_Length 3316 (Canvas, -Canvas.Surround_Box_Scroll); 3317 elsif Mouse_Y_In_Canvas > Gdouble (Height) - Margin then 3318 Y_Scroll := Canvas_To_World_Length 3319 (Canvas, Canvas.Surround_Box_Scroll); 3320 else 3321 Y_Scroll := 0.0; 3322 end if; 3323 3324 if Traces then 3325 Put_Line ("Test_Scrolling_Box, world delta=" 3326 & Gdouble'Image (X_Scroll) & " " 3327 & Gdouble'Image (Y_Scroll) 3328 & " mouse canvas=" 3329 & Gdouble'Image (Mouse_X_In_Canvas) 3330 & Gdouble'Image (Mouse_Y_In_Canvas)); 3331 end if; 3332 end Test_Scrolling_Box; 3333 3334 ----------------------- 3335 -- Scrolling_Timeout -- 3336 ----------------------- 3337 3338 function Scrolling_Timeout (Canvas : Interactive_Canvas) return Boolean is 3339 Mouse_X_Canvas, Mouse_Y_Canvas : Gint; 3340 Mask : Gdk_Modifier_Type; 3341 W : Gdk_Window; 3342 X_Scroll, Y_Scroll : Gdouble; 3343 Cr : Cairo_Context; 3344 3345 begin 3346 if Traces then 3347 Put_Line ("Scrolling timeout"); 3348 end if; 3349 3350 W := Get_Window (Canvas); 3351 3352 Get_Device_Position 3353 (Get_Window (Canvas), Canvas.Scrolling_Device, 3354 Mouse_X_Canvas, Mouse_Y_Canvas, Mask, W); 3355 3356 Test_Scrolling_Box 3357 (Canvas, Gdouble (Mouse_X_Canvas), 3358 Gdouble (Mouse_Y_Canvas), X_Scroll, Y_Scroll); 3359 3360 if (X_Scroll /= 0.0 or else Y_Scroll /= 0.0) 3361 and then Move_Selection 3362 (Canvas, 3363 New_Offset_X_World => X_Scroll + Canvas.Offset_X_World, 3364 New_Offset_Y_World => Y_Scroll + Canvas.Offset_Y_World, 3365 Behavior => Clamp) 3366 then 3367 -- Keep increasing the speed 3368 if Canvas.Surround_Box_Scroll < Scrolling_Amount_Max then 3369 Canvas.Surround_Box_Scroll := Canvas.Surround_Box_Scroll 3370 * Scrolling_Amount_Increase; 3371 end if; 3372 3373 -- Force an immediate draw, since Queue_Draw would only redraw in 3374 -- an idle event, and thus might not happen before the next timeout. 3375 -- With lots of items, this would break the scrolling. 3376 3377 Cr := Create (Canvas); 3378 Draw_All (Canvas, Cr); 3379 Destroy (Cr); 3380 return True; 3381 else 3382 Canvas.Surround_Box_Scroll := Scrolling_Amount_Min; 3383 Canvas.Scrolling_Timeout_Id := 0; 3384 return False; 3385 end if; 3386 end Scrolling_Timeout; 3387 3388 --------------------------- 3389 -- Draw_Dashed_Selection -- 3390 --------------------------- 3391 3392 procedure Draw_Dashed_Selection 3393 (Canvas : access Interactive_Canvas_Record'Class; 3394 Cr : Cairo_Context) 3395 is 3396 Iter : Item_Iterator; 3397 Item : Canvas_Item; 3398 Rect : Gdk_Rectangle; 3399 Sel : Gdk_RGBA := (0.0, 0.0, 0.0, 1.0); 3400 3401 begin 3402 if Canvas.Selected_Count = 0 then 3403 Rect := Get_Background_Selection_Rectangle (Canvas); 3404 3405 Cairo.Save (Cr); 3406 Set_Transform 3407 (Canvas, Cr, Gdouble (Rect.X), Gdouble (Rect.Y)); 3408 Cairo.Rectangle 3409 (Cr, 3410 0.5, 3411 0.5, 3412 Gdouble (Rect.Width) - 1.0, 3413 Gdouble (Rect.Height) - 1.0); 3414 3415 Sel.Alpha := 0.3; 3416 Set_Source_RGBA (Cr, Sel); 3417 Fill_Preserve (Cr); 3418 3419 Sel.Alpha := 1.0; 3420 Set_Source_RGBA (Cr, Sel); 3421 Stroke (Cr); 3422 3423 Cairo.Restore (Cr); 3424 3425 else 3426 Iter := Start (Canvas, Selected_Only => True); 3427 Set_Source_RGBA (Cr, (0.0, 0.0, 0.0, 0.3)); 3428 3429 loop 3430 Item := Get (Iter); 3431 exit when Item = null; 3432 3433 if Item.Visible then 3434 Cairo.Save (Cr); 3435 3436 declare 3437 C : constant Cairo_Rectangle_Int := 3438 Get_Actual_Coordinates (Canvas, Item); 3439 begin 3440 Set_Transform (Canvas, Cr, Gdouble (C.X), Gdouble (C.Y)); 3441 Cairo.Rectangle 3442 (Cr, 0.0, 0.0, Gdouble (C.Width), Gdouble (C.Height)); 3443 Cairo.Fill (Cr); 3444 3445 exception 3446 when E : others => 3447 Gtkada.Bindings.Process_Exception (E); 3448 end; 3449 3450 Cairo.Restore (Cr); 3451 end if; 3452 Next (Iter); 3453 end loop; 3454 3455 Update_Links 3456 (Canvas, Cr, Invert_Mode => True, From_Selection => True); 3457 end if; 3458 end Draw_Dashed_Selection; 3459 3460 -------------------- 3461 -- Move_Selection -- 3462 -------------------- 3463 3464 function Move_Selection 3465 (Canvas : access Interactive_Canvas_Record'Class; 3466 New_Offset_X_World, New_Offset_Y_World : Gdouble; 3467 Behavior : Bounds_Modification_Mode) return Boolean 3468 is 3469 Z : Gdouble renames Canvas.Zoom; 3470 begin 3471 if not Canvas.Mouse_Has_Moved then 3472 -- Is this a motion, or simply a selection ? 3473 3474 if abs (New_Offset_X_World) <= Canvas.Motion_Threshold / Z 3475 and then abs (New_Offset_Y_World) <= Canvas.Motion_Threshold / Z 3476 then 3477 return False; 3478 end if; 3479 end if; 3480 3481 Canvas.Mouse_Has_Moved := True; 3482 3483 if Traces then 3484 Put_Line ("Move_Selection, delta world=" 3485 & Gdouble'Image (New_Offset_X_World) 3486 & " " & Gdouble'Image (New_Offset_Y_World)); 3487 end if; 3488 3489 Canvas.Offset_X_World := New_Offset_X_World; 3490 Canvas.Offset_Y_World := New_Offset_Y_World; 3491 3492 Update_Adjustments (Canvas, Behavior); 3493 3494 Scroll_Canvas_To_Area 3495 (Canvas, 3496 Canvas.World_X_At_Click + 3497 Canvas.Offset_X_World - Gdouble (Scrolling_Margin), 3498 Canvas.World_Y_At_Click + 3499 Canvas.Offset_Y_World - Gdouble (Scrolling_Margin), 3500 Canvas.World_X_At_Click + 3501 Canvas.Offset_X_World + Gdouble (Scrolling_Margin), 3502 Canvas.World_Y_At_Click + 3503 Canvas.Offset_Y_World + Gdouble (Scrolling_Margin)); 3504 3505 Queue_Draw (Canvas); 3506 3507 return True; 3508 end Move_Selection; 3509 3510 ------------------ 3511 -- Item_Updated -- 3512 ------------------ 3513 3514 procedure Item_Updated 3515 (Canvas : access Interactive_Canvas_Record; 3516 Item : access Canvas_Item_Record'Class) 3517 is 3518 begin 3519 if Item.Visible then 3520 Queue_Draw_Area 3521 (Canvas, 3522 Item.Coord.X, 3523 Item.Coord.Y, 3524 Item.Coord.Width, 3525 Item.Coord.Height); 3526 end if; 3527 end Item_Updated; 3528 3529 ------------ 3530 -- Remove -- 3531 ------------ 3532 3533 procedure Remove 3534 (Canvas : access Interactive_Canvas_Record; 3535 Item : access Canvas_Item_Record'Class) is 3536 begin 3537 Remove_From_Selection (Canvas, Item); 3538 Remove (Canvas.Children, Item); 3539 3540 -- Have to redraw everything, since there might have been some 3541 -- links. 3542 -- ??? Note very efficient when removing several items. 3543 Refresh_Canvas (Canvas); 3544 end Remove; 3545 3546 ----------- 3547 -- Clear -- 3548 ----------- 3549 3550 procedure Clear (Canvas : access Interactive_Canvas_Record) is 3551 begin 3552 Clear_Selection (Canvas); 3553 Clear (Canvas.Children); 3554 Refresh_Canvas (Canvas); 3555 end Clear; 3556 3557 --------------------- 3558 -- On_Button_Click -- 3559 --------------------- 3560 3561 function On_Button_Click 3562 (Item : access Canvas_Item_Record; 3563 Event : Gdk.Event.Gdk_Event_Button) return Boolean 3564 is 3565 pragma Unreferenced (Item, Event); 3566 begin 3567 return False; 3568 end On_Button_Click; 3569 3570 --------------- 3571 -- Get_Coord -- 3572 --------------- 3573 3574 function Get_Coord 3575 (Item : access Canvas_Item_Record) return Gdk.Rectangle.Gdk_Rectangle is 3576 begin 3577 return Item.Coord; 3578 end Get_Coord; 3579 3580 -------------- 3581 -- Has_Link -- 3582 -------------- 3583 3584 function Has_Link 3585 (Canvas : access Interactive_Canvas_Record; 3586 From, To : access Canvas_Item_Record'Class; 3587 Name : UTF8_String := "") return Boolean 3588 is 3589 Current : Edge_Iterator := First 3590 (Canvas.Children, 3591 Src => Vertex_Access (From), 3592 Dest => Vertex_Access (To), 3593 Directed => False); 3594 E : Canvas_Link; 3595 Candidate : Boolean; 3596 begin 3597 -- We need to examine both links from FROM to TO and from TO to FROM, 3598 -- since the layout algorithm might sometimes transparently revert links 3599 -- to get an acyclic graph 3600 3601 while not At_End (Current) loop 3602 E := Canvas_Link (Get (Current)); 3603 if Get_Arrow_Type (E) = End_Arrow then 3604 Candidate := Get_Src (E) = Vertex_Access (From) 3605 and then Get_Dest (E) = Vertex_Access (To); 3606 elsif Get_Arrow_Type (E) = Start_Arrow then 3607 Candidate := Get_Src (E) = Vertex_Access (To) 3608 and then Get_Dest (E) = Vertex_Access (From); 3609 else 3610 Candidate := True; 3611 end if; 3612 3613 if Candidate 3614 and then 3615 (Name = "" 3616 or else (Canvas_Link (Get (Current)).Descr /= null 3617 and then Canvas_Link (Get (Current)).Descr.all = Name)) 3618 then 3619 return True; 3620 end if; 3621 Next (Current); 3622 end loop; 3623 return False; 3624 end Has_Link; 3625 3626 ---------------- 3627 -- Lower_Item -- 3628 ---------------- 3629 3630 procedure Lower_Item 3631 (Canvas : access Interactive_Canvas_Record; 3632 Item : access Canvas_Item_Record'Class) is 3633 begin 3634 Move_To_Front (Canvas.Children, Item); 3635 3636 -- Redraw just the part of the canvas that is impacted. 3637 Item_Updated (Canvas, Item); 3638 end Lower_Item; 3639 3640 ---------------- 3641 -- Raise_Item -- 3642 ---------------- 3643 3644 procedure Raise_Item 3645 (Canvas : access Interactive_Canvas_Record; 3646 Item : access Canvas_Item_Record'Class) is 3647 begin 3648 Move_To_Back (Canvas.Children, Item); 3649 3650 -- Redraw just the part of the canvas that is impacted. 3651 Item_Updated (Canvas, Item); 3652 end Raise_Item; 3653 3654 --------------- 3655 -- Is_On_Top -- 3656 --------------- 3657 3658 function Is_On_Top 3659 (Canvas : access Interactive_Canvas_Record; 3660 Item : access Canvas_Item_Record'Class) return Boolean 3661 is 3662 Iter : Vertex_Iterator := First (Canvas.Children); 3663 Last : Canvas_Item := null; 3664 begin 3665 while not At_End (Iter) loop 3666 Last := Canvas_Item (Get (Iter)); 3667 Next (Iter); 3668 end loop; 3669 return Last = Canvas_Item (Item); 3670 end Is_On_Top; 3671 3672 --------------- 3673 -- Show_Item -- 3674 --------------- 3675 3676 procedure Show_Item 3677 (Canvas : access Interactive_Canvas_Record'Class; 3678 Item : access Canvas_Item_Record'Class; 3679 Canvas_X, Canvas_Y : Gdouble) 3680 is 3681 begin 3682 Scroll_Canvas_To_Item 3683 (Canvas, Item, Canvas_X, Canvas_Y); 3684 end Show_Item; 3685 3686 ---------------- 3687 -- Align_Item -- 3688 ---------------- 3689 3690 procedure Align_Item 3691 (Canvas : access Interactive_Canvas_Record; 3692 Item : access Canvas_Item_Record'Class; 3693 X_Align : Float := 0.5; 3694 Y_Align : Float := 0.5) is 3695 begin 3696 Show_Item (Canvas, Item, Gdouble (X_Align), Gdouble (Y_Align)); 3697 end Align_Item; 3698 3699 --------------- 3700 -- Show_Item -- 3701 --------------- 3702 3703 procedure Show_Item 3704 (Canvas : access Interactive_Canvas_Record; 3705 Item : access Canvas_Item_Record'Class) is 3706 begin 3707 Show_Item (Canvas, Item, 0.5, 0.5); 3708 end Show_Item; 3709 3710 ----------------------- 3711 -- Get_Align_On_Grid -- 3712 ----------------------- 3713 3714 function Get_Align_On_Grid 3715 (Canvas : access Interactive_Canvas_Record) return Boolean is 3716 begin 3717 return Canvas.Align_On_Grid; 3718 end Get_Align_On_Grid; 3719 3720 -------------------- 3721 -- Set_Visibility -- 3722 -------------------- 3723 3724 procedure Set_Visibility 3725 (Item : access Canvas_Item_Record; 3726 Visible : Boolean) is 3727 begin 3728 Item.Visible := Visible; 3729 end Set_Visibility; 3730 3731 ---------------- 3732 -- Is_Visible -- 3733 ---------------- 3734 3735 function Is_Visible (Item : access Canvas_Item_Record) return Boolean is 3736 begin 3737 return Item.Visible; 3738 end Is_Visible; 3739 3740 -------------------- 3741 -- Refresh_Canvas -- 3742 -------------------- 3743 3744 procedure Refresh_Canvas (Canvas : access Interactive_Canvas_Record) is 3745 begin 3746 Update_Adjustments (Canvas); 3747 Queue_Draw (Canvas); 3748 end Refresh_Canvas; 3749 3750 --------------------- 3751 -- Clear_Selection -- 3752 --------------------- 3753 3754 procedure Clear_Selection (Canvas : access Interactive_Canvas_Record) is 3755 Iter : Item_Iterator := Start (Canvas, Selected_Only => True); 3756 begin 3757 while Get (Iter) /= null loop 3758 Remove_From_Selection (Canvas, Get (Iter)); 3759 Next (Iter); 3760 end loop; 3761 end Clear_Selection; 3762 3763 ---------------------- 3764 -- Add_To_Selection -- 3765 ---------------------- 3766 3767 procedure Add_To_Selection 3768 (Canvas : access Interactive_Canvas_Record; 3769 Item : access Canvas_Item_Record'Class) 3770 is 3771 begin 3772 if not Item.Selected then 3773 Canvas.Selected_Count := Canvas.Selected_Count + 1; 3774 Item.Selected := True; 3775 Selected (Item, Canvas, Is_Selected => True); 3776 Emit_By_Name_Item 3777 (Get_Object (Canvas), "item_selected" & ASCII.NUL, Item); 3778 end if; 3779 end Add_To_Selection; 3780 3781 --------------------------- 3782 -- Remove_From_Selection -- 3783 --------------------------- 3784 3785 procedure Remove_From_Selection 3786 (Canvas : access Interactive_Canvas_Record; 3787 Item : access Canvas_Item_Record'Class) 3788 is 3789 begin 3790 if Item.Selected then 3791 Canvas.Selected_Count := Canvas.Selected_Count - 1; 3792 Item.Selected := False; 3793 if not Canvas.In_Destruction then 3794 Selected (Item, Canvas, Is_Selected => False); 3795 end if; 3796 3797 Emit_By_Name_Item 3798 (Get_Object (Canvas), "item_unselected" & ASCII.NUL, Item); 3799 end if; 3800 end Remove_From_Selection; 3801 3802 ---------------- 3803 -- Select_All -- 3804 ---------------- 3805 3806 procedure Select_All (Canvas : access Interactive_Canvas_Record) is 3807 Iter : Item_Iterator := Start (Canvas, Selected_Only => False); 3808 Item : Canvas_Item; 3809 begin 3810 loop 3811 Item := Get (Iter); 3812 exit when Item = null; 3813 Add_To_Selection (Canvas, Item); 3814 Next (Iter); 3815 end loop; 3816 end Select_All; 3817 3818 --------------- 3819 -- Configure -- 3820 --------------- 3821 3822 procedure Configure 3823 (Link : access Canvas_Link_Record; 3824 Arrow : Arrow_Type := End_Arrow; 3825 Descr : UTF8_String := "") is 3826 begin 3827 Link.Arrow := Arrow; 3828 Free (Link.Descr); 3829 Link.Descr := new String'(Descr); 3830 end Configure; 3831 3832 -------------- 3833 -- Add_Link -- 3834 -------------- 3835 3836 procedure Add_Link 3837 (Canvas : access Interactive_Canvas_Record; 3838 Link : access Canvas_Link_Record'Class; 3839 Src : access Canvas_Item_Record'Class; 3840 Dest : access Canvas_Item_Record'Class; 3841 Arrow : Arrow_Type := End_Arrow; 3842 Descr : UTF8_String := "") is 3843 begin 3844 Configure (Link, Arrow, Descr); 3845 Add_Edge (Canvas.Children, Link, Src, Dest); 3846 end Add_Link; 3847 3848 ----------------- 3849 -- Remove_Link -- 3850 ----------------- 3851 3852 procedure Remove_Link 3853 (Canvas : access Interactive_Canvas_Record; 3854 Link : access Canvas_Link_Record'Class) is 3855 begin 3856 Remove (Canvas.Children, Link); 3857 end Remove_Link; 3858 3859 ------------------- 3860 -- For_Each_Link -- 3861 ------------------- 3862 3863 procedure For_Each_Link 3864 (Canvas : access Interactive_Canvas_Record; 3865 Execute : Link_Processor; 3866 From, To : Canvas_Item := null) 3867 is 3868 Iter : Edge_Iterator := First 3869 (Canvas.Children, Vertex_Access (From), Vertex_Access (To)); 3870 Link : Canvas_Link; 3871 begin 3872 while not At_End (Iter) loop 3873 Link := Canvas_Link (Get (Iter)); 3874 Next (Iter); 3875 exit when not Execute (Canvas, Link); 3876 end loop; 3877 end For_Each_Link; 3878 3879 ------------- 3880 -- Destroy -- 3881 ------------- 3882 3883 procedure Destroy (Link : in out Canvas_Link_Record) is 3884 begin 3885 Free (Link.Descr); 3886 end Destroy; 3887 3888 procedure Destroy (Item : in out Canvas_Item_Record) is 3889 pragma Unreferenced (Item); 3890 begin 3891 null; 3892 end Destroy; 3893 3894 --------------- 3895 -- Get_Descr -- 3896 --------------- 3897 3898 function Get_Descr (Link : access Canvas_Link_Record) return UTF8_String is 3899 begin 3900 if Link.Descr = null then 3901 return ""; 3902 else 3903 return Link.Descr.all; 3904 end if; 3905 end Get_Descr; 3906 3907 ----------------- 3908 -- Set_Src_Pos -- 3909 ----------------- 3910 3911 procedure Set_Src_Pos 3912 (Link : access Canvas_Link_Record; X_Pos, Y_Pos : Gfloat := 0.5) is 3913 begin 3914 Link.Src_X_Pos := X_Pos; 3915 Link.Src_Y_Pos := Y_Pos; 3916 end Set_Src_Pos; 3917 3918 ------------------ 3919 -- Set_Dest_Pos -- 3920 ------------------ 3921 3922 procedure Set_Dest_Pos 3923 (Link : access Canvas_Link_Record; X_Pos, Y_Pos : Gfloat := 0.5) is 3924 begin 3925 Link.Dest_X_Pos := X_Pos; 3926 Link.Dest_Y_Pos := Y_Pos; 3927 end Set_Dest_Pos; 3928 3929 ------------------ 3930 -- Zoom_Timeout -- 3931 ------------------ 3932 3933 function Zoom_Timeout (Canvas : Interactive_Canvas) return Boolean is 3934 Now : constant Ada.Calendar.Time := Ada.Calendar.Clock; 3935 Z : Gdouble; 3936 dT : Gdouble; 3937 use type Ada.Calendar.Time; 3938 3939 begin 3940 if Canvas.Zoom_Start + Canvas.Zoom_Duration < Now then 3941 Zoom_Internal (Canvas, Canvas.Target_Zoom); 3942 return False; 3943 else 3944 dT := Gdouble (Now - Canvas.Zoom_Start); 3945 Z := Canvas.Initial_Zoom + 3946 (Canvas.Target_Zoom - Canvas.Initial_Zoom) * 3947 dT / Gdouble (Canvas.Zoom_Duration); 3948 Zoom_Internal (Canvas, Z); 3949 3950 return True; 3951 end if; 3952 end Zoom_Timeout; 3953 3954 ------------------- 3955 -- Zoom_Internal -- 3956 ------------------- 3957 3958 procedure Zoom_Internal 3959 (Canvas : access Interactive_Canvas_Record'Class; Percent : Gdouble) 3960 is 3961 begin 3962 -- Display the proper area in the canvas 3963 -- When zooming out, we want to keep the old area centered into the 3964 -- new one. 3965 -- When zooming in, we want to keep the same center as before 3966 -- (reverse of zoom out) 3967 3968 -- Apply the zoom 3969 Canvas.Zoom := Percent; 3970 Canvas.Freeze := True; 3971 -- Only update the page size, other values will be updated when 3972 -- centering the zoom area 3973 Update_Adjustments (Canvas); 3974 3975 -- Display the proper area in the canvas 3976 -- When zooming out, we want to keep the old area centered into the 3977 -- new one. 3978 -- When zooming in, we want to keep the same center as before 3979 -- (reverse of zoom out) 3980 Scroll_Canvas_To_Area 3981 (Canvas, 3982 Canvas.Zoom_X, Canvas.Zoom_Y, Canvas.Zoom_X, Canvas.Zoom_Y, 3983 Canvas_X => 0.5, Canvas_Y => 0.5); 3984 Canvas.Freeze := False; 3985 3986 Queue_Draw (Canvas); 3987 3988 Widget_Callback.Emit_By_Name (Canvas, "zoomed"); 3989 end Zoom_Internal; 3990 3991 ---------- 3992 -- Zoom -- 3993 ---------- 3994 3995 procedure Zoom 3996 (Canvas : access Interactive_Canvas_Record; 3997 Percent : Gdouble := 1.0; 3998 Length : Duration := 0.0) 3999 is 4000 Id : G_Source_Id; 4001 pragma Unreferenced (Id); 4002 begin 4003 if Canvas.Zoom = Percent then 4004 return; 4005 end if; 4006 Canvas.Target_Zoom := Percent; 4007 Canvas.Initial_Zoom := Canvas.Zoom; 4008 Canvas.Zoom_X := 4009 Canvas.World_X + 4010 Gdouble (Get_Allocated_Width (Canvas)) / Canvas.Zoom / 2.0; 4011 Canvas.Zoom_Y := 4012 Canvas.World_Y + 4013 Gdouble (Get_Allocated_Height (Canvas)) / Canvas.Zoom / 2.0; 4014 Canvas.Zoom_Start := Ada.Calendar.Clock; 4015 4016 -- Do we want smooth scrolling ? 4017 if Length > 0.0 then 4018 Canvas.Zoom_Duration := Length; 4019 4020 Id := Canvas_Timeout.Idle_Add 4021 (Zoom_Timeout'Access, Interactive_Canvas (Canvas)); 4022 4023 else 4024 Zoom_Internal (Canvas, Percent); 4025 end if; 4026 end Zoom; 4027 4028 -------------- 4029 -- Get_Zoom -- 4030 -------------- 4031 4032 function Get_Zoom 4033 (Canvas : access Interactive_Canvas_Record) return Glib.Gdouble is 4034 begin 4035 return Canvas.Zoom; 4036 end Get_Zoom; 4037 4038 -------------- 4039 -- Scrolled -- 4040 -------------- 4041 4042 procedure Scrolled (Canvas : access Gtk_Widget_Record'Class) is 4043 begin 4044 Queue_Draw (Canvas); 4045 end Scrolled; 4046 4047 ---------- 4048 -- Draw -- 4049 ---------- 4050 4051 procedure Draw 4052 (Item : access Buffered_Item_Record; 4053 Cr : Cairo.Cairo_Context) is 4054 begin 4055 Cairo.Set_Source_Surface (Cr, Item.Pixmap, 0.0, 0.0); 4056 Cairo.Rectangle 4057 (Cr, 0.0, 0.0, 4058 Gdouble (Item.Coord.Width), Gdouble (Item.Coord.Height)); 4059 Cairo.Fill (Cr); 4060 4061 if Status (Cr) /= Cairo_Status_Success then 4062 Put_Line ("??? Cannot draw buffered item: " & 4063 Cairo_Status'Image (Status (Cr))); 4064 end if; 4065 end Draw; 4066 4067 --------------------- 4068 -- Set_Screen_Size -- 4069 --------------------- 4070 4071 procedure Set_Screen_Size 4072 (Item : access Buffered_Item_Record; 4073 Width, Height : Glib.Gint) 4074 is 4075 begin 4076 if Item.Pixmap /= Null_Surface then 4077 Cairo.Surface.Destroy (Item.Pixmap); 4078 end if; 4079 4080 -- Always pass a drawable, so that the colormap for Item.Pixmap is 4081 -- set correctly. Otherwise, on setups where colormaps are used we 4082 -- get a crash 4083 Item.Pixmap := Create (Cairo_Format_ARGB32, Width, Height); 4084 4085 Set_Screen_Size (Canvas_Item_Record (Item.all)'Access, Width, Height); 4086 end Set_Screen_Size; 4087 4088 ------------- 4089 -- Destroy -- 4090 ------------- 4091 4092 procedure Destroy (Item : in out Buffered_Item_Record) is 4093 begin 4094 if Item.Pixmap /= Null_Surface then 4095 Destroy (Item.Pixmap); 4096 Item.Pixmap := Null_Surface; 4097 end if; 4098 4099 Destroy (Canvas_Item_Record (Item)); 4100 end Destroy; 4101 4102 ------------- 4103 -- Surface -- 4104 ------------- 4105 4106 function Surface (Item : access Buffered_Item_Record) 4107 return Cairo_Surface is 4108 begin 4109 return Item.Pixmap; 4110 end Surface; 4111 4112 -------------------- 4113 -- Get_Arrow_Type -- 4114 -------------------- 4115 4116 function Get_Arrow_Type 4117 (Link : access Canvas_Link_Record) return Arrow_Type is 4118 begin 4119 return Link.Arrow; 4120 end Get_Arrow_Type; 4121 4122 -------------------------- 4123 -- Set_Orthogonal_Links -- 4124 -------------------------- 4125 4126 procedure Set_Orthogonal_Links 4127 (Canvas : access Interactive_Canvas_Record; 4128 Orthogonal : Boolean) is 4129 begin 4130 Canvas.Orthogonal_Links := Orthogonal; 4131 end Set_Orthogonal_Links; 4132 4133 -------------------------- 4134 -- Get_Orthogonal_Links -- 4135 -------------------------- 4136 4137 function Get_Orthogonal_Links 4138 (Canvas : access Interactive_Canvas_Record) return Boolean is 4139 begin 4140 return Canvas.Orthogonal_Links; 4141 end Get_Orthogonal_Links; 4142 4143 ------------------------- 4144 -- Is_From_Auto_Layout -- 4145 ------------------------- 4146 4147 function Is_From_Auto_Layout 4148 (Item : access Canvas_Item_Record) return Boolean is 4149 begin 4150 return Item.From_Auto_Layout; 4151 end Is_From_Auto_Layout; 4152 4153 ----------------- 4154 -- Is_Selected -- 4155 ----------------- 4156 4157 function Is_Selected 4158 (Canvas : access Interactive_Canvas_Record; 4159 Item : access Canvas_Item_Record'Class) return Boolean 4160 is 4161 pragma Unreferenced (Canvas); 4162 begin 4163 return Item.Selected; 4164 end Is_Selected; 4165 4166 ------------ 4167 -- Canvas -- 4168 ------------ 4169 4170 function Canvas 4171 (Item : access Canvas_Item_Record) return Interactive_Canvas is 4172 begin 4173 return Item.Canvas; 4174 end Canvas; 4175 4176 -------------- 4177 -- Selected -- 4178 -------------- 4179 4180 procedure Selected 4181 (Item : access Canvas_Item_Record; 4182 Canvas : access Interactive_Canvas_Record'Class; 4183 Is_Selected : Boolean) 4184 is 4185 pragma Unreferenced (Item, Is_Selected); 4186 begin 4187 Queue_Draw (Canvas); 4188 end Selected; 4189 4190 ----------------- 4191 -- Get_Src_Pos -- 4192 ----------------- 4193 4194 procedure Get_Src_Pos 4195 (Link : access Canvas_Link_Record; X, Y : out Glib.Gfloat) is 4196 begin 4197 X := Link.Src_X_Pos; 4198 Y := Link.Src_Y_Pos; 4199 end Get_Src_Pos; 4200 4201 ------------------ 4202 -- Get_Dest_Pos -- 4203 ------------------ 4204 4205 procedure Get_Dest_Pos 4206 (Link : access Canvas_Link_Record; X, Y : out Glib.Gfloat) is 4207 begin 4208 X := Link.Dest_X_Pos; 4209 Y := Link.Dest_Y_Pos; 4210 end Get_Dest_Pos; 4211 4212 --------------------- 4213 -- Get_Arrow_Angle -- 4214 --------------------- 4215 4216 function Get_Arrow_Angle 4217 (Canvas : access Interactive_Canvas_Record'Class) return Gdouble is 4218 begin 4219 return Canvas.Arrow_Angle; 4220 end Get_Arrow_Angle; 4221 4222 ---------------------- 4223 -- Get_Arrow_Length -- 4224 ---------------------- 4225 4226 function Get_Arrow_Length 4227 (Canvas : access Interactive_Canvas_Record'Class) return Glib.Gint is 4228 begin 4229 return Canvas.Arrow_Length; 4230 end Get_Arrow_Length; 4231 4232end Gtkada.Canvas; 4233