Ada95/samples/ncurses2-attr_test.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                                 ncurses                                  --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright (c) 2000,2001,2004 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: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37 --  Version Control
  38 --  $Revision: 1.5 $
  39 --  $Date: 2004/08/21 21:37:00 $
  40 --  Binding Version 01.00
  41 ------------------------------------------------------------------------------
  42 with ncurses2.util; use ncurses2.util;
  43 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  44 with Terminal_Interface.Curses.Terminfo;
  45 use Terminal_Interface.Curses.Terminfo;
  46 with Ada.Characters.Handling;
  47 with Ada.Strings.Fixed;
  48
  49 procedure ncurses2.attr_test is
  50
  51    function  subset (super, sub : Character_Attribute_Set) return Boolean;
  52    function  intersect (b, a : Character_Attribute_Set) return Boolean;
  53    function  has_A_COLOR (attr : Attributed_Character) return Boolean;
  54    function  show_attr (row  : Line_Position;
  55                         skip : Natural;
  56                         attr : Character_Attribute_Set;
  57                         name : String;
  58                         once : Boolean) return Line_Position;
  59    procedure attr_getc (skip : out Integer;
  60                         fg, bg : in out Color_Number;
  61                         result : out Boolean);
  62
  63
  64    function subset (super, sub : Character_Attribute_Set) return Boolean is
  65    begin
  66       if
  67         (super.Stand_Out or not sub.Stand_Out) and
  68         (super.Under_Line or not sub.Under_Line) and
  69         (super.Reverse_Video or not sub.Reverse_Video) and
  70         (super.Blink or not sub.Blink) and
  71         (super.Dim_Character or not sub.Dim_Character) and
  72         (super.Bold_Character or not sub.Bold_Character) and
  73         (super.Alternate_Character_Set or not sub.Alternate_Character_Set) and
  74         (super.Invisible_Character or not sub.Invisible_Character) -- and
  75 --      (super.Protected_Character or not sub.Protected_Character) and
  76 --      (super.Horizontal or not sub.Horizontal) and
  77 --      (super.Left or not sub.Left) and
  78 --      (super.Low or not sub.Low) and
  79 --      (super.Right or not sub.Right) and
  80 --      (super.Top or not sub.Top) and
  81 --      (super.Vertical or not sub.Vertical)
  82       then
  83          return True;
  84       else
  85          return False;
  86       end if;
  87    end subset;
  88
  89
  90    function intersect (b, a : Character_Attribute_Set) return Boolean is
  91    begin
  92       if
  93         (a.Stand_Out and b.Stand_Out) or
  94         (a.Under_Line and b.Under_Line) or
  95         (a.Reverse_Video and b.Reverse_Video) or
  96         (a.Blink and b.Blink) or
  97         (a.Dim_Character and b.Dim_Character) or
  98         (a.Bold_Character and b.Bold_Character) or
  99         (a.Alternate_Character_Set and b.Alternate_Character_Set) or
 100         (a.Invisible_Character and b.Invisible_Character) -- or
 101 --      (a.Protected_Character and b.Protected_Character) or
 102 --      (a.Horizontal and b.Horizontal) or
 103 --      (a.Left and b.Left) or
 104 --      (a.Low and b.Low) or
 105 --      (a.Right and b.Right) or
 106 --      (a.Top and b.Top) or
 107 --      (a.Vertical and b.Vertical)
 108       then
 109          return True;
 110       else
 111          return False;
 112       end if;
 113    end intersect;
 114
 115    function has_A_COLOR (attr : Attributed_Character) return Boolean is
 116    begin
 117       if attr.Color /= Color_Pair (0) then
 118          return True;
 119       else
 120          return False;
 121       end if;
 122    end has_A_COLOR;
 123
 124    --  Print some text with attributes.
 125    function show_attr (row  : Line_Position;
 126                        skip : Natural;
 127                        attr : Character_Attribute_Set;
 128                        name : String;
 129                        once : Boolean) return Line_Position is
 130
 131       function make_record (n : Integer) return Character_Attribute_Set;
 132       function make_record (n : Integer) return Character_Attribute_Set is
 133          --  unsupported means true
 134          a : Character_Attribute_Set := (others => False);
 135          m : Integer;
 136          rest : Integer;
 137       begin
 138          --  ncv is a bitmap with these fields
 139          --              A_STANDOUT,
 140          --              A_UNDERLINE,
 141          --              A_REVERSE,
 142          --              A_BLINK,
 143          --              A_DIM,
 144          --              A_BOLD,
 145          --              A_INVIS,
 146          --              A_PROTECT,
 147          --              A_ALTCHARSET
 148          --  It means no_color_video,
 149          --  video attributes that can't be used with colors
 150          --  see man terminfo.5
 151          m := n mod 2;
 152          rest := n / 2;
 153          if 1 = m then
 154             a.Stand_Out := True;
 155          end if;
 156          m := rest mod 2;
 157          rest := rest / 2;
 158          if 1 = m then
 159             a.Under_Line := True;
 160          end if;
 161          m := rest mod 2;
 162          rest := rest / 2;
 163          if 1 = m then
 164             a.Reverse_Video := True;
 165          end if;
 166          m := rest mod 2;
 167          rest := rest / 2;
 168          if 1 = m then
 169             a.Blink := True;
 170          end if;
 171          m := rest mod 2;
 172          rest := rest / 2;
 173          if 1 = m then
 174             a.Bold_Character := True;
 175          end if;
 176          m := rest mod 2;
 177          rest := rest / 2;
 178          if 1 = m then
 179             a.Invisible_Character := True;
 180          end if;
 181          m := rest mod 2;
 182          rest := rest / 2;
 183 --       if 1 = m then
 184 --          a.Protected_Character := True;
 185 --       end if;
 186          m := rest mod 2;
 187          rest := rest / 2;
 188          if 1 = m then
 189             a.Alternate_Character_Set := True;
 190          end if;
 191
 192          return a;
 193       end make_record;
 194
 195       ncv : constant Integer := Get_Number ("ncv");
 196
 197    begin
 198       Move_Cursor (Line => row, Column => 8);
 199       Add (Str => name & " mode:");
 200       Move_Cursor (Line => row, Column => 24);
 201       Add (Ch => '|');
 202       if skip /= 0 then
 203          --  printw("%*s", skip, " ")
 204          Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
 205       end if;
 206       if once then
 207          Switch_Character_Attribute (Attr => attr);
 208       else
 209          Set_Character_Attributes (Attr => attr);
 210       end if;
 211       Add (Str => "abcde fghij klmno pqrst uvwxy z");
 212       if once then
 213          Switch_Character_Attribute (Attr => attr, On => False);
 214       end if;
 215       if skip /= 0 then
 216          Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
 217       end if;
 218       Add (Ch => '|');
 219       if attr /= Normal_Video then
 220          declare begin
 221             if not subset (super => Supported_Attributes, sub => attr) then
 222                Add (Str => " (N/A)");
 223             elsif ncv > 0 and has_A_COLOR (Get_Background) then
 224                declare
 225                   Color_Supported_Attributes :
 226                     constant Character_Attribute_Set := make_record (ncv);
 227                begin
 228                   if intersect (Color_Supported_Attributes, attr) then
 229                      Add (Str => " (NCV) ");
 230                   end if;
 231                end;
 232             end if;
 233          end;
 234       end if;
 235       return row + 2;
 236    end show_attr;
 237
 238    procedure attr_getc (skip : out Integer; fg, bg : in out Color_Number;
 239                                             result : out Boolean) is
 240       ch : constant Key_Code := Getchar;
 241       nc : constant Color_Number := Color_Number (Number_Of_Colors);
 242       curscr : Window;
 243       pragma Import (C, curscr, "curscr");
 244       --  curscr is not implemented in the Ada binding
 245    begin
 246       result := True;
 247       if Ada.Characters.Handling.Is_Digit (Character'Val (ch)) then
 248          skip := ctoi (Code_To_Char (ch));
 249       elsif ch = CTRL ('L') then
 250          Touch;
 251          Touch (curscr);
 252          Refresh;
 253       elsif Has_Colors then
 254          case ch is
 255             --  Note the mathematical elegance compared to the C version.
 256             when Character'Pos ('f') => fg := (fg + 1) mod nc;
 257             when Character'Pos ('F') => fg := (fg - 1) mod nc;
 258             when Character'Pos ('b') => bg := (bg + 1) mod nc;
 259             when Character'Pos ('B') => bg := (bg - 1) mod nc;
 260             when others =>
 261                result := False;
 262          end case;
 263       else
 264          result := False;
 265       end if;
 266    end attr_getc;
 267
 268
 269
 270    --      pairs could be defined as array ( Color_Number(0) .. colors - 1) of
 271    --      array (Color_Number(0).. colors - 1) of Boolean;
 272    pairs : array (Color_Pair'Range) of Boolean := (others => False);
 273    fg, bg : Color_Number := Black; -- = 0;
 274    xmc : constant Integer := Get_Number ("xmc");
 275    skip : Integer := xmc;
 276    n : Integer;
 277
 278    use Int_IO;
 279
 280 begin
 281    pairs (0) := True;
 282
 283    if skip < 0 then
 284       skip := 0;
 285    end if;
 286    n := skip;
 287
 288    loop
 289       declare
 290          row : Line_Position := 2;
 291          normal : Attributed_Character := Blank2;
 292          --  ???
 293       begin
 294          --  row := 2; -- weird, row is set to 0 without this.
 295          --  TODO delete the above line, it was a gdb quirk that confused me
 296          if Has_Colors then declare
 297             pair : constant Color_Pair :=
 298               Color_Pair (fg * Color_Number (Number_Of_Colors) + bg);
 299          begin
 300             --  Go though each color pair. Assume that the number of
 301             --  Redefinable_Color_Pairs is 8*8 with predefined Colors 0..7
 302             if not pairs (pair) then
 303                Init_Pair (pair, fg, bg);
 304                pairs (pair) := True;
 305             end if;
 306             normal.Color := pair;
 307          end;
 308          end if;
 309          Set_Background (Ch => normal);
 310          Erase;
 311
 312          Add (Line => 0, Column => 20,
 313               Str => "Character attribute test display");
 314
 315          row := show_attr (row, n, (Stand_Out => True, others => False),
 316                            "STANDOUT", True);
 317          row := show_attr (row, n, (Reverse_Video => True, others => False),
 318                            "REVERSE", True);
 319          row := show_attr (row, n, (Bold_Character => True, others => False),
 320                            "BOLD", True);
 321          row := show_attr (row, n, (Under_Line => True, others => False),
 322                            "UNDERLINE", True);
 323          row := show_attr (row, n, (Dim_Character => True, others => False),
 324                            "DIM", True);
 325          row := show_attr (row, n, (Blink => True, others => False),
 326                            "BLINK", True);
 327 --       row := show_attr (row, n, (Protected_Character => True,
 328 --                                  others => False), "PROTECT", True);
 329          row := show_attr (row, n, (Invisible_Character => True,
 330                                     others => False), "INVISIBLE", True);
 331          row := show_attr (row, n, Normal_Video, "NORMAL", False);
 332
 333          Move_Cursor (Line => row, Column => 8);
 334          if xmc > -1 then
 335             Add (Str => "This terminal does have the magic-cookie glitch");
 336          else
 337             Add (Str => "This terminal does not have the magic-cookie glitch");
 338          end if;
 339          Move_Cursor (Line => row + 1, Column => 8);
 340          Add (Str => "Enter a digit to set gaps on each side of " &
 341               "displayed attributes");
 342          Move_Cursor (Line => row + 2, Column => 8);
 343          Add (Str => "^L = repaint");
 344          if Has_Colors then
 345             declare tmp1 : String (1 .. 1);
 346             begin
 347                Add (Str => ".  f/F/b/F toggle colors (");
 348                Put (tmp1, Integer (fg));
 349                Add (Str => tmp1);
 350                Add (Ch => '/');
 351                Put (tmp1, Integer (bg));
 352                Add (Str => tmp1);
 353                Add (Ch => ')');
 354             end;
 355          end if;
 356          Refresh;
 357       end;
 358
 359       declare result : Boolean; begin
 360          attr_getc (n, fg, bg, result);
 361          exit when not result;
 362       end;
 363    end loop;
 364
 365    Set_Background (Ch => Blank2);
 366    Erase;
 367    End_Windows;
 368 end ncurses2.attr_test;