diff options
Diffstat (limited to 'Ada95/samples/ncurses2-attr_test.adb')
| -rw-r--r-- | Ada95/samples/ncurses2-attr_test.adb | 362 |
1 files changed, 362 insertions, 0 deletions
diff --git a/Ada95/samples/ncurses2-attr_test.adb b/Ada95/samples/ncurses2-attr_test.adb new file mode 100644 index 000000000000..66271042c0bb --- /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; |