------------------------------------------------------------------------------ -- -- -- 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 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;