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 | --------------------------------------------------------------------------------------------------------------------
-- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory.
--------------------------------------------------------------------------------------------------------------------
with Ada.Finalization;
with System.Address_To_Access_Conversions;
package body SDL.Video.Surfaces.Makers is
procedure Create (Self : in out Surface;
Size : in SDL.Sizes;
BPP : in Pixel_Depths;
Red_Mask : in Colour_Masks;
Blue_Mask : in Colour_Masks;
Green_Mask : in Colour_Masks;
Alpha_Mask : in Colour_Masks) is
function SDL_Create_RGB_Surface
(Flags : in Surface_Flags := 0; -- TODO: Is this the correct type?
Width : in C.int := 0;
Height : in C.int := 0;
Depth : in Pixel_Depths := 1;
Red_Mask : in Colour_Masks := 0;
Green_Mask : in Colour_Masks := 0;
Blue_Mask : in Colour_Masks := 0;
Alpha_Mask : in Colour_Masks := 0) return Internal_Surface_Pointer with
Import => True,
Convention => C,
External_Name => "SDL_CreateRGBSurface";
begin
Self.Internal := SDL_Create_RGB_Surface (Width => Size.Width,
Height => Size.Height,
Depth => BPP,
Red_Mask => Red_Mask,
Green_Mask => Green_Mask,
Blue_Mask => Blue_Mask,
Alpha_Mask => Alpha_Mask);
end Create;
procedure Create_From (Self : in out Surface;
Pixels : in Element_Pointer;
Size : in SDL.Sizes;
BPP : in Pixel_Depths := Element'Size;
Pitch : in System.Storage_Elements.Storage_Offset;
Red_Mask : in Colour_Masks;
Green_Mask : in Colour_Masks;
Blue_Mask : in Colour_Masks;
Alpha_Mask : in Colour_Masks) is
type Element_Pointer_C is access all Element with Convention => C;
function SDL_Create_RGB_Surface_From
(Pixels : in Element_Pointer_C;
Width : in C.int := 0;
Height : in C.int := 0;
Depth : in Pixel_Depths := 1;
Pitch : in C.int := 0;
Red_Mask : in Colour_Masks := 0;
Green_Mask : in Colour_Masks := 0;
Blue_Mask : in Colour_Masks := 0;
Alpha_Mask : in Colour_Masks := 0) return Internal_Surface_Pointer with
Import => True,
Convention => C,
External_Name => "SDL_CreateRGBSurfaceFrom";
begin
Self.Internal := SDL_Create_RGB_Surface_From (Pixels => Element_Pointer_C (Pixels),
Width => Size.Width,
Height => Size.Height,
Depth => BPP,
Pitch => C.int (Pitch),
Red_Mask => Red_Mask,
Green_Mask => Green_Mask,
Blue_Mask => Blue_Mask,
Alpha_Mask => Alpha_Mask);
end Create_From;
procedure Create_From_Array (Self : in out Surface;
Pixels : access Element_Array;
Red_Mask : in Colour_Masks;
Green_Mask : in Colour_Masks;
Blue_Mask : in Colour_Masks;
Alpha_Mask : in Colour_Masks) is
type Element_Pointer_C is access all Element with Convention => C;
package Convert is new System.Address_To_Access_Conversions (Element);
function SDL_Create_RGB_Surface_From
(Pixels : in Element_Pointer_C; -- Note: using System.Address here is not portable
Width : in C.int := 0;
Height : in C.int := 0;
Depth : in Pixel_Depths := 1;
Pitch : in C.int := 0;
Red_Mask : in Colour_Masks := 0;
Green_Mask : in Colour_Masks := 0;
Blue_Mask : in Colour_Masks := 0;
Alpha_Mask : in Colour_Masks := 0) return Internal_Surface_Pointer with
Import => True,
Convention => C,
External_Name => "SDL_CreateRGBSurfaceFrom";
use System.Storage_Elements;
Pitch : constant Storage_Offset := Pixels (Index'Succ (Pixels'First (1)), Pixels'First (2))'Address
- Pixels (Pixels'First (1), Pixels'First (2))'Address;
begin
Self.Internal := SDL_Create_RGB_Surface_From (
Pixels => Element_Pointer_C (Convert.To_Pointer (Pixels (Pixels'First (1), Pixels'First (2))'Address)),
Width => Pixels'Length (2),
Height => Pixels'Length (1),
Depth => Element'Size,
Pitch => C.int (Pitch),
Red_Mask => Red_Mask,
Green_Mask => Green_Mask,
Blue_Mask => Blue_Mask,
Alpha_Mask => Alpha_Mask);
end Create_From_Array;
-- TODO: SDL_CreateRGBSurfaceFrom
-- procedure Create (Self : in out Surface; File_Name : in String) is
-- -- This is actually a macro in the header.
-- function SDL_Load_BMP (File_Name : in C.char_array) return Internal_Surface_Pointer with
-- Import => True,
-- Convention => C,
-- External_Name => "SDL_LoadBMP";
-- begin
-- Self.Internal := SDL_Load_BMP (C.To_C (File_Name));
-- end Create;
function Get_Internal_Surface (Self : in Surface) return Internal_Surface_Pointer is
begin
return Self.Internal;
end Get_Internal_Surface;
function Make_Surface_From_Pointer (S : in Internal_Surface_Pointer; Owns : in Boolean := False) return Surface is
begin
return (Ada.Finalization.Controlled with Internal => S, Owns => Owns);
end Make_Surface_From_Pointer;
end SDL.Video.Surfaces.Makers;
|