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