blob: 768cd0850ef9b40264bc6aaef974d09dc50998f3 (
plain)
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
|
-- Programmed by Jedidiah Barber
-- Released into the public domain
with
Ada.Strings.Fixed,
Ada.Strings.Unbounded,
Ada.Unchecked_Deallocation,
FLTK.Images.Pixmaps,
Interfaces.C.Strings;
package body FLTK.Pixmap_Marshal is
package SU renames Ada.Strings.Unbounded;
package Pix renames FLTK.Images.Pixmaps;
package C renames Interfaces.C;
package CS renames Interfaces.C.Strings;
function To_Coltype
(Value : in Pix.Color_Kind)
return Character is
begin
case Value is
when Pix.Colorful => return 'c';
when Pix.Monochrome => return 'm';
when Pix.Greyscale => return 'g';
when Pix.Symbolic => return 's';
end case;
end To_Coltype;
function Marshal_Data
(Values : in Pix.Header;
Colors : in Pix.Color_Definition_Array;
Pixels : in Pix.Pixmap_Data)
return chars_ptr_array_access
is
C_Data : chars_ptr_array_access := new CS.chars_ptr_array
(1 .. C.size_t (1 + Colors'Length + Pixels'Length (1)));
begin
-- Header values line
C_Data (1) := CS.New_String (Ada.Strings.Fixed.Trim
((Positive'Image (Values.Width) & Positive'Image (Values.Height) &
Positive'Image (Values.Colors) & Positive'Image (Values.Per_Pixel)),
Ada.Strings.Left));
-- Color definition lines
for Place in 1 .. Colors'Length loop
C_Data (C.size_t (Place + 1)) := CS.New_String
(SU.To_String (Colors (Colors'First + Place - 1).Name) & " " &
To_Coltype (Colors (Colors'First + Place - 1).Kind) & " " &
SU.To_String (Colors (Colors'First + Place - 1).Value));
end loop;
-- Pixel data lines
for Place in 1 .. Pixels'Length (1) loop
declare
Line : String (1 .. Pixels'Length (2));
for Line'Address use Pixels (Pixels'First (1) + Place - 1, 1)'Address;
pragma Import (Ada, Line);
begin
C_Data (C.size_t (Place + 1 + Colors'Length)) := CS.New_String (Line);
end;
end loop;
return C_Data;
end Marshal_Data;
procedure Free is new Ada.Unchecked_Deallocation
(Interfaces.C.Strings.chars_ptr_array, chars_ptr_array_access);
procedure Free_Recursive
(This : in out chars_ptr_array_access) is
begin
if This /= null then
for Item of This.all loop
CS.Free (Item);
end loop;
Free (This);
end if;
end Free_Recursive;
end FLTK.Pixmap_Marshal;
|
