1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding -- 4-- -- 5-- Terminal_Interface.Curses.Text_IO -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 2020 Thomas E. Dickey -- 11-- Copyright 1999-2011,2014 Free Software Foundation, Inc. -- 12-- -- 13-- Permission is hereby granted, free of charge, to any person obtaining a -- 14-- copy of this software and associated documentation files (the -- 15-- "Software"), to deal in the Software without restriction, including -- 16-- without limitation the rights to use, copy, modify, merge, publish, -- 17-- distribute, distribute with modifications, sublicense, and/or sell -- 18-- copies of the Software, and to permit persons to whom the Software is -- 19-- furnished to do so, subject to the following conditions: -- 20-- -- 21-- The above copyright notice and this permission notice shall be included -- 22-- in all copies or substantial portions of the Software. -- 23-- -- 24-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- 25-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- 26-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- 27-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- 28-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- 29-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- 30-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- 31-- -- 32-- Except as contained in this notice, the name(s) of the above copyright -- 33-- holders shall not be used in advertising or otherwise to promote the -- 34-- sale, use or other dealings in this Software without prior written -- 35-- authorization. -- 36------------------------------------------------------------------------------ 37-- Author: Juergen Pfeifer, 1996 38-- Version Control: 39-- $Revision: 1.23 $ 40-- $Date: 2020/02/02 23:34:34 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43package body Terminal_Interface.Curses.Text_IO is 44 45 Default_Window : Window := Null_Window; 46 47 procedure Set_Window (Win : 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 : 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 : 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 : 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 : Window; Spacing : Positive_Count := 1) 129 is 130 P_Size : constant Count := Page_Length (Win); 131 begin 132 if not Spacing'Valid 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 : Positive_Count := 1) 146 is 147 begin 148 New_Line (Get_Window, Spacing); 149 end New_Line; 150 151 procedure New_Page (Win : 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 : Window; To : Positive_Count) 164 is 165 Y : Line_Position; 166 X1 : Column_Position; 167 X2 : Column_Position; 168 N : Natural; 169 begin 170 if not To'Valid 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 : Positive_Count) 192 is 193 begin 194 Set_Col (Get_Window, To); 195 end Set_Col; 196 197 procedure Set_Line (Win : Window; To : Positive_Count) 198 is 199 Y1 : Line_Position; 200 Y2 : Line_Position; 201 X : Column_Position; 202 N : Natural; 203 begin 204 if not To'Valid then 205 raise Constraint_Error; 206 end if; 207 208 Get_Cursor_Position (Win, Y1, X); 209 pragma Warnings (Off, X); -- unreferenced 210 N := Natural (To); N := N - 1; 211 Y2 := Line_Position (N); 212 if Y2 < Y1 then 213 New_Page (Win); 214 Y1 := 0; 215 end if; 216 if Y1 < Y2 then 217 New_Line (Win, Positive_Count (Y2 - Y1)); 218 end if; 219 end Set_Line; 220 221 procedure Set_Line (To : Positive_Count) 222 is 223 begin 224 Set_Line (Get_Window, To); 225 end Set_Line; 226 227 function Col (Win : Window) return Positive_Count 228 is 229 Y : Line_Position; 230 X : Column_Position; 231 N : Natural; 232 begin 233 Get_Cursor_Position (Win, Y, X); 234 N := Natural (X); N := N + 1; 235 -- if N > Natural (Count'Last) then 236 -- raise Layout_Error; 237 -- end if; 238 return Positive_Count (N); 239 end Col; 240 241 function Col return Positive_Count 242 is 243 begin 244 return Col (Get_Window); 245 end Col; 246 247 function Line (Win : Window) return Positive_Count 248 is 249 Y : Line_Position; 250 X : Column_Position; 251 N : Natural; 252 begin 253 Get_Cursor_Position (Win, Y, X); 254 N := Natural (Y); N := N + 1; 255 -- if N > Natural (Count'Last) then 256 -- raise Layout_Error; 257 -- end if; 258 return Positive_Count (N); 259 end Line; 260 261 function Line return Positive_Count 262 is 263 begin 264 return Line (Get_Window); 265 end Line; 266 267 ----------------------- 268 -- Characters Output -- 269 ----------------------- 270 271 procedure Put (Win : Window; Item : Character) 272 is 273 P_Size : constant Count := Page_Length (Win); 274 Y : Line_Position; 275 X : Column_Position; 276 L : Line_Count; 277 C : Column_Count; 278 begin 279 if P_Size > 0 then 280 Get_Cursor_Position (Win, Y, X); 281 Get_Size (Win, L, C); 282 if (Y + 1) = L and then (X + 1) = C then 283 New_Page (Win); 284 end if; 285 end if; 286 Add (Win, Item); 287 end Put; 288 289 procedure Put (Item : Character) 290 is 291 begin 292 Put (Get_Window, Item); 293 end Put; 294 295 -------------------- 296 -- Strings-Output -- 297 -------------------- 298 299 procedure Put (Win : Window; Item : String) 300 is 301 P_Size : constant Count := Page_Length (Win); 302 Y : Line_Position; 303 X : Column_Position; 304 L : Line_Count; 305 C : Column_Count; 306 begin 307 if P_Size > 0 then 308 Get_Cursor_Position (Win, Y, X); 309 Get_Size (Win, L, C); 310 if (Y + 1) = L and then (X + 1 + Item'Length) >= C then 311 New_Page (Win); 312 end if; 313 end if; 314 Add (Win, Item); 315 end Put; 316 317 procedure Put (Item : String) 318 is 319 begin 320 Put (Get_Window, Item); 321 end Put; 322 323 procedure Put_Line 324 (Win : Window; 325 Item : String) 326 is 327 begin 328 Put (Win, Item); 329 New_Line (Win, 1); 330 end Put_Line; 331 332 procedure Put_Line 333 (Item : String) 334 is 335 begin 336 Put_Line (Get_Window, Item); 337 end Put_Line; 338 339end Terminal_Interface.Curses.Text_IO; 340