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