]> ncurses.scripts.mit.edu Git - ncurses.git/blob - Ada95/samples/ncurses2-attr_test.adb
ncurses 6.2 - patch 20200808
[ncurses.git] / Ada95 / samples / ncurses2-attr_test.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-2007,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.10 $
40 --  $Date: 2020/02/02 23:34:34 $
41 --  Binding Version 01.00
42 ------------------------------------------------------------------------------
43 with ncurses2.util; use ncurses2.util;
44 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
45 with Terminal_Interface.Curses.Terminfo;
46 use Terminal_Interface.Curses.Terminfo;
47 with Ada.Characters.Handling;
48 with Ada.Strings.Fixed;
49
50 procedure ncurses2.attr_test is
51
52    function  subset (super, sub : Character_Attribute_Set) return Boolean;
53    function  intersect (b, a : Character_Attribute_Set) return Boolean;
54    function  has_A_COLOR (attr : Attributed_Character) return Boolean;
55    function  show_attr (row  : Line_Position;
56                         skip : Natural;
57                         attr : Character_Attribute_Set;
58                         name : String;
59                         once : Boolean) return Line_Position;
60    procedure attr_getc (skip : in out Integer;
61                         fg, bg : in out Color_Number;
62                         result : out Boolean);
63
64    function subset (super, sub : Character_Attribute_Set) return Boolean is
65    begin
66       if
67         (super.Stand_Out or not sub.Stand_Out) and
68         (super.Under_Line or not sub.Under_Line) and
69         (super.Reverse_Video or not sub.Reverse_Video) and
70         (super.Blink or not sub.Blink) and
71         (super.Dim_Character or not sub.Dim_Character) and
72         (super.Bold_Character or not sub.Bold_Character) and
73         (super.Alternate_Character_Set or not sub.Alternate_Character_Set) and
74         (super.Invisible_Character or not sub.Invisible_Character) -- and
75 --      (super.Protected_Character or not sub.Protected_Character) and
76 --      (super.Horizontal or not sub.Horizontal) and
77 --      (super.Left or not sub.Left) and
78 --      (super.Low or not sub.Low) and
79 --      (super.Right or not sub.Right) and
80 --      (super.Top or not sub.Top) and
81 --      (super.Vertical or not sub.Vertical)
82       then
83          return True;
84       else
85          return False;
86       end if;
87    end subset;
88
89    function intersect (b, a : Character_Attribute_Set) return Boolean is
90    begin
91       if
92         (a.Stand_Out and b.Stand_Out) or
93         (a.Under_Line and b.Under_Line) or
94         (a.Reverse_Video and b.Reverse_Video) or
95         (a.Blink and b.Blink) or
96         (a.Dim_Character and b.Dim_Character) or
97         (a.Bold_Character and b.Bold_Character) or
98         (a.Alternate_Character_Set and b.Alternate_Character_Set) or
99         (a.Invisible_Character and b.Invisible_Character) -- or
100 --      (a.Protected_Character and b.Protected_Character) or
101 --      (a.Horizontal and b.Horizontal) or
102 --      (a.Left and b.Left) or
103 --      (a.Low and b.Low) or
104 --      (a.Right and b.Right) or
105 --      (a.Top and b.Top) or
106 --      (a.Vertical and b.Vertical)
107       then
108          return True;
109       else
110          return False;
111       end if;
112    end intersect;
113
114    function has_A_COLOR (attr : Attributed_Character) return Boolean is
115    begin
116       if attr.Color /= Color_Pair (0) then
117          return True;
118       else
119          return False;
120       end if;
121    end has_A_COLOR;
122
123    --  Print some text with attributes.
124    function show_attr (row  : Line_Position;
125                        skip : Natural;
126                        attr : Character_Attribute_Set;
127                        name : String;
128                        once : Boolean) return Line_Position is
129
130       function make_record (n : Integer) return Character_Attribute_Set;
131       function make_record (n : Integer) return Character_Attribute_Set is
132          --  unsupported means true
133          a : Character_Attribute_Set := (others => False);
134          m : Integer;
135          rest : Integer;
136       begin
137          --  ncv is a bitmap with these fields
138          --              A_STANDOUT,
139          --              A_UNDERLINE,
140          --              A_REVERSE,
141          --              A_BLINK,
142          --              A_DIM,
143          --              A_BOLD,
144          --              A_INVIS,
145          --              A_PROTECT,
146          --              A_ALTCHARSET
147          --  It means no_color_video,
148          --  video attributes that can't be used with colors
149          --  see man terminfo.5
150          m := n mod 2;
151          rest := n / 2;
152          if 1 = m then
153             a.Stand_Out := True;
154          end if;
155          m := rest mod 2;
156          rest := rest / 2;
157          if 1 = m then
158             a.Under_Line := True;
159          end if;
160          m := rest mod 2;
161          rest := rest / 2;
162          if 1 = m then
163             a.Reverse_Video := True;
164          end if;
165          m := rest mod 2;
166          rest := rest / 2;
167          if 1 = m then
168             a.Blink := True;
169          end if;
170          m := rest mod 2;
171          rest := rest / 2;
172          if 1 = m then
173             a.Bold_Character := True;
174          end if;
175          m := rest mod 2;
176          rest := rest / 2;
177          if 1 = m then
178             a.Invisible_Character := True;
179          end if;
180          m := rest mod 2;
181          rest := rest / 2;
182          if 1 = m then
183             a.Protected_Character := True;
184          end if;
185          m := rest mod 2;
186          rest := rest / 2;
187          if 1 = m then
188             a.Alternate_Character_Set := True;
189          end if;
190
191          return a;
192       end make_record;
193
194       ncv : constant Integer := Get_Number ("ncv");
195
196    begin
197       Move_Cursor (Line => row, Column => 8);
198       Add (Str => name & " mode:");
199       Move_Cursor (Line => row, Column => 24);
200       Add (Ch => '|');
201       if skip /= 0 then
202          --  printw("%*s", skip, " ")
203          Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
204       end if;
205       if once then
206          Switch_Character_Attribute (Attr => attr);
207       else
208          Set_Character_Attributes (Attr => attr);
209       end if;
210       Add (Str => "abcde fghij klmno pqrst uvwxy z");
211       if once then
212          Switch_Character_Attribute (Attr => attr, On => False);
213       end if;
214       if skip /= 0 then
215          Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
216       end if;
217       Add (Ch => '|');
218       if attr /= Normal_Video then
219          declare begin
220             if not subset (super => Supported_Attributes, sub => attr) then
221                Add (Str => " (N/A)");
222             elsif ncv > 0 and has_A_COLOR (Get_Background) then
223                declare
224                   Color_Supported_Attributes :
225                     constant Character_Attribute_Set := make_record (ncv);
226                begin
227                   if intersect (Color_Supported_Attributes, attr) then
228                      Add (Str => " (NCV) ");
229                   end if;
230                end;
231             end if;
232          end;
233       end if;
234       return row + 2;
235    end show_attr;
236
237    procedure attr_getc (skip : in out Integer;
238                         fg, bg : in out Color_Number;
239                         result : out Boolean) is
240       ch : constant Key_Code := Getchar;
241       nc : constant Color_Number := Color_Number (Number_Of_Colors);
242    begin
243       result := True;
244       if Ada.Characters.Handling.Is_Digit (Character'Val (ch)) then
245          skip := ctoi (Code_To_Char (ch));
246       elsif ch = CTRL ('L') then
247          Touch;
248          Touch (Current_Window);
249          Refresh;
250       elsif Has_Colors then
251          case ch is
252             --  Note the mathematical elegance compared to the C version.
253             when Character'Pos ('f') => fg := (fg + 1) mod nc;
254             when Character'Pos ('F') => fg := (fg - 1) mod nc;
255             when Character'Pos ('b') => bg := (bg + 1) mod nc;
256             when Character'Pos ('B') => bg := (bg - 1) mod nc;
257             when others =>
258                result := False;
259          end case;
260       else
261          result := False;
262       end if;
263    end attr_getc;
264
265    --      pairs could be defined as array ( Color_Number(0) .. colors - 1) of
266    --      array (Color_Number(0).. colors - 1) of Boolean;
267    pairs : array (Color_Pair'Range) of Boolean := (others => False);
268    fg, bg : Color_Number := Black; -- = 0;
269    xmc : constant Integer := Get_Number ("xmc");
270    skip : Integer := xmc;
271    n : Integer;
272
273    use Int_IO;
274
275 begin
276    pairs (0) := True;
277
278    if skip < 0 then
279       skip := 0;
280    end if;
281    n := skip;
282
283    loop
284       declare
285          row : Line_Position := 2;
286          normal : Attributed_Character := Blank2;
287          --  ???
288       begin
289          --  row := 2; -- weird, row is set to 0 without this.
290          --  TODO delete the above line, it was a gdb quirk that confused me
291          if Has_Colors then
292             declare pair : constant Color_Pair :=
293               Color_Pair (fg * Color_Number (Number_Of_Colors) + bg);
294             begin
295                --  Go though each color pair. Assume that the number of
296                --  Redefinable_Color_Pairs is 8*8 with predefined Colors 0..7
297                if not pairs (pair) then
298                   Init_Pair (pair, fg, bg);
299                   pairs (pair) := True;
300                end if;
301                normal.Color := pair;
302             end;
303          end if;
304          Set_Background (Ch => normal);
305          Erase;
306
307          Add (Line => 0, Column => 20,
308               Str => "Character attribute test display");
309
310          row := show_attr (row, n, (Stand_Out => True, others => False),
311                            "STANDOUT", True);
312          row := show_attr (row, n, (Reverse_Video => True, others => False),
313                            "REVERSE", True);
314          row := show_attr (row, n, (Bold_Character => True, others => False),
315                            "BOLD", True);
316          row := show_attr (row, n, (Under_Line => True, others => False),
317                            "UNDERLINE", True);
318          row := show_attr (row, n, (Dim_Character => True, others => False),
319                            "DIM", True);
320          row := show_attr (row, n, (Blink => True, others => False),
321                            "BLINK", True);
322 --       row := show_attr (row, n, (Protected_Character => True,
323 --                                  others => False), "PROTECT", True);
324          row := show_attr (row, n, (Invisible_Character => True,
325                                     others => False), "INVISIBLE", True);
326          row := show_attr (row, n, Normal_Video, "NORMAL", False);
327
328          Move_Cursor (Line => row, Column => 8);
329          if xmc > -1 then
330             Add (Str => "This terminal does have the magic-cookie glitch");
331          else
332             Add (Str => "This terminal does not have the magic-cookie glitch");
333          end if;
334          Move_Cursor (Line => row + 1, Column => 8);
335          Add (Str => "Enter a digit to set gaps on each side of " &
336               "displayed attributes");
337          Move_Cursor (Line => row + 2, Column => 8);
338          Add (Str => "^L = repaint");
339          if Has_Colors then
340             declare tmp1 : String (1 .. 1);
341             begin
342                Add (Str => ".  f/F/b/F toggle colors (");
343                Put (tmp1, Integer (fg));
344                Add (Str => tmp1);
345                Add (Ch => '/');
346                Put (tmp1, Integer (bg));
347                Add (Str => tmp1);
348                Add (Ch => ')');
349             end;
350          end if;
351          Refresh;
352       end;
353
354       declare result : Boolean; begin
355          attr_getc (n, fg, bg, result);
356          exit when not result;
357       end;
358    end loop;
359
360    Set_Background (Ch => Blank2);
361    Erase;
362    End_Windows;
363 end ncurses2.attr_test;