Ada95/samples/ncurses2-acs_display.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                                 ncurses                                  --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright 2020 Thomas E. Dickey                                          --
  11 -- Copyright 2000-2006,2008 Free Software Foundation, Inc.                  --
  12 --                                                                          --
  13 -- Permission is hereby granted, free of charge, to any person obtaining a  --
  14 -- copy of this software and associated documentation files (the            --
  15 -- "Software"), to deal in the Software without restriction, including      --
  16 -- without limitation the rights to use, copy, modify, merge, publish,      --
  17 -- distribute, distribute with modifications, sublicense, and/or sell       --
  18 -- copies of the Software, and to permit persons to whom the Software is    --
  19 -- furnished to do so, subject to the following conditions:                 --
  20 --                                                                          --
  21 -- The above copyright notice and this permission notice shall be included  --
  22 -- in all copies or substantial portions of the Software.                   --
  23 --                                                                          --
  24 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  25 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  26 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  27 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  28 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  29 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  30 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  31 --                                                                          --
  32 -- Except as contained in this notice, the name(s) of the above copyright   --
  33 -- holders shall not be used in advertising or otherwise to promote the     --
  34 -- sale, use or other dealings in this Software without prior written       --
  35 -- authorization.                                                           --
  36 ------------------------------------------------------------------------------
  37 --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  38 --  Version Control
  39 --  $Revision: 1.7 $
  40 --  $Date: 2020/02/02 23:34:34 $
  41 --  Binding Version 01.00
  42 ------------------------------------------------------------------------------
  43 with ncurses2.util; use ncurses2.util;
  44 with ncurses2.genericPuts;
  45 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  46
  47 with Ada.Strings.Unbounded;
  48 with Ada.Strings.Fixed;
  49
  50 procedure ncurses2.acs_display is
  51    use Int_IO;
  52
  53    procedure show_upper_chars (first : Integer);
  54    function  show_1_acs (N    : Integer;
  55                          name : String;
  56                          code :  Attributed_Character)
  57                         return Integer;
  58    procedure show_acs_chars;
  59
  60    procedure show_upper_chars (first : Integer)  is
  61       C1 : constant Boolean := (first = 128);
  62       last : constant Integer := first + 31;
  63       package p is new ncurses2.genericPuts (200);
  64       use p;
  65       use p.BS;
  66       use Ada.Strings.Unbounded;
  67
  68       tmpa : Unbounded_String;
  69       tmpb : BS.Bounded_String;
  70    begin
  71       Erase;
  72       Switch_Character_Attribute
  73         (Attr => (Bold_Character => True, others => False));
  74       Move_Cursor (Line => 0, Column => 20);
  75       tmpa := To_Unbounded_String ("Display of ");
  76       if C1 then
  77          tmpa := tmpa & "C1";
  78       else
  79          tmpa := tmpa & "GR";
  80       end if;
  81       tmpa := tmpa & " Character Codes ";
  82       myPut (tmpb, first);
  83       Append (tmpa, To_String (tmpb));
  84       Append (tmpa, " to ");
  85       myPut (tmpb, last);
  86       Append (tmpa, To_String (tmpb));
  87       Add (Str => To_String (tmpa));
  88       Switch_Character_Attribute
  89         (On => False,
  90          Attr => (Bold_Character => True, others => False));
  91       Refresh;
  92
  93       for code in first .. last loop
  94          declare
  95             row : constant Line_Position
  96                 := Line_Position (4 + ((code - first) mod 16));
  97             col : constant Column_Position
  98                 := Column_Position (((code - first) / 16) *
  99                                     Integer (Columns) / 2);
 100             tmp3 : String (1 .. 3);
 101             tmpx : String (1 .. Integer (Columns / 4));
 102             reply : Key_Code;
 103          begin
 104             Put (tmp3, code);
 105             myPut (tmpb, code, 16);
 106             tmpa := To_Unbounded_String (tmp3 & " (" & To_String (tmpb) & ')');
 107
 108             Ada.Strings.Fixed.Move (To_String (tmpa), tmpx,
 109                                     Justify => Ada.Strings.Right);
 110             Add (Line => row, Column => col,
 111                  Str => tmpx & ' ' & ':' & ' ');
 112             if C1 then
 113                Set_NoDelay_Mode (Mode => True);
 114             end if;
 115             Add_With_Immediate_Echo (Ch => Code_To_Char (Key_Code (code)));
 116             --  TODO check this
 117             if C1 then
 118                reply := Getchar;
 119                while reply /= Key_None loop
 120                   Add (Ch => Code_To_Char (reply));
 121                   Nap_Milli_Seconds (10);
 122                   reply := Getchar;
 123                end loop;
 124                Set_NoDelay_Mode (Mode => False);
 125             end if;
 126          end;
 127       end loop;
 128    end show_upper_chars;
 129
 130    function show_1_acs (N    : Integer;
 131                         name : String;
 132                         code :  Attributed_Character)
 133                        return Integer is
 134       height : constant Integer := 16;
 135       row : constant Line_Position := Line_Position (4 + (N mod height));
 136       col : constant Column_Position := Column_Position ((N / height) *
 137                                                 Integer (Columns) / 2);
 138       tmpx : String (1 .. Integer (Columns) / 3);
 139    begin
 140       Ada.Strings.Fixed.Move (name, tmpx,
 141                               Justify => Ada.Strings.Right,
 142                               Drop => Ada.Strings.Left);
 143       Add (Line => row, Column => col, Str => tmpx & ' ' & ':' & ' ');
 144       --  we need more room than C because our identifiers are longer
 145       --  22 chars actually
 146       Add (Ch => code);
 147       return N + 1;
 148    end show_1_acs;
 149
 150    procedure show_acs_chars is
 151       n : Integer;
 152    begin
 153       Erase;
 154       Switch_Character_Attribute
 155         (Attr => (Bold_Character => True, others => False));
 156       Add (Line => 0, Column => 20,
 157            Str => "Display of the ACS Character Set");
 158       Switch_Character_Attribute (On => False,
 159                                   Attr => (Bold_Character => True,
 160                                            others => False));
 161       Refresh;
 162
 163       --  the following is useful to generate the below
 164       --  grep '^[ ]*ACS_' ../src/terminal_interface-curses.ads |
 165       --  awk '{print  "n := show_1_acs(n, \""$1"\", ACS_Map("$1"));"}'
 166
 167       n := show_1_acs (0, "ACS_Upper_Left_Corner",
 168                        ACS_Map (ACS_Upper_Left_Corner));
 169       n := show_1_acs (n, "ACS_Lower_Left_Corner",
 170                        ACS_Map (ACS_Lower_Left_Corner));
 171       n := show_1_acs (n, "ACS_Upper_Right_Corner",
 172                        ACS_Map (ACS_Upper_Right_Corner));
 173       n := show_1_acs (n, "ACS_Lower_Right_Corner",
 174                        ACS_Map (ACS_Lower_Right_Corner));
 175       n := show_1_acs (n, "ACS_Left_Tee", ACS_Map (ACS_Left_Tee));
 176       n := show_1_acs (n, "ACS_Right_Tee", ACS_Map (ACS_Right_Tee));
 177       n := show_1_acs (n, "ACS_Bottom_Tee", ACS_Map (ACS_Bottom_Tee));
 178       n := show_1_acs (n, "ACS_Top_Tee", ACS_Map (ACS_Top_Tee));
 179       n := show_1_acs (n, "ACS_Horizontal_Line",
 180                        ACS_Map (ACS_Horizontal_Line));
 181       n := show_1_acs (n, "ACS_Vertical_Line", ACS_Map (ACS_Vertical_Line));
 182       n := show_1_acs (n, "ACS_Plus_Symbol", ACS_Map (ACS_Plus_Symbol));
 183       n := show_1_acs (n, "ACS_Scan_Line_1", ACS_Map (ACS_Scan_Line_1));
 184       n := show_1_acs (n, "ACS_Scan_Line_9", ACS_Map (ACS_Scan_Line_9));
 185       n := show_1_acs (n, "ACS_Diamond", ACS_Map (ACS_Diamond));
 186       n := show_1_acs (n, "ACS_Checker_Board", ACS_Map (ACS_Checker_Board));
 187       n := show_1_acs (n, "ACS_Degree", ACS_Map (ACS_Degree));
 188       n := show_1_acs (n, "ACS_Plus_Minus", ACS_Map (ACS_Plus_Minus));
 189       n := show_1_acs (n, "ACS_Bullet", ACS_Map (ACS_Bullet));
 190       n := show_1_acs (n, "ACS_Left_Arrow", ACS_Map (ACS_Left_Arrow));
 191       n := show_1_acs (n, "ACS_Right_Arrow", ACS_Map (ACS_Right_Arrow));
 192       n := show_1_acs (n, "ACS_Down_Arrow", ACS_Map (ACS_Down_Arrow));
 193       n := show_1_acs (n, "ACS_Up_Arrow", ACS_Map (ACS_Up_Arrow));
 194       n := show_1_acs (n, "ACS_Board_Of_Squares",
 195                        ACS_Map (ACS_Board_Of_Squares));
 196       n := show_1_acs (n, "ACS_Lantern", ACS_Map (ACS_Lantern));
 197       n := show_1_acs (n, "ACS_Solid_Block", ACS_Map (ACS_Solid_Block));
 198       n := show_1_acs (n, "ACS_Scan_Line_3", ACS_Map (ACS_Scan_Line_3));
 199       n := show_1_acs (n, "ACS_Scan_Line_7", ACS_Map (ACS_Scan_Line_7));
 200       n := show_1_acs (n, "ACS_Less_Or_Equal", ACS_Map (ACS_Less_Or_Equal));
 201       n := show_1_acs (n, "ACS_Greater_Or_Equal",
 202                        ACS_Map (ACS_Greater_Or_Equal));
 203       n := show_1_acs (n, "ACS_PI", ACS_Map (ACS_PI));
 204       n := show_1_acs (n, "ACS_Not_Equal", ACS_Map (ACS_Not_Equal));
 205       n := show_1_acs (n, "ACS_Sterling", ACS_Map (ACS_Sterling));
 206
 207       if n = 0 then
 208          raise Constraint_Error;
 209       end if;
 210    end show_acs_chars;
 211
 212    c1 : Key_Code;
 213    c : Character := 'a';
 214 begin
 215    loop
 216       case c is
 217          when 'a' =>
 218             show_acs_chars;
 219          when '0' | '1' | '2' | '3' =>
 220             show_upper_chars (ctoi (c) * 32 + 128);
 221          when others =>
 222             null;
 223       end case;
 224       Add (Line => Lines - 3, Column => 0,
 225            Str => "Note: ANSI terminals may not display C1 characters.");
 226       Add (Line => Lines - 2, Column => 0,
 227            Str => "Select: a=ACS, 0=C1, 1,2,3=GR characters, q=quit");
 228       Refresh;
 229       c1 := Getchar;
 230       c := Code_To_Char (c1);
 231       exit when c = 'q' or c = 'x';
 232    end loop;
 233    Pause;
 234    Erase;
 235    End_Windows;
 236 end ncurses2.acs_display;