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;