mirror/ncursesw-morphos
2
0
Fork 0
mirror of https://github.com/Aigor44/ncursesw-morphos.git synced 2024-12-27 07:49:06 +08:00
Code Issues Packages Projects Releases Wiki Activity
9776951416
ncursesw-morphos/Ada95/samples/ncurses2-attr_test.adb
Thomas E. Dickey 4c309ad3b1 ncurses 5.6 - patch 20080726 
+ build-fixes for gcc 4.3.1 (changes to gnat "warnings", and C inlining
  thresholds).
2008-07-26 22:24:31 +00:00

363 lines
14 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT ncurses Binding Samples --
-- --
-- ncurses --
-- --
-- B O D Y --
-- --
------------------------------------------------------------------------------
-- Copyright (c) 2000-2007,2008 Free Software Foundation, Inc. --
-- --
-- Permission is hereby granted, free of charge, to any person obtaining a --
-- copy of this software and associated documentation files (the --
-- "Software"), to deal in the Software without restriction, including --
-- without limitation the rights to use, copy, modify, merge, publish, --
-- distribute, distribute with modifications, sublicense, and/or sell --
-- copies of the Software, and to permit persons to whom the Software is --
-- furnished to do so, subject to the following conditions: --
-- --
-- The above copyright notice and this permission notice shall be included --
-- in all copies or substantial portions of the Software. --
-- --
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
-- --
-- Except as contained in this notice, the name(s) of the above copyright --
-- holders shall not be used in advertising or otherwise to promote the --
-- sale, use or other dealings in this Software without prior written --
-- authorization. --
------------------------------------------------------------------------------
-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
-- Version Control
-- $Revision: 1.9 $
-- $Date: 2008/07/26 18:47:26 $
-- Binding Version 01.00
------------------------------------------------------------------------------
with ncurses2.util; use ncurses2.util;
with Terminal_Interface.Curses; use Terminal_Interface.Curses;
with Terminal_Interface.Curses.Terminfo;
use Terminal_Interface.Curses.Terminfo;
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
procedure ncurses2.attr_test is
function subset (super, sub : Character_Attribute_Set) return Boolean;
function intersect (b, a : Character_Attribute_Set) return Boolean;
function has_A_COLOR (attr : Attributed_Character) return Boolean;
function show_attr (row : Line_Position;
skip : Natural;
attr : Character_Attribute_Set;
name : String;
once : Boolean) return Line_Position;
procedure attr_getc (skip : in out Integer;
fg, bg : in out Color_Number;
result : out Boolean);
function subset (super, sub : Character_Attribute_Set) return Boolean is
begin
if
(super.Stand_Out or not sub.Stand_Out) and
(super.Under_Line or not sub.Under_Line) and
(super.Reverse_Video or not sub.Reverse_Video) and
(super.Blink or not sub.Blink) and
(super.Dim_Character or not sub.Dim_Character) and
(super.Bold_Character or not sub.Bold_Character) and
(super.Alternate_Character_Set or not sub.Alternate_Character_Set) and
(super.Invisible_Character or not sub.Invisible_Character) -- and
-- (super.Protected_Character or not sub.Protected_Character) and
-- (super.Horizontal or not sub.Horizontal) and
-- (super.Left or not sub.Left) and
-- (super.Low or not sub.Low) and
-- (super.Right or not sub.Right) and
-- (super.Top or not sub.Top) and
-- (super.Vertical or not sub.Vertical)
then
return True;
else
return False;
end if;
end subset;
function intersect (b, a : Character_Attribute_Set) return Boolean is
begin
if
(a.Stand_Out and b.Stand_Out) or
(a.Under_Line and b.Under_Line) or
(a.Reverse_Video and b.Reverse_Video) or
(a.Blink and b.Blink) or
(a.Dim_Character and b.Dim_Character) or
(a.Bold_Character and b.Bold_Character) or
(a.Alternate_Character_Set and b.Alternate_Character_Set) or
(a.Invisible_Character and b.Invisible_Character) -- or
-- (a.Protected_Character and b.Protected_Character) or
-- (a.Horizontal and b.Horizontal) or
-- (a.Left and b.Left) or
-- (a.Low and b.Low) or
-- (a.Right and b.Right) or
-- (a.Top and b.Top) or
-- (a.Vertical and b.Vertical)
then
return True;
else
return False;
end if;
end intersect;
function has_A_COLOR (attr : Attributed_Character) return Boolean is
begin
if attr.Color /= Color_Pair (0) then
return True;
else
return False;
end if;
end has_A_COLOR;
-- Print some text with attributes.
function show_attr (row : Line_Position;
skip : Natural;
attr : Character_Attribute_Set;
name : String;
once : Boolean) return Line_Position is
function make_record (n : Integer) return Character_Attribute_Set;
function make_record (n : Integer) return Character_Attribute_Set is
-- unsupported means true
a : Character_Attribute_Set := (others => False);
m : Integer;
rest : Integer;
begin
-- ncv is a bitmap with these fields
-- A_STANDOUT,
-- A_UNDERLINE,
-- A_REVERSE,
-- A_BLINK,
-- A_DIM,
-- A_BOLD,
-- A_INVIS,
-- A_PROTECT,
-- A_ALTCHARSET
-- It means no_color_video,
-- video attributes that can't be used with colors
-- see man terminfo.5
m := n mod 2;
rest := n / 2;
if 1 = m then
a.Stand_Out := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Under_Line := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Reverse_Video := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Blink := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Bold_Character := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Invisible_Character := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Protected_Character := True;
end if;
m := rest mod 2;
rest := rest / 2;
if 1 = m then
a.Alternate_Character_Set := True;
end if;
return a;
end make_record;
ncv : constant Integer := Get_Number ("ncv");
begin
Move_Cursor (Line => row, Column => 8);
Add (Str => name & " mode:");
Move_Cursor (Line => row, Column => 24);
Add (Ch => '|');
if skip /= 0 then
-- printw("%*s", skip, " ")
Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
end if;
if once then
Switch_Character_Attribute (Attr => attr);
else
Set_Character_Attributes (Attr => attr);
end if;
Add (Str => "abcde fghij klmno pqrst uvwxy z");
if once then
Switch_Character_Attribute (Attr => attr, On => False);
end if;
if skip /= 0 then
Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
end if;
Add (Ch => '|');
if attr /= Normal_Video then
declare begin
if not subset (super => Supported_Attributes, sub => attr) then
Add (Str => " (N/A)");
elsif ncv > 0 and has_A_COLOR (Get_Background) then
declare
Color_Supported_Attributes :
constant Character_Attribute_Set := make_record (ncv);
begin
if intersect (Color_Supported_Attributes, attr) then
Add (Str => " (NCV) ");
end if;
end;
end if;
end;
end if;
return row + 2;
end show_attr;
procedure attr_getc (skip : in out Integer;
fg, bg : in out Color_Number;
result : out Boolean) is
ch : constant Key_Code := Getchar;
nc : constant Color_Number := Color_Number (Number_Of_Colors);
begin
result := True;
if Ada.Characters.Handling.Is_Digit (Character'Val (ch)) then
skip := ctoi (Code_To_Char (ch));
elsif ch = CTRL ('L') then
Touch;
Touch (Current_Window);
Refresh;
elsif Has_Colors then
case ch is
-- Note the mathematical elegance compared to the C version.
when Character'Pos ('f') => fg := (fg + 1) mod nc;
when Character'Pos ('F') => fg := (fg - 1) mod nc;
when Character'Pos ('b') => bg := (bg + 1) mod nc;
when Character'Pos ('B') => bg := (bg - 1) mod nc;
when others =>
result := False;
end case;
else
result := False;
end if;
end attr_getc;
-- pairs could be defined as array ( Color_Number(0) .. colors - 1) of
-- array (Color_Number(0).. colors - 1) of Boolean;
pairs : array (Color_Pair'Range) of Boolean := (others => False);
fg, bg : Color_Number := Black; -- = 0;
xmc : constant Integer := Get_Number ("xmc");
skip : Integer := xmc;
n : Integer;
use Int_IO;
begin
pairs (0) := True;
if skip < 0 then
skip := 0;
end if;
n := skip;
loop
declare
row : Line_Position := 2;
normal : Attributed_Character := Blank2;
-- ???
begin
-- row := 2; -- weird, row is set to 0 without this.
-- TODO delete the above line, it was a gdb quirk that confused me
if Has_Colors then
declare pair : constant Color_Pair :=
Color_Pair (fg * Color_Number (Number_Of_Colors) + bg);
begin
-- Go though each color pair. Assume that the number of
-- Redefinable_Color_Pairs is 8*8 with predefined Colors 0..7
if not pairs (pair) then
Init_Pair (pair, fg, bg);
pairs (pair) := True;
end if;
normal.Color := pair;
end;
end if;
Set_Background (Ch => normal);
Erase;
Add (Line => 0, Column => 20,
Str => "Character attribute test display");
row := show_attr (row, n, (Stand_Out => True, others => False),
"STANDOUT", True);
row := show_attr (row, n, (Reverse_Video => True, others => False),
"REVERSE", True);
row := show_attr (row, n, (Bold_Character => True, others => False),
"BOLD", True);
row := show_attr (row, n, (Under_Line => True, others => False),
"UNDERLINE", True);
row := show_attr (row, n, (Dim_Character => True, others => False),
"DIM", True);
row := show_attr (row, n, (Blink => True, others => False),
"BLINK", True);
-- row := show_attr (row, n, (Protected_Character => True,
-- others => False), "PROTECT", True);
row := show_attr (row, n, (Invisible_Character => True,
others => False), "INVISIBLE", True);
row := show_attr (row, n, Normal_Video, "NORMAL", False);
Move_Cursor (Line => row, Column => 8);
if xmc > -1 then
Add (Str => "This terminal does have the magic-cookie glitch");
else
Add (Str => "This terminal does not have the magic-cookie glitch");
end if;
Move_Cursor (Line => row + 1, Column => 8);
Add (Str => "Enter a digit to set gaps on each side of " &
"displayed attributes");
Move_Cursor (Line => row + 2, Column => 8);
Add (Str => "^L = repaint");
if Has_Colors then
declare tmp1 : String (1 .. 1);
begin
Add (Str => ". f/F/b/F toggle colors (");
Put (tmp1, Integer (fg));
Add (Str => tmp1);
Add (Ch => '/');
Put (tmp1, Integer (bg));
Add (Str => tmp1);
Add (Ch => ')');
end;
end if;
Refresh;
end;
declare result : Boolean; begin
attr_getc (n, fg, bg, result);
exit when not result;
end;
end loop;
Set_Background (Ch => Blank2);
Erase;
End_Windows;
end ncurses2.attr_test;
Reference in New Issue View Git Blame Copy Permalink