Ada95/samples/ncurses2-attr_test.adb

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