Base version of ncurses-5.7 library
diff --git a/Ada95/samples/ncurses2-attr_test.adb b/Ada95/samples/ncurses2-attr_test.adb
new file mode 100644
index 0000000..6627104
--- /dev/null
+++ b/Ada95/samples/ncurses2-attr_test.adb
@@ -0,0 +1,362 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding Samples --
+-- --
+-- ncurses --
+-- --
+-- B O D Y --
+-- --
+------------------------------------------------------------------------------
+-- Copyright (c) 2000-2007,2008 Free Software Foundation, Inc. --
+-- --
+-- Permission is hereby granted, free of charge, to any person obtaining a --
+-- copy of this software and associated documentation files (the --
+-- "Software"), to deal in the Software without restriction, including --
+-- without limitation the rights to use, copy, modify, merge, publish, --
+-- distribute, distribute with modifications, sublicense, and/or sell --
+-- copies of the Software, and to permit persons to whom the Software is --
+-- furnished to do so, subject to the following conditions: --
+-- --
+-- The above copyright notice and this permission notice shall be included --
+-- in all copies or substantial portions of the Software. --
+-- --
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
+-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
+-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
+-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
+-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
+-- --
+-- Except as contained in this notice, the name(s) of the above copyright --
+-- holders shall not be used in advertising or otherwise to promote the --
+-- sale, use or other dealings in this Software without prior written --
+-- authorization. --
+------------------------------------------------------------------------------
+-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
+-- Version Control
+-- $Revision: 1.9 $
+-- $Date: 2008/07/26 18:47:26 $
+-- Binding Version 01.00
+------------------------------------------------------------------------------
+with ncurses2.util; use ncurses2.util;
+with Terminal_Interface.Curses; use Terminal_Interface.Curses;
+with Terminal_Interface.Curses.Terminfo;
+use Terminal_Interface.Curses.Terminfo;
+with Ada.Characters.Handling;
+with Ada.Strings.Fixed;
+
+procedure ncurses2.attr_test is
+
+ function subset (super, sub : Character_Attribute_Set) return Boolean;
+ function intersect (b, a : Character_Attribute_Set) return Boolean;
+ function has_A_COLOR (attr : Attributed_Character) return Boolean;
+ function show_attr (row : Line_Position;
+ skip : Natural;
+ attr : Character_Attribute_Set;
+ name : String;
+ once : Boolean) return Line_Position;
+ procedure attr_getc (skip : in out Integer;
+ fg, bg : in out Color_Number;
+ result : out Boolean);
+
+ function subset (super, sub : Character_Attribute_Set) return Boolean is
+ begin
+ if
+ (super.Stand_Out or not sub.Stand_Out) and
+ (super.Under_Line or not sub.Under_Line) and
+ (super.Reverse_Video or not sub.Reverse_Video) and
+ (super.Blink or not sub.Blink) and
+ (super.Dim_Character or not sub.Dim_Character) and
+ (super.Bold_Character or not sub.Bold_Character) and
+ (super.Alternate_Character_Set or not sub.Alternate_Character_Set) and
+ (super.Invisible_Character or not sub.Invisible_Character) -- and
+-- (super.Protected_Character or not sub.Protected_Character) and
+-- (super.Horizontal or not sub.Horizontal) and
+-- (super.Left or not sub.Left) and
+-- (super.Low or not sub.Low) and
+-- (super.Right or not sub.Right) and
+-- (super.Top or not sub.Top) and
+-- (super.Vertical or not sub.Vertical)
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end subset;
+
+ function intersect (b, a : Character_Attribute_Set) return Boolean is
+ begin
+ if
+ (a.Stand_Out and b.Stand_Out) or
+ (a.Under_Line and b.Under_Line) or
+ (a.Reverse_Video and b.Reverse_Video) or
+ (a.Blink and b.Blink) or
+ (a.Dim_Character and b.Dim_Character) or
+ (a.Bold_Character and b.Bold_Character) or
+ (a.Alternate_Character_Set and b.Alternate_Character_Set) or
+ (a.Invisible_Character and b.Invisible_Character) -- or
+-- (a.Protected_Character and b.Protected_Character) or
+-- (a.Horizontal and b.Horizontal) or
+-- (a.Left and b.Left) or
+-- (a.Low and b.Low) or
+-- (a.Right and b.Right) or
+-- (a.Top and b.Top) or
+-- (a.Vertical and b.Vertical)
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end intersect;
+
+ function has_A_COLOR (attr : Attributed_Character) return Boolean is
+ begin
+ if attr.Color /= Color_Pair (0) then
+ return True;
+ else
+ return False;
+ end if;
+ end has_A_COLOR;
+
+ -- Print some text with attributes.
+ function show_attr (row : Line_Position;
+ skip : Natural;
+ attr : Character_Attribute_Set;
+ name : String;
+ once : Boolean) return Line_Position is
+
+ function make_record (n : Integer) return Character_Attribute_Set;
+ function make_record (n : Integer) return Character_Attribute_Set is
+ -- unsupported means true
+ a : Character_Attribute_Set := (others => False);
+ m : Integer;
+ rest : Integer;
+ begin
+ -- ncv is a bitmap with these fields
+ -- A_STANDOUT,
+ -- A_UNDERLINE,
+ -- A_REVERSE,
+ -- A_BLINK,
+ -- A_DIM,
+ -- A_BOLD,
+ -- A_INVIS,
+ -- A_PROTECT,
+ -- A_ALTCHARSET
+ -- It means no_color_video,
+ -- video attributes that can't be used with colors
+ -- see man terminfo.5
+ m := n mod 2;
+ rest := n / 2;
+ if 1 = m then
+ a.Stand_Out := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Under_Line := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Reverse_Video := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Blink := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Bold_Character := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Invisible_Character := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Protected_Character := True;
+ end if;
+ m := rest mod 2;
+ rest := rest / 2;
+ if 1 = m then
+ a.Alternate_Character_Set := True;
+ end if;
+
+ return a;
+ end make_record;
+
+ ncv : constant Integer := Get_Number ("ncv");
+
+ begin
+ Move_Cursor (Line => row, Column => 8);
+ Add (Str => name & " mode:");
+ Move_Cursor (Line => row, Column => 24);
+ Add (Ch => '|');
+ if skip /= 0 then
+ -- printw("%*s", skip, " ")
+ Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
+ end if;
+ if once then
+ Switch_Character_Attribute (Attr => attr);
+ else
+ Set_Character_Attributes (Attr => attr);
+ end if;
+ Add (Str => "abcde fghij klmno pqrst uvwxy z");
+ if once then
+ Switch_Character_Attribute (Attr => attr, On => False);
+ end if;
+ if skip /= 0 then
+ Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
+ end if;
+ Add (Ch => '|');
+ if attr /= Normal_Video then
+ declare begin
+ if not subset (super => Supported_Attributes, sub => attr) then
+ Add (Str => " (N/A)");
+ elsif ncv > 0 and has_A_COLOR (Get_Background) then
+ declare
+ Color_Supported_Attributes :
+ constant Character_Attribute_Set := make_record (ncv);
+ begin
+ if intersect (Color_Supported_Attributes, attr) then
+ Add (Str => " (NCV) ");
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ return row + 2;
+ end show_attr;
+
+ procedure attr_getc (skip : in out Integer;
+ fg, bg : in out Color_Number;
+ result : out Boolean) is
+ ch : constant Key_Code := Getchar;
+ nc : constant Color_Number := Color_Number (Number_Of_Colors);
+ begin
+ result := True;
+ if Ada.Characters.Handling.Is_Digit (Character'Val (ch)) then
+ skip := ctoi (Code_To_Char (ch));
+ elsif ch = CTRL ('L') then
+ Touch;
+ Touch (Current_Window);
+ Refresh;
+ elsif Has_Colors then
+ case ch is
+ -- Note the mathematical elegance compared to the C version.
+ when Character'Pos ('f') => fg := (fg + 1) mod nc;
+ when Character'Pos ('F') => fg := (fg - 1) mod nc;
+ when Character'Pos ('b') => bg := (bg + 1) mod nc;
+ when Character'Pos ('B') => bg := (bg - 1) mod nc;
+ when others =>
+ result := False;
+ end case;
+ else
+ result := False;
+ end if;
+ end attr_getc;
+
+ -- pairs could be defined as array ( Color_Number(0) .. colors - 1) of
+ -- array (Color_Number(0).. colors - 1) of Boolean;
+ pairs : array (Color_Pair'Range) of Boolean := (others => False);
+ fg, bg : Color_Number := Black; -- = 0;
+ xmc : constant Integer := Get_Number ("xmc");
+ skip : Integer := xmc;
+ n : Integer;
+
+ use Int_IO;
+
+begin
+ pairs (0) := True;
+
+ if skip < 0 then
+ skip := 0;
+ end if;
+ n := skip;
+
+ loop
+ declare
+ row : Line_Position := 2;
+ normal : Attributed_Character := Blank2;
+ -- ???
+ begin
+ -- row := 2; -- weird, row is set to 0 without this.
+ -- TODO delete the above line, it was a gdb quirk that confused me
+ if Has_Colors then
+ declare pair : constant Color_Pair :=
+ Color_Pair (fg * Color_Number (Number_Of_Colors) + bg);
+ begin
+ -- Go though each color pair. Assume that the number of
+ -- Redefinable_Color_Pairs is 8*8 with predefined Colors 0..7
+ if not pairs (pair) then
+ Init_Pair (pair, fg, bg);
+ pairs (pair) := True;
+ end if;
+ normal.Color := pair;
+ end;
+ end if;
+ Set_Background (Ch => normal);
+ Erase;
+
+ Add (Line => 0, Column => 20,
+ Str => "Character attribute test display");
+
+ row := show_attr (row, n, (Stand_Out => True, others => False),
+ "STANDOUT", True);
+ row := show_attr (row, n, (Reverse_Video => True, others => False),
+ "REVERSE", True);
+ row := show_attr (row, n, (Bold_Character => True, others => False),
+ "BOLD", True);
+ row := show_attr (row, n, (Under_Line => True, others => False),
+ "UNDERLINE", True);
+ row := show_attr (row, n, (Dim_Character => True, others => False),
+ "DIM", True);
+ row := show_attr (row, n, (Blink => True, others => False),
+ "BLINK", True);
+-- row := show_attr (row, n, (Protected_Character => True,
+-- others => False), "PROTECT", True);
+ row := show_attr (row, n, (Invisible_Character => True,
+ others => False), "INVISIBLE", True);
+ row := show_attr (row, n, Normal_Video, "NORMAL", False);
+
+ Move_Cursor (Line => row, Column => 8);
+ if xmc > -1 then
+ Add (Str => "This terminal does have the magic-cookie glitch");
+ else
+ Add (Str => "This terminal does not have the magic-cookie glitch");
+ end if;
+ Move_Cursor (Line => row + 1, Column => 8);
+ Add (Str => "Enter a digit to set gaps on each side of " &
+ "displayed attributes");
+ Move_Cursor (Line => row + 2, Column => 8);
+ Add (Str => "^L = repaint");
+ if Has_Colors then
+ declare tmp1 : String (1 .. 1);
+ begin
+ Add (Str => ". f/F/b/F toggle colors (");
+ Put (tmp1, Integer (fg));
+ Add (Str => tmp1);
+ Add (Ch => '/');
+ Put (tmp1, Integer (bg));
+ Add (Str => tmp1);
+ Add (Ch => ')');
+ end;
+ end if;
+ Refresh;
+ end;
+
+ declare result : Boolean; begin
+ attr_getc (n, fg, bg, result);
+ exit when not result;
+ end;
+ end loop;
+
+ Set_Background (Ch => Blank2);
+ Erase;
+ End_Windows;
+end ncurses2.attr_test;