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