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