1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200 | -- --
-- package Gtk.Layered Copyright (c) Dmitry A. Kazakov --
-- Interface Luebeck --
-- Autumn, 2010 --
-- --
-- Last revision : 13:15 14 Sep 2019 --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public License as --
-- published by the Free Software Foundation; either version 2 of --
-- the License, or (at your option) any later version. This library --
-- is distributed in the hope that it will be useful, but WITHOUT --
-- ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. You should have --
-- received a copy of the GNU General Public License along with --
-- this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this unit, or you link this unit with other files to produce an --
-- executable, this unit does not by itself cause the resulting --
-- executable to be covered by the GNU General Public License. This --
-- exception does not however invalidate any other reasons why the --
-- executable file might be covered by the GNU Public License. --
--____________________________________________________________________--
with Ada.Real_Time; use Ada.Real_Time;
with Ada.Streams; use Ada.Streams;
with Cairo; use Cairo;
with Cairo.Ellipses; use Cairo.Ellipses;
with Glib.Values; use Glib.Values;
with Gdk.Color; use Gdk.Color;
with Gdk.Rectangle; use Gdk.Rectangle;
with Gtk.Adjustment; use Gtk.Adjustment;
with Gtk.Drawing_Area; use Gtk.Drawing_Area;
with Gtk.Enums.String_Lists; use Gtk.Enums.String_Lists;
with Gtk.Widget; use Gtk.Widget;
with Pango.Cairo.Fonts; use Pango.Cairo.Fonts;
with System; use System;
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
with Gtk.Handlers;
package Gtk.Layered is
--
-- End_Parameters -- Parameters of a needle end
--
-- Length - The distance of the end to the center (can be negative)
-- Width - The width of the needle in the end
-- Cap - The style of the end
--
type End_Parameters is record
Length : GDouble;
Width : GDouble;
Cap : Cairo_Line_Cap;
end record;
--
-- Text_Transformation -- Alignment and transformation of texts
--
-- The text is transformed and aligned in accordance to a vector with
-- the coordinates X, Y and the angle Alpha:
--
-- (o) Moved_Inside moves the text to X, Y so that a curve with the
-- vector as its perpendicular would bound the text from outside.
-- (o) Moved_Centered moves the text to X, Y so that a curve with the
-- vector as its perpendicular would go through the text's center.
-- (o) Moved_Outside moves the text to X, Y so that a curve with the
-- vector as its perpendicular would bound the text from inside.
-- (o) Rotated moves the text's center to X, Y rotating the text so
-- that its vertical axis would be parallel to the vector.
-- (o) Skewed moves the text's center to X, Y skewing and rotating the
-- text so that its vertical axis would be perpendicular to the
-- vector and its horizontal axis would be parallel to some third
-- vector (e.g. the major axis of some ellipse). The height of the
-- text's parallelogram is kept equal to the original height of the
-- text.
--
type Text_Transformation is
( Moved_Inside,
Moved_Centered,
Moved_Outside,
Rotated,
Skewed
);
--
-- Interpolation_Mode -- Interpolation mode
--
-- Left - The value at the left point is used
-- Linear - The value is interpolated between two points
--
type Interpolation_Mode is (Left, Linear);
--
-- Line_Parameters -- Parameters of a line
--
-- Width - The line width
-- Color - The line color
-- Line_Cap - The way lines ends
--
type Line_Parameters is record
Width : GDouble;
Color : Gdk_Color;
Line_Cap : Cairo_Line_Cap;
end record;
--
-- Tick parameters -- Parameters of a gauge scale
--
-- Step - The angular step of the tick
-- First - The number of the first tick
-- Skipped - The number of the skipped tick
--
-- Ticks are drawn at angles incremented by Step. Ticks are numbered
-- from 1 to Skipped and again from 1 etc. The ticks with the number
-- equal to Skipped are not drawn.
--
subtype Tick_Number is Integer range 1..1_000_000;
type Tick_Parameters is record
Step : GDouble;
First : Tick_Number;
Skipped : Tick_Number;
end record;
--
-- Elliptic_Shape_Type -- Types of shapes bound by an elliptic arc
--
type Elliptic_Shape_Type is (Sector, Segment, Bagel);
--
-- Elliptic_Arc_Closure -- Parameters of an elliptic closure
--
type Elliptic_Arc_Closure
( Shape : Elliptic_Shape_Type := Sector
) is
record
case Shape is
when Sector => Center : Cairo_Tuple;
when Bagel => Arc : Ellipse_Parameters;
when Segment => null;
end case;
end record;
--
-- Fill_Opacity -- Opacity, when filling shapes
--
subtype Fill_Opacity is GDouble range 0.0..1.0;
--
-- Vertical alignment -- Alignment along the vertical axis
--
type Vertical_Alignment is (Top, Center, Bottom);
--
-- Waveform_Drawing_Method -- The method of the waveform
--
-- Resample_New_And_Stroke - The historic part of the waveform is
-- moved the new one is resampled and then
-- the waveform line is drawn using Stroke.
-- Resample_All_And_Stroke - The waveform is sampled new and then the
-- waveform line is drawn using Stroke.
--
type Waveform_Drawing_Method is
( Resample_New_And_Stroke,
Resample_All_And_Stroke
);
--
-- Layer_Object -- The layer object's interface
--
type Layer_Object is limited interface;
------------------------------------------------------------------------
-- Layer_Needle
--
type Gauge_Needle is limited interface;
--
-- Get_Adjustment -- The adjustment object used by the needle
--
-- Layer - The needle
--
-- Returns :
--
-- The adjustment object or else null
--
function Get_Adjustment (Layer : Gauge_Needle)
return Gtk_Adjustment is abstract;
--
-- Get_Value -- Get the value indicated by the needle
--
-- Layer - The needle
--
-- The value is in the range 0.0..1.0. The implementation must be
-- task-safe, callable on the context of a task different from the GTK
-- loop task.
--
-- Returns :
--
-- The value
--
function Get_Value (Layer : Gauge_Needle) return GDouble is abstract;
--
-- Set_Value -- Change the value indicated by the needle
--
-- Layer - The needle
-- Value - The value in the range 0.0..1.0
--
-- When the value is out of range it is saturated to the nearest bound.
-- The implementation must be task-safe, callable on the context of a
-- task different from the GTK loop task. Note that changing the value
-- has no immediate effect on the widget the needle's layer belongs. In
-- order to redraw it you should call Queue_Draw.
--
procedure Set_Value
( Layer : in out Gauge_Needle;
Value : GDouble
) is abstract;
------------------------------------------------------------------------
-- Layer_Location -- Where a layer can be placed
--
type Layer_Location is limited interface;
--
-- Add -- Place layer object under the location specified
--
-- Layer - The layer object
-- Under - The layer object location
--
procedure Add
( Layer : not null access Layer_Object;
Under : not null access Layer_Location'Class
) is abstract;
------------------------------------------------------------------------
-- Annotation_Layer -- Interface of the annotation layers
--
type Annotation_Layer is limited interface;
--
-- Get_Face -- Text font face
--
-- Layer - The annotation layer
--
-- Returns :
--
-- The font face
--
function Get_Face (Layer : Annotation_Layer)
return Pango_Cairo_Font is abstract;
--
-- Get_Height -- The text height
--
-- Layer - The annotation layer
--
-- Returns :
--
-- The text height
--
function Get_Height (Layer : Annotation_Layer)
return GDouble is abstract;
--
-- Get_Markup -- The annotation text markup
--
-- Layer - The annotation layer
-- Position - The text number 1..Get_Texts_Number
--
-- The texts are drawn at ticks in their postion order.
--
-- Returns :
--
-- True if the text uses pango markup
--
-- Exceptions :
--
-- Constraint_Error -- Position is greater than the texts number
--
function Get_Markup
( Layer : Annotation_Layer;
Position : Positive
) return Boolean is abstract;
--
-- Get_Stretch -- The text stretch
--
-- Layer - The label layer
--
-- The text stretch is how the text width should be scaled relatively to
-- its height. For example, 2.0 means twice as wide than normal.
--
-- Returns :
--
-- The text stretch
--
function Get_Stretch (Layer : Annotation_Layer)
return GDouble is abstract;
--
-- Get_Text -- The annotation text
--
-- Layer - The annotation layer
-- Position - The text number 1..Get_Texts_Number
--
-- The texts are drawn at ticks in their postion order.
--
-- Returns :
--
-- The text
--
-- Exceptions :
--
-- Constraint_Error -- Position is greater than the texts number
--
function Get_Text
( Layer : Annotation_Layer;
Position : Positive
) return UTF8_String is abstract;
--
-- Get_Texts_Number -- The number of texts
--
-- Layer - The annotation layer
--
-- Returns :
--
-- The number of texts the annotation draws
--
function Get_Texts_Number (Layer : Annotation_Layer)
return Natural is abstract;
--
-- Get_Ticks -- The ticks where texts are located
--
-- Layer - The annotation layer
--
-- Returns :
--
-- The ticks parameters
--
function Get_Ticks (Layer : Annotation_Layer)
return Tick_Parameters is abstract;
--
-- Set_Face -- Set font face
--
-- Layer - The annotation layer
-- Face - The text font
--
procedure Set_Face
( Layer : in out Annotation_Layer;
Face : Pango_Cairo_Font
) is abstract;
--
-- Set_Text -- Set an annotation text
--
-- Layer - The annotation layer
-- Position - The text number 1..Get_Texts_Number
-- Text - The new text
-- Markup - True if the text contains markup directives
--
-- The texts are drawn at ticks in their postion order.
--
-- Exceptions :
--
-- Constraint_Error -- Position is greater than the texts number + 1
--
procedure Set_Text
( Layer : in out Annotation_Layer;
Position : Positive;
Text : UTF8_String;
Markup : Boolean := False
) is abstract;
--
-- Set_Texts -- Set annotation texts
--
-- Layer - The annotation layer
-- Texts - The new texts
-- [ Delimiter ] - Text delimiter
-- Markup - True if the texts contain markup directives
--
-- The texts are drawn at ticks in their postion order. The texts can be
-- specified as a list, a controlled list (in the form "a"/"b"/"c"), or
-- as a single string separated by the Delimiter character.
--
procedure Set_Texts
( Layer : in out Annotation_Layer;
Texts : Gtk.Enums.String_List.GList;
Markup : Boolean := False
) is abstract;
procedure Set_Texts
( Layer : in out Annotation_Layer'Class;
Texts : Controlled_String_List;
Markup : Boolean := False
);
procedure Set_Texts
( Layer : in out Annotation_Layer;
Texts : UTF8_String;
Delimiter : Character := ' ';
Markup : Boolean := False
) is abstract;
------------------------------------------------------------------------
-- Scalable_Layer -- Interface of scalable layers
--
type Scalable_Layer is limited interface;
--
-- Get_Scaled -- The behavior when the parent widget is resized
--
-- Layer - The layer
--
-- Returns :
--
-- The scaling mode
--
function Get_Scaled (Layer : Scalable_Layer)
return Boolean is abstract;
--
-- Set_Scaled -- Change the behavior when the parent widget is resized
--
-- Layer - The layer
-- Scaled - Scaling mode
--
procedure Set_Scaled
( Layer : in out Scalable_Layer;
Scaled : Boolean
) is abstract;
------------------------------------------------------------------------
-- Widened_Layer -- Interface of the layers which lines are widened
--
type Widened_Layer is limited interface;
--
-- Get_Widened -- The behavior when the parent widget is resized
--
-- Layer - The layer
--
-- Returns :
--
-- The line scaling mode
--
function Get_Widened (Layer : Widened_Layer)
return Boolean is abstract;
--
-- Set_Widened -- Change the behavior when the parent widget is resized
--
-- Layer - The layer
-- Widened - Line widening mode
--
procedure Set_Widened
( Layer : in out Widened_Layer;
Widened : Boolean
) is abstract;
------------------------------------------------------------------------
-- Gtk_Layered_Record -- The graphical widget containing layers
--
-- Signals:
--
-- layer-added - emitted when the layer has been added. The first
-- parameter is the position of the layer.
-- layer-removed - emitted when the layer has been removed. The first
-- parameter is the position the removed layer had.
--
type Gtk_Layered_Record is
new Gtk_Widget_Record and Layer_Location with private;
type Gtk_Layered is access all Gtk_Layered_Record'Class;
--
-- Abstract_Layer
--
type Abstract_Layer is
abstract new Ada.Finalization.Limited_Controlled
and Layer_Object
and Layer_Location with private;
------------------------------------------------------------------------
-- Operations of layered widgets:
--
-- Erase -- Deletes all layers of the widget
--
-- Widget - The widget
--
procedure Erase (Widget : in out Gtk_Layered_Record);
--
-- Finalize -- Destruction is called upon destruction
--
-- Widget - The widget being destroyed
--
procedure Finalize (Widget : in out Gtk_Layered_Record) is null;
--
-- Get_Aspect_Ratio -- Get the widget aspect ratio
--
-- Widget - The widget
--
-- Returns :
--
-- Get the aspect ratio
--
function Get_Aspect_Ratio
( Widget : not null access constant Gtk_Layered_Record
) return GDouble;
--
-- Get_Bottom -- The bottom layer of the widget
--
-- Widget - The layered widget
--
-- Returns :
--
-- The most bottom layer or the widget itself when depth is 0
--
function Get_Bottom (Widget : not null access Gtk_Layered_Record)
return not null access Layer_Location'Class;
--
-- Get_Depth -- Get maximal depth of the widget
--
-- Widget - The layered widget
--
-- Returns :
--
-- Number of layers the widget presently has
--
function Get_Depth
( Widget : not null access constant Gtk_Layered_Record
) return Natural;
--
-- Get_Center -- The drawn widget center
--
-- Widget - The widget
--
-- Returns :
--
-- Current center of the widget when the layers are drawn
--
function Get_Center
( Widget : not null access constant Gtk_Layered_Record
) return Cairo_Tuple;
--
-- Get_Drawing_Time -- The topmost layer of the widget
--
-- Widget - The layered widget
--
-- This function returns the time of drawing. The widgets which state
-- depend on real time should use this value when draw their states.
--
-- Returns :
--
-- The time the state of layers being drawn must reflect
--
function Get_Drawing_Time
( Widget : not null access constant Gtk_Layered_Record
) return Time;
--
-- Get_Layer -- Get the layer by its number
--
-- Widget - The widget
-- Layer - The layer position 1..Get_Depth (Widget)
--
-- The deepest layer has the number 1. The topmost layer has the number
-- Get_Depth (Widget).
--
-- Returns :
--
-- The layer with the number Layer or null
--
function Get_Layer
( Widget : not null access Gtk_Layered_Record;
Layer : Positive
) return access Abstract_Layer'Class;
--
-- Get_Lower -- The bottom layer of the widget
--
-- Widget - The layered widget
--
-- Returns :
--
-- The bottom layer or null
--
function Get_Lower (Widget : not null access Gtk_Layered_Record)
return access Abstract_Layer'Class;
--
-- Get_Size -- The drawn widget size
--
-- Widget - The widget
--
-- Returns :
--
-- Current size of the widget when the layers are drawn
--
function Get_Size
( Widget : not null access constant Gtk_Layered_Record
) return GDouble;
--
-- Get_Type -- The type of the widget
--
-- Returns :
--
-- The GTK type of the widget
--
function Get_Type return GType;
--
-- Get_Upper -- The topmost layer of the widget
--
-- Widget - The layered widget
--
-- Returns :
--
-- The topmost layer or null
--
function Get_Upper (Widget : not null access Gtk_Layered_Record)
return access Abstract_Layer'Class;
--
-- Gtk_New -- Factory
--
-- Widget - The result
--
procedure Gtk_New (Widget : out Gtk_Layered);
--
-- Initialize -- Construction to be called once by any derived type
--
-- Widget - The widget to initialize
--
procedure Initialize
( Widget : not null access Gtk_Layered_Record'Class
);
--
-- Insert -- A layer at the specified depth
--
-- Widget - The widget
-- Layer - The layer to move
-- Position - The layer's new depth
--
-- This procedure moves or adds the layer to the depth To. If Position
-- is greater than Get_Depth (Widget) the layer is moved to the widget's
-- top.
--
procedure Insert
( Widget : not null access Gtk_Layered_Record'Class;
Layer : in out Abstract_Layer'Class;
Position : Positive
);
--
-- Refresh -- Refresh the widget contents
--
-- Widget - The widget
-- Context - Drawing context
--
-- This procedure should not be called directly. Use standard GTK+ means
-- instead, e.g. Queue_Draw.
--
procedure Refresh
( Widget : not null access Gtk_Layered_Record;
Context : Cairo_Context
);
--
-- Remove -- Layer by its number
--
-- Widget - The widget
-- Layer - The layer position 1..Get_Depth (Widget)
--
procedure Remove
( Widget : not null access Gtk_Layered_Record;
Layer : Positive
);
--
-- Resized -- Called upon widget size or position change
--
-- Widget - The widget
-- Allocation - The new widget position and size
--
procedure Resized
( Widget : not null access Gtk_Layered_Record;
Allocation : Gtk_Allocation
) is null;
--
-- Set_Aspect_Ratio -- Set the widget aspect ratio
--
-- Widget - The widget
-- Aspect_Ratio - The aspect ratio
--
-- The widget aspect ratio is the relation of the widget contents' width
-- to the height. The ratio influences the way the widget layers are
-- scaled with the widget (when marked as scaled). When the layer's Draw
-- is called the parameter Size determines the widget's size. This
-- parameter is computed from the actual widget's width and height and
-- the aspect ratio:
--
-- Size := Height when Width / Height >= Aspect_Ratio
-- Size := Width when Width / Height < Aspect_Ratio
--
-- The default aspect ratio is 1. This is a good choice for the contents
-- bounded by a circle.
--
-- Exceptions :
--
-- Constraint_Error - Illegal aspect ratio
--
procedure Set_Aspect_Ratio
( Widget : not null access Gtk_Layered_Record;
Aspect_Ratio : GDouble
);
--
-- Snapshot -- Transfer the contents of the widget onto a surface
--
-- Widget - The widget
-- Target - A handle to the surface / context
--
-- This procedure is used for taking snapshots of the widget. E.g. for
-- rendering its contents into a PDF file etc. Note that this is not
-- conventional drawing, for which see Queue_Draw.
--
procedure Snapshot
( Widget : not null access Gtk_Layered_Record;
Target : Cairo_Surface
);
procedure Snapshot
( Widget : not null access Gtk_Layered_Record;
Target : Cairo_Context
);
--
-- Style_Changed -- The widget style was set
--
-- Widget - The widget
--
procedure Style_Changed
( Widget : not null access Gtk_Layered_Record
) is null;
------------------------------------------------------------------------
-- Operations of abstract layers:
--
-- Above -- The layer above this one
--
-- Layer - The layer
--
-- Returns :
--
-- The layer above or null
--
function Above (Layer : Abstract_Layer)
return access Abstract_Layer'Class;
--
-- Atop -- The location atop of the layer
--
-- Layer - The layer
--
-- Returns :
--
-- The location atop layer
--
function Atop (Layer : Abstract_Layer)
return not null access Layer_Location'Class;
--
-- Add -- Add a new layer which parameters are read from a stream
--
-- Under - The layer or widget where to place the region under
-- Stream - The to read the parameters from
--
-- Returns :
--
-- The layer
--
-- Exceptions :
--
-- Constraint_Error - Wrong parameters
-- I/O errors
--
function Add
( Under : not null access Layer_Location'Class;
Stream : not null access Root_Stream_Type'Class
) return not null access Abstract_Layer is abstract;
--
-- Below -- The layer below this one
--
-- Layer - The layer
--
-- Returns :
--
-- The layer below or null
--
function Below (Layer : Abstract_Layer)
return access Abstract_Layer'Class;
--
-- Draw -- The layer
--
-- Layer - The layer to draw
-- Context - The drawing context
-- Area - The drawing area
--
-- The implementation need not to draw outside Area rectangle. After a
-- successful call to Draw, Is_Updated should return False. The layer,
-- when scalable should consider the widget's center in Get_Center and
-- its size of Get_Size.
--
procedure Draw
( Layer : in out Abstract_Layer;
Context : Cairo_Context;
Area : Gdk_Rectangle
) is abstract;
--
-- Finalize -- Destruction
--
-- Layer - The layer being finalized
--
-- When overridden the implementation must call this one from its body.
--
procedure Finalize (Layer : in out Abstract_Layer);
--
-- Find_Property -- Get number of layer properties
--
-- Layer - The layer
-- Name - The property name
-- Constraint - The expected property type
--
-- This function returns the number of the property of the specified
-- name. The result is 0 if the layer does not have this property. When
-- Constraint is not GType_Invalid the type of the property must match.
--
-- Returns :
--
-- The property number or 0 if no property found
--
function Find_Property
( Layer : Abstract_Layer'Class;
Name : String;
Constraint : GType := GType_Invalid
) return Natural;
--
-- Find_Property -- Get number of layer properties
--
-- Layer - The layer
-- Pattern - The expected property
--
-- This function returns the number of the property matching Pattern.
-- The property matches pattern if the nick name, type, minimum (when
-- applied), maximum (when applied) match.
--
-- Returns :
--
-- The property number or 0 if no property found
--
function Find_Property
( Layer : Abstract_Layer'Class;
Constraint : Param_Spec
) return Natural;
--
--
-- Get_Position -- Get the layer's position
--
-- Layer - The layer
--
-- Returns :
--
-- The layer's position or 0 if the layer is not of any widget
--
function Get_Position (Layer : Abstract_Layer) return Natural;
--
-- Get_Properties_Number -- Get number of layer properties
--
-- Layer - The layer
--
-- Layers are not GLib objects and thus do not have properties of their
-- own. But they support properties interface. The layer can be asked
-- for its "properties" and their values can be get and set thus
-- influencing the layer's parameters. This can be used by the layered
-- widget in different ways. The styles and properties of the widget may
-- map to the layer's "properties." An application can control layers of
-- a widget by setting the "properties" of the layers.
--
-- Returns :
--
-- The number of properties
--
function Get_Properties_Number (Layer : Abstract_Layer)
return Natural is abstract;
--
-- Get_Property_Specification -- Get specification of a property
--
-- Layer - The layer
-- Property - The property number
--
-- The result must be released by the caller using Unref.
--
-- Returns :
--
-- The property specification
--
-- Exceptions :
--
-- Constraint_Error - The property number is invalid
--
function Get_Property_Specification
( Layer : Abstract_Layer;
Property : Positive
) return Param_Spec is abstract;
--
-- Get_Property_Value -- Get the value of a property
--
-- Layer - The layer
-- Property - The property number
--
-- The result must be released by the caller using Unset.
--
-- Returns :
--
-- The property value
--
-- Exceptions :
--
-- Constraint_Error - The property number is invalid
--
function Get_Property_Value
( Layer : Abstract_Layer;
Property : Positive
) return GValue is abstract;
--
-- Get_Widget -- Get the layer's widget
--
-- Layer - The layer
--
-- Returns :
--
-- The layer's widget
--
function Get_Widget (Layer : Abstract_Layer)
return not null access Gtk_Layered_Record'Class;
--
-- Is_Caching -- Check if the layer is a caching layer
--
-- Layer - The layer
--
-- Returns :
--
-- True when the layer is caching
--
function Is_Caching (Layer : Abstract_Layer) return Boolean;
--
-- Is_Updated -- Update check
--
-- Layer - The layer
--
-- Returns :
--
-- True when the layer contents was changed
--
function Is_Updated (Layer : Abstract_Layer)
return Boolean is abstract;
--
-- Move -- The layer in XY-surface
--
-- Layer - The layer
-- Offset - To move by
--
-- The implementation moves all geometric shapes the layer draws from
-- the original position (x,y) to the position (x,y) + Offset. Note that
-- when the layer implements the interface Scalable_Layer, and
-- Get_Scaled returns true, then the effective Offset in cairo
-- coordinates will depend on the current widget's size (see Get_Size),
-- on which Offset is multiplied. Therefore to move the scalable layer
-- in cairo coordinates, Offset must be divided to the widget's size.
-- Note also that some layers, e.g. ones with border, influence Get_Size
-- of the layers above.
--
procedure Move
( Layer : in out Abstract_Layer;
Offset : Cairo_Tuple
) is abstract;
--
-- Prepare -- Called when the widget's layers are about to be drawn
--
-- Layer - The layer to draw
-- Context - The drawing context
-- Area - The drawing area
--
-- This procedure is called for all layers before drawing occurs. The
-- implementation shall not change the list of widget layers nor perform
-- drawing onto Context. The default implementation does nothing.
--
procedure Prepare
( Layer : in out Abstract_Layer;
Context : Cairo_Context;
Area : Gdk_Rectangle
) is null;
--
-- Property_Set -- Called when a property of the layer's widget is set
--
-- Layer - The layer
-- Param - The property parameter specification
--
-- The procedure is called when the layer calls Install_Property at
-- least once from inside the body of Register. The implementation
-- should check if the layer's appearance need to be changed because a
-- property of the layer's widget has been set.
--
procedure Property_Set
( Layer : in out Abstract_Layer;
Param : Param_Spec
) is null;
--
-- Resized -- Called when the layer's widget is resized
--
-- Layer - The layer
-- Area - The widget's rectangle
--
procedure Resized
( Layer : in out Abstract_Layer;
Area : Gdk_Rectangle
) is null;
--
-- Restore -- The layer from streamed properties
--
-- Stream - The stream to write the layer's properties into
-- Layer - The layer being restore
--
-- Exceptions :
--
-- Constraint_Error - Wrong parameters
-- I/O errors
--
procedure Restore
( Stream : in out Root_Stream_Type'Class;
Layer : in out Abstract_Layer
) is abstract;
--
-- Scale -- The layer in XY-surface
--
-- Layer - The layer
-- Factor - Magnification factor
--
-- The implementation magnifies all geometric shapes the layer draws by
-- Factor.
--
-- Exceptions :
--
-- Constraint_Error - Illegal factor
--
procedure Scale
( Layer : in out Abstract_Layer;
Factor : GDouble
) is abstract;
--
-- Set_Property_Value -- Set value of a property
--
-- Layer - The layer
-- Property - The property number
-- Value - The property value
--
-- Exceptions :
--
-- Constraint_Error - The property number is invalid
--
procedure Set_Property_Value
( Layer : in out Abstract_Layer;
Property : Positive;
Value : GValue
) is abstract;
--
-- Store -- Set cache from the context
--
-- Layer - A caching layer
-- Context - To read cache from
--
-- For the layers which return True from Is_Caching, this procedure is
-- called when all underlying layers are drawn. The layer should cache
-- the image drawn. Later when the widget need to be redrawn and the
-- underlying layers return False from their Is_Updated, they are
-- excluded from drawing and only the Draw of the caching layer is
-- called.
--
procedure Store
( Layer : in out Abstract_Layer;
Context : Cairo_Context
) is null;
--
-- Store -- The layer properties
--
-- Stream - The stream to write the layer's properties into
-- Layer - The layer
--
-- Exceptions :
--
-- I/O errors
--
procedure Store
( Stream : in out Root_Stream_Type'Class;
Layer : Abstract_Layer
) is abstract;
--
-- Style_Set -- Called when the style of the layer's widget is set
--
-- Layer - The layer
--
-- The procedure is called when the widget's style property is set. The
-- default implementation does nothing.
--
procedure Style_Set (Layer : in out Abstract_Layer) is null;
overriding
procedure Add
( Layer : not null access Abstract_Layer;
Under : not null access Layer_Location'Class
);
function Image (Location : Address) return String;
private
Min_Step : constant := 1.0E-9;
type Abstract_Layer_Ptr is access all Abstract_Layer'Class;
type Abstract_Layer is
abstract new Ada.Finalization.Limited_Controlled
and Layer_Object
and Layer_Location with
record
Prev, Next : Abstract_Layer_Ptr;
Widget : Gtk_Layered;
end record;
--
-- Remove -- Layer from the widget where it resides
--
-- Layer - The layer
--
-- Note, this does not destroy the object. Usually the widget need to be
-- redrawn and the layer object destroyed.
--
procedure Remove (Layer : in out Abstract_Layer);
--
-- Gtk_Layered_Record -- The widget implementation
--
type Gtk_Layered_Record is
new Gtk_Drawing_Area_Record and Layer_Location with
record
Bottom : Abstract_Layer_Ptr;
Depth : Natural := 0;
Aspect_Ratio : GDouble := 1.0;
Center : Cairo_Tuple := (0.0, 0.0);
Size : GDouble := 0.0;
Updated : Boolean := True;
Drawing : Boolean := False;
Drawing_Time : Time := Clock;
end record;
--
-- Destroy -- Handler of "destroy"
--
procedure Destroy
( Widget : access Gtk_Layered_Record'Class
);
--
-- Draw -- Handler of "draw"
--
function Draw
( Widget : access Gtk_Layered_Record'Class;
Context : Cairo.Cairo_Context
) return Boolean;
--
-- Emit -- Emit signal
--
procedure Emit
( Widget : not null access Gtk_Layered_Record'Class;
Signal : Signal_ID;
Value : GUInt
);
--
-- Notify -- The property set event's callback
--
procedure Notify
( Widget : access Gtk_Layered_Record'Class;
Params : GValues
);
--
-- Size_Allocate -- The size_allocate event's callback
--
procedure Size_Allocate
( Widget : access Gtk_Layered_Record'Class;
Allocation : Gtk_Allocation_Access
);
--
-- Style_Updated -- The style-updated event's callback
--
procedure Style_Updated
( Widget : access Gtk_Layered_Record'Class
);
--
-- Instantiations of the callback handlers
--
package Return_Boolean_Callback is
new Gtk.Handlers.Return_Callback
( Gtk_Layered_Record,
Boolean
);
package Widget_Callback is
new Gtk.Handlers.Callback (Gtk_Layered_Record);
package Allocation_Marshaller is
new Widget_Callback.Marshallers.Generic_Marshaller
( Gtk_Allocation_Access,
Get_Allocation
);
pragma Inline (Get_Center);
pragma Inline (Get_Size);
pragma Inline (Get_Widget);
function Get_First_Tick (First, Skipped : Tick_Number)
return Tick_Number;
procedure Free is
new Ada.Unchecked_Deallocation
( Abstract_Layer'Class,
Abstract_Layer_Ptr
);
---------------------------------------------------------------------
type Tracing_Flags is mod 2**2;
Trace_Amplifier : Tracing_Flags := 2**0;
Trace_Waveform : Tracing_Flags := 2**1;
Tracing_Mode : constant Tracing_Flags := 0;
Trace_File : constant String := "c:/temp/aicwl.txt";
procedure Trace (Data : System.Address; Text : String);
procedure Trace_Line (Data : System.Address; Text : String);
---------------------------------------------------------------------
end Gtk.Layered;
|