ncurses 4.2
[ncurses.git] / Ada95 / src / terminal_interface-curses-text_io.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                           GNAT ncurses Binding                           --
4 --                                                                          --
5 --                     Terminal_Interface.Curses.Text_IO                    --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998 Free Software Foundation, Inc.                        --
11 --                                                                          --
12 -- Permission is hereby granted, free of charge, to any person obtaining a  --
13 -- copy of this software and associated documentation files (the            --
14 -- "Software"), to deal in the Software without restriction, including      --
15 -- without limitation the rights to use, copy, modify, merge, publish,      --
16 -- distribute, distribute with modifications, sublicense, and/or sell       --
17 -- copies of the Software, and to permit persons to whom the Software is    --
18 -- furnished to do so, subject to the following conditions:                 --
19 --                                                                          --
20 -- The above copyright notice and this permission notice shall be included  --
21 -- in all copies or substantial portions of the Software.                   --
22 --                                                                          --
23 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
24 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
25 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
26 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
27 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
28 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
29 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
30 --                                                                          --
31 -- Except as contained in this notice, the name(s) of the above copyright   --
32 -- holders shall not be used in advertising or otherwise to promote the     --
33 -- sale, use or other dealings in this Software without prior written       --
34 -- authorization.                                                           --
35 ------------------------------------------------------------------------------
36 --  Author: Juergen Pfeifer <juergen.pfeifer@gmx.net> 1996
37 --  Version Control:
38 --  $Revision: 1.11 $
39 --  Binding Version 01.00
40 ------------------------------------------------------------------------------
41 package body Terminal_Interface.Curses.Text_IO is
42
43    Default_Window : Window := Null_Window;
44
45    procedure Set_Window (Win : in Window)
46    is
47    begin
48       Default_Window := Win;
49    end Set_Window;
50
51    function Get_Window return Window
52    is
53    begin
54       if Default_Window = Null_Window then
55          return Standard_Window;
56       else
57          return Default_Window;
58       end if;
59    end Get_Window;
60    pragma Inline (Get_Window);
61
62    procedure Flush (Win : in Window)
63    is
64    begin
65       Refresh (Win);
66    end Flush;
67
68    procedure Flush
69    is
70    begin
71       Flush (Get_Window);
72    end Flush;
73
74    --------------------------------------------
75    -- Specification of line and page lengths --
76    --------------------------------------------
77
78    --  There are no set routines in this package. I assume, that you allocate
79    --  the window with an appropriate size.
80    --  A scroll-window is interpreted as an page with unbounded page length,
81    --  i.e. it returns the conventional 0 as page length.
82
83    function Line_Length (Win : in Window) return Count
84    is
85       N_Lines : Line_Count;
86       N_Cols  : Column_Count;
87    begin
88       Get_Size (Win, N_Lines, N_Cols);
89       if Natural (N_Cols) > Natural (Count'Last) then
90          raise Layout_Error;
91       end if;
92       return Count (N_Cols);
93    end Line_Length;
94
95    function Line_Length return Count
96    is
97    begin
98       return Line_Length (Get_Window);
99    end Line_Length;
100
101    function Page_Length (Win : in Window) return Count
102    is
103       N_Lines : Line_Count;
104       N_Cols  : Column_Count;
105    begin
106       if Scrolling_Allowed (Win) then
107          return 0;
108       else
109          Get_Size (Win, N_Lines, N_Cols);
110          if Natural (N_Lines) > Natural (Count'Last) then
111             raise Layout_Error;
112          end if;
113          return Count (N_Lines);
114       end if;
115    end Page_Length;
116
117    function Page_Length return Count
118    is
119    begin
120       return Page_Length (Get_Window);
121    end Page_Length;
122
123    ------------------------------------
124    -- Column, Line, and Page Control --
125    ------------------------------------
126    procedure New_Line (Win : in Window; Spacing : in Positive_Count := 1)
127    is
128       P_Size : constant Count := Page_Length (Win);
129    begin
130       if Spacing not in Positive_Count then
131          raise Constraint_Error;
132       end if;
133
134       for I in 1 .. Spacing loop
135          if P_Size > 0 and then Line (Win) >= P_Size then
136             New_Page (Win);
137          else
138             Add (Win, Ascii.LF);
139          end if;
140       end loop;
141    end New_Line;
142
143    procedure New_Line (Spacing : in Positive_Count := 1)
144    is
145    begin
146       New_Line (Get_Window, Spacing);
147    end New_Line;
148
149    procedure New_Page (Win : in Window)
150    is
151    begin
152       Clear (Win);
153    end New_Page;
154
155    procedure New_Page
156    is
157    begin
158       New_Page (Get_Window);
159    end New_Page;
160
161    procedure Set_Col (Win : in Window;  To : in Positive_Count)
162    is
163       Y  : Line_Position;
164       X1 : Column_Position;
165       X2 : Column_Position;
166       N  : Natural;
167    begin
168       if To not in Positive_Count then
169          raise Constraint_Error;
170       end if;
171
172       Get_Cursor_Position (Win, Y, X1);
173       N  := Natural (To); N := N - 1;
174       X2 := Column_Position (N);
175       if X1 > X2 then
176          New_Line (Win, 1);
177          X1 := 0;
178       end if;
179       if X1 < X2 then
180          declare
181             Filler : constant String (Integer (X1) .. (Integer (X2) - 1))
182               := (others => ' ');
183          begin
184             Put (Win, Filler);
185          end;
186       end if;
187    end Set_Col;
188
189    procedure Set_Col (To : in Positive_Count)
190    is
191    begin
192       Set_Col (Get_Window, To);
193    end Set_Col;
194
195    procedure Set_Line (Win : in Window; To : in Positive_Count)
196    is
197       Y1 : Line_Position;
198       Y2 : Line_Position;
199       X  : Column_Position;
200       N  : Natural;
201    begin
202       if To not in Positive_Count then
203          raise Constraint_Error;
204       end if;
205
206       Get_Cursor_Position (Win, Y1, X);
207       N  := Natural (To); N := N - 1;
208       Y2 := Line_Position (N);
209       if Y2 < Y1 then
210          New_Page (Win);
211          Y1 := 0;
212       end if;
213       if Y1 < Y2 then
214          New_Line (Win, Positive_Count (Y2 - Y1));
215       end if;
216    end Set_Line;
217
218    procedure Set_Line (To : in Positive_Count)
219    is
220    begin
221       Set_Line (Get_Window, To);
222    end Set_Line;
223
224    function Col (Win : in Window) return Positive_Count
225    is
226       Y : Line_Position;
227       X : Column_Position;
228       N : Natural;
229    begin
230       Get_Cursor_Position (Win, Y, X);
231       N := Natural (X); N := N + 1;
232       if N > Natural (Count'Last) then
233          raise Layout_Error;
234       end if;
235       return Positive_Count (N);
236    end Col;
237
238    function Col return Positive_Count
239    is
240    begin
241       return Col (Get_Window);
242    end Col;
243
244    function Line (Win : in Window) return Positive_Count
245    is
246       Y : Line_Position;
247       X : Column_Position;
248       N : Natural;
249    begin
250       Get_Cursor_Position (Win, Y, X);
251       N := Natural (Y); N := N + 1;
252       if N > Natural (Count'Last) then
253          raise Layout_Error;
254       end if;
255       return Positive_Count (N);
256    end Line;
257
258    function Line return Positive_Count
259    is
260    begin
261       return Line (Get_Window);
262    end Line;
263
264    -----------------------
265    -- Characters Output --
266    -----------------------
267
268    procedure Put (Win  : in Window; Item : in Character)
269    is
270       P_Size : constant Count := Page_Length (Win);
271       Y : Line_Position;
272       X : Column_Position;
273       L : Line_Count;
274       C : Column_Count;
275    begin
276       if P_Size > 0 then
277          Get_Cursor_Position (Win, Y, X);
278          Get_Size (Win, L, C);
279          if (Y + 1) = L and then (X + 1) = C then
280             New_Page (Win);
281          end if;
282       end if;
283       Add (Win, Item);
284    end Put;
285
286    procedure Put (Item : in Character)
287    is
288    begin
289       Put (Get_Window, Item);
290    end Put;
291
292    --------------------
293    -- Strings-Output --
294    --------------------
295
296    procedure Put (Win  : in Window; Item : in String)
297    is
298       P_Size : constant Count := Page_Length (Win);
299       Y : Line_Position;
300       X : Column_Position;
301       L : Line_Count;
302       C : Column_Count;
303    begin
304       if P_Size > 0 then
305          Get_Cursor_Position (Win, Y, X);
306          Get_Size (Win, L, C);
307          if (Y + 1) = L and then (X + 1 + Item'Length) >= C then
308             New_Page (Win);
309          end if;
310       end if;
311       Add (Win, Item);
312    end Put;
313
314    procedure Put (Item : in String)
315    is
316    begin
317       Put (Get_Window, Item);
318    end Put;
319
320    procedure Put_Line
321      (Win  : in Window;
322       Item : in String)
323    is
324    begin
325       Put (Win, Item);
326       New_Line (Win, 1);
327    end Put_Line;
328
329    procedure Put_Line
330      (Item : in String)
331    is
332    begin
333       Put_Line (Get_Window, Item);
334    end Put_Line;
335
336 end Terminal_Interface.Curses.Text_IO;