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------------------------------------------------------------------------------ 43with ncurses2.util; use ncurses2.util; 44with Terminal_Interface.Curses; use Terminal_Interface.Curses; 45with Terminal_Interface.Curses.Terminfo; 46use Terminal_Interface.Curses.Terminfo; 47with Ada.Characters.Handling; 48with Ada.Strings.Fixed; 49 50procedure 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 275begin 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; 363end ncurses2.attr_test; 364