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 | -- part of OpenGLAda, (c) 2017 Felix Krause
-- released under the terms of the MIT license, see the file "COPYING"
with Interfaces.C.Strings;
with Glfw.API;
package body Glfw.Monitors is
function Monitors return Monitor_List is
use type API.Address_List_Pointers.Pointer;
Count : aliased Interfaces.C.int;
Raw : constant API.Address_List_Pointers.Pointer :=
API.Get_Monitors (Count'Access);
begin
if Raw /= null then
declare
List : constant API.Address_List := API.Address_List_Pointers.Value
(Raw, Interfaces.C.ptrdiff_t (Count));
Ret : Monitor_List (List'Range);
begin
for I in List'Range loop
Ret (I).Handle := List (I);
end loop;
return Ret;
end;
else
raise Operation_Exception;
end if;
end Monitors;
function Primary_Monitor return Monitor is
use type System.Address;
Raw : constant System.Address := API.Get_Primary_Monitor;
begin
if Raw /= System.Null_Address then
return Monitor'(Handle => Raw);
else
raise Operation_Exception;
end if;
end Primary_Monitor;
procedure Get_Position (Object : Monitor; X, Y : out Integer) is
X_Raw, Y_Raw : Interfaces.C.int;
begin
API.Get_Monitor_Pos (Object.Handle, X_Raw, Y_Raw);
X := Integer (X_Raw);
Y := Integer (Y_Raw);
end Get_Position;
procedure Get_Physical_Size (Object : Monitor;
Width, Height : out Integer) is
Width_Raw, Height_Raw : Interfaces.C.int;
begin
API.Get_Monitor_Physical_Size (Object.Handle, Width_Raw, Height_Raw);
Width := Integer (Width_Raw);
Height := Integer (Height_Raw);
end Get_Physical_Size;
function Name (Object : Monitor) return String is
begin
return Interfaces.C.Strings.Value (API.Get_Monitor_Name (Object.Handle));
end Name;
function Video_Modes (Object : Monitor) return Video_Mode_List is
use type API.VMode_List_Pointers.Pointer;
Count : aliased Interfaces.C.int;
Raw : constant API.VMode_List_Pointers.Pointer
:= API.Get_Video_Modes (Object.Handle, Count'Access);
begin
if Raw /= null then
return API.VMode_List_Pointers.Value (Raw,
Interfaces.C.ptrdiff_t (Count));
else
raise Operation_Exception;
end if;
end Video_Modes;
function Current_Video_Mode (Object : Monitor) return Video_Mode is
begin
return API.Get_Video_Mode (Object.Handle).all;
end Current_Video_Mode;
procedure Set_Gamma (Object : Monitor; Gamma : Float) is
begin
API.Set_Gamma (Object.Handle, Interfaces.C.C_float (Gamma));
end Set_Gamma;
function Current_Gamma_Ramp (Object : Monitor) return Gamma_Ramp is
Raw : constant access constant API.Raw_Gamma_Ramp
:= API.Get_Gamma_Ramp (Object.Handle);
procedure UShort_To_Gamma_List (Source : API.Unsigned_Short_List;
Target : in out Gamma_Value_Array) is
begin
for I in Source'Range loop
Target (I) := Source (I);
end loop;
end UShort_To_Gamma_List;
begin
return Ret : Gamma_Ramp (Integer (Raw.Size)) do
UShort_To_Gamma_List (API.Unsigned_Short_List_Pointers.Value
(Raw.Red, Interfaces.C.ptrdiff_t (Raw.Size)),
Ret.Red);
UShort_To_Gamma_List (API.Unsigned_Short_List_Pointers.Value
(Raw.Green, Interfaces.C.ptrdiff_t (Raw.Size)),
Ret.Green);
UShort_To_Gamma_List (API.Unsigned_Short_List_Pointers.Value
(Raw.Blue, Interfaces.C.ptrdiff_t (Raw.Size)),
Ret.Blue);
end return;
end Current_Gamma_Ramp;
procedure Set_Gamma_Ramp (Object : Monitor; Value : Gamma_Ramp) is
Raw : aliased API.Raw_Gamma_Ramp;
begin
Raw.Size := Interfaces.C.unsigned (Value.Size);
Raw.Red := Value.Red (1)'Unrestricted_Access;
Raw.Green := Value.Green (1)'Unrestricted_Access;
Raw.Blue := Value.Blue (1)'Unrestricted_Access;
API.Set_Gamma_Ramp (Object.Handle, Raw'Access);
end Set_Gamma_Ramp;
function Raw_Pointer (Object : Monitor) return System.Address is
begin
return Object.Handle;
end Raw_Pointer;
end Glfw.Monitors;
|