ncurses 4.2
[ncurses.git] / Ada95 / ada_include / 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@T-Online.de> 1996
37 --  Version Control:
38 --  $Revision: 1.8 $
39 --  Binding Version 00.93
40 ------------------------------------------------------------------------------
41 with System;
42
43 package body Terminal_Interface.Curses.Text_IO is
44
45    Default_Window : Window := Null_Window;
46
47    procedure Set_Window (Win : in Window)
48    is
49    begin
50       Default_Window := Win;
51    end Set_Window;
52
53    function Get_Window return Window
54    is
55    begin
56       if Default_Window = Null_Window then
57          return Standard_Window;
58       else
59          return Default_Window;
60       end if;
61    end Get_Window;
62    pragma Inline (Get_Window);
63
64    procedure Flush (Win : in Window)
65    is
66    begin
67       Refresh (Win);
68    end Flush;
69
70    procedure Flush
71    is
72    begin
73       Flush (Get_Window);
74    end Flush;
75
76    --------------------------------------------
77    -- Specification of line and page lengths --
78    --------------------------------------------
79
80    --  There are no set routines in this package. I assume, that you allocate
81    --  the window with an appropriate size.
82    --  A scroll-window is interpreted as an page with unbounded page length,
83    --  i.e. it returns the conventional 0 as page length.
84
85    function Line_Length (Win : in Window) return Count
86    is
87       N_Lines : Line_Count;
88       N_Cols  : Column_Count;
89    begin
90       Get_Size (Win, N_Lines, N_Cols);
91       if Natural (N_Cols) > Natural (Count'Last) then
92          raise Layout_Error;
93       end if;
94       return Count (N_Cols);
95    end Line_Length;
96
97    function Line_Length return Count
98    is
99    begin
100       return Line_Length (Get_Window);
101    end Line_Length;
102
103    function Page_Length (Win : in Window) return Count
104    is
105       N_Lines : Line_Count;
106       N_Cols  : Column_Count;
107    begin
108       if Scrolling_Allowed (Win) then
109          return 0;
110       else
111          Get_Size (Win, N_Lines, N_Cols);
112          if Natural (N_Lines) > Natural (Count'Last) then
113             raise Layout_Error;
114          end if;
115          return Count (N_Lines);
116       end if;
117    end Page_Length;
118
119    function Page_Length return Count
120    is
121    begin
122       return Page_Length (Get_Window);
123    end Page_Length;
124
125    ------------------------------------
126    -- Column, Line, and Page Control --
127    ------------------------------------
128    procedure New_Line (Win : in Window; Spacing : in Positive_Count := 1)
129    is
130       P_Size : constant Count := Page_Length (Win);
131    begin
132       if Spacing not in Positive_Count then
133          raise Constraint_Error;
134       end if;
135
136       for I in 1 .. Spacing loop
137          if P_Size > 0 and then Line (Win) >= P_Size then
138             New_Page (Win);
139          else
140             Add (Win, Ascii.LF);
141          end if;
142       end loop;
143    end New_Line;
144
145    procedure New_Line (Spacing : in Positive_Count := 1)
146    is
147    begin
148       New_Line (Get_Window, Spacing);
149    end New_Line;
150
151    procedure New_Page (Win : in Window)
152    is
153    begin
154       Clear (Win);
155    end New_Page;
156
157    procedure New_Page
158    is
159    begin
160       New_Page (Get_Window);
161    end New_Page;
162
163    procedure Set_Col (Win : in Window;  To : in Positive_Count)
164    is
165       Y  : Line_Position;
166       X1 : Column_Position;
167       X2 : Column_Position;
168       N  : Natural;
169    begin
170       if To not in Positive_Count then
171          raise Constraint_Error;
172       end if;
173
174       Get_Cursor_Position (Win, Y, X1);
175       N  := Natural (To); N := N - 1;
176       X2 := Column_Position (N);
177       if X1 > X2 then
178          New_Line (Win, 1);
179          X1 := 0;
180       end if;
181       if X1 < X2 then
182          declare
183             Filler : constant String (Integer (X1) .. (Integer (X2) - 1))
184               := (others => ' ');
185          begin
186             Put (Win, Filler);
187          end;
188       end if;
189    end Set_Col;
190
191    procedure Set_Col (To : in Positive_Count)
192    is
193    begin
194       Set_Col (Get_Window, To);
195    end Set_Col;
196
197    procedure Set_Line (Win : in Window; To : in Positive_Count)
198    is
199       Y1 : Line_Position;
200       Y2 : Line_Position;
201       X  : Column_Position;
202       N  : Natural;
203    begin
204       if To not in Positive_Count then
205          raise Constraint_Error;
206       end if;
207
208       Get_Cursor_Position (Win, Y1, X);
209       N  := Natural (To); N := N - 1;
210       Y2 := Line_Position (N);
211       if Y2 < Y1 then
212          New_Page (Win);
213          Y1 := 0;
214       end if;
215       if Y1 < Y2 then
216          New_Line (Win, Positive_Count (Y2 - Y1));
217       end if;
218    end Set_Line;
219
220    procedure Set_Line (To : in Positive_Count)
221    is
222    begin
223       Set_Line (Get_Window, To);
224    end Set_Line;
225
226    function Col (Win : in Window) return Positive_Count
227    is
228       Y : Line_Position;
229       X : Column_Position;
230       N : Natural;
231    begin
232       Get_Cursor_Position (Win, Y, X);
233       N := Natural (X); N := N + 1;
234       if N > Natural (Count'Last) then
235          raise Layout_Error;
236       end if;
237       return Positive_Count (N);
238    end Col;
239
240    function Col return Positive_Count
241    is
242    begin
243       return Col (Get_Window);
244    end Col;
245
246    function Line (Win : in Window) return Positive_Count
247    is
248       Y : Line_Position;
249       X : Column_Position;
250       N : Natural;
251    begin
252       Get_Cursor_Position (Win, Y, X);
253       N := Natural (Y); N := N + 1;
254       if N > Natural (Count'Last) then
255          raise Layout_Error;
256       end if;
257       return Positive_Count (N);
258    end Line;
259
260    function Line return Positive_Count
261    is
262    begin
263       return Line (Get_Window);
264    end Line;
265
266    -----------------------
267    -- Characters Output --
268    -----------------------
269
270    procedure Put (Win  : in Window; Item : in Character)
271    is
272       P_Size : constant Count := Page_Length (Win);
273       Y : Line_Position;
274       X : Column_Position;
275       L : Line_Count;
276       C : Column_Count;
277    begin
278       if P_Size > 0 then
279          Get_Cursor_Position (Win, Y, X);
280          Get_Size (Win, L, C);
281          if (Y + 1) = L and then (X + 1) = C then
282             New_Page (Win);
283          end if;
284       end if;
285       Add (Win, Item);
286    end Put;
287
288    procedure Put (Item : in Character)
289    is
290    begin
291       Put (Get_Window, Item);
292    end Put;
293
294    --------------------
295    -- Strings-Output --
296    --------------------
297
298    procedure Put (Win  : in Window; Item : in String)
299    is
300       P_Size : constant Count := Page_Length (Win);
301       Y : Line_Position;
302       X : Column_Position;
303       L : Line_Count;
304       C : Column_Count;
305    begin
306       if P_Size > 0 then
307          Get_Cursor_Position (Win, Y, X);
308          Get_Size (Win, L, C);
309          if (Y + 1) = L and then (X + 1 + Item'Length) >= C then
310             New_Page (Win);
311          end if;
312       end if;
313       Add (Win, Item);
314    end Put;
315
316    procedure Put (Item : in String)
317    is
318    begin
319       Put (Get_Window, Item);
320    end Put;
321
322    procedure Put_Line
323      (Win  : in Window;
324       Item : in String)
325    is
326    begin
327       Put (Win, Item);
328       New_Line (Win, 1);
329    end Put_Line;
330
331    procedure Put_Line
332      (Item : in String)
333    is
334    begin
335       Put_Line (Get_Window, Item);
336    end Put_Line;
337
338 end Terminal_Interface.Curses.Text_IO;