Ada95/samples/sample-form_demo-aux.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                            Sample.Form_Demo.Aux                          --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 --  Version 00.92                                                           --
  10 --                                                                          --
  11 --  The ncurses Ada95 binding is copyrighted 1996 by                        --
  12 --  Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de                     --
  13 --                                                                          --
  14 --  Permission is hereby granted to reproduce and distribute this           --
  15 --  binding by any means and for any fee, whether alone or as part          --
  16 --  of a larger distribution, in source or in binary form, PROVIDED         --
  17 --  this notice is included with any such distribution, and is not          --
  18 --  removed from any of its header files. Mention of ncurses and the        --
  19 --  author of this binding in any applications linked with it is            --
  20 --  highly appreciated.                                                     --
  21 --                                                                          --
  22 --  This binding comes AS IS with no warranty, implied or expressed.        --
  23 ------------------------------------------------------------------------------
  24 --  Version Control
  25 --  $Revision: 1.5 $
  26 ------------------------------------------------------------------------------
  27 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
  28
  29 with Sample.Manifest; use Sample.Manifest;
  30 with Sample.Helpers; use Sample.Helpers;
  31 with Sample.Keyboard_Handler; use Sample.Keyboard_Handler;
  32 with Sample.Explanation; use Sample.Explanation;
  33
  34 package body Sample.Form_Demo.Aux is
  35
  36    procedure Geometry (F  : in  Form;
  37                        L  : out Line_Count;        -- Lines used for menu
  38                        C  : out Column_Count;      -- Columns used for menu
  39                        Y  : out Line_Position;     -- Proposed Line for menu
  40                        X  : out Column_Position)   -- Proposed Column for menu
  41    is
  42    begin
  43       Scale (F, L, C);
  44
  45       L := L + 2;  -- count for frame at top and bottom
  46       C := C + 2;  -- "
  47
  48       --  Calculate horizontal coordinate at the screen center
  49       X := (Columns - C) / 2;
  50       Y := 1; -- start always in line 1
  51    end Geometry;
  52
  53    function Create (F     : Form;
  54                     Title : String;
  55                     Lin   : Line_Position;
  56                     Col   : Column_Position) return Panel
  57    is
  58       W, S : Window;
  59       L : Line_Count;
  60       C : Column_Count;
  61       Y : Line_Position;
  62       X : Column_Position;
  63       Pan : Panel;
  64    begin
  65       Geometry (F, L, C, Y, X);
  66       W := New_Window (L, C, Lin, Col);
  67       Set_Meta_Mode (W);
  68       Set_KeyPad_Mode (W);
  69       if Has_Colors then
  70          Set_Background (Win => W,
  71                          Ch  => (Ch    => ' ',
  72                                  Color => Default_Colors,
  73                                  Attr  => Normal_Video));
  74          Set_Character_Attributes (Win => W,
  75                                    Color => Default_Colors,
  76                                    Attr  => Normal_Video);
  77          Erase (W);
  78       end if;
  79       S := Derived_Window (W, L - 2, C - 2, 1, 1);
  80       Set_Meta_Mode (S);
  81       Set_KeyPad_Mode (S);
  82       Box (W);
  83       Set_Window (F, W);
  84       Set_Sub_Window (F, S);
  85       if Title'Length > 0 then
  86          Window_Title (W, Title);
  87       end if;
  88       Pan := New_Panel (W);
  89       Post (F);
  90       return Pan;
  91    end Create;
  92
  93    procedure Destroy (F : in Form;
  94                       P : in out Panel)
  95    is
  96       W, S : Window;
  97    begin
  98       W := Get_Window (F);
  99       S := Get_Sub_Window (F);
 100       Post (F, False);
 101       Erase (W);
 102       Delete (P);
 103       Set_Window (F, Null_Window);
 104       Set_Sub_Window (F, Null_Window);
 105       Delete (S);
 106       Delete (W);
 107       Update_Panels;
 108    end Destroy;
 109
 110    function Get_Request (F           : Form;
 111                          P           : Panel;
 112                          Handle_CRLF : Boolean := True) return Key_Code
 113    is
 114       W  : constant Window := Get_Window (F);
 115       K  : Real_Key_Code;
 116       Ch : Character;
 117    begin
 118       Top (P);
 119       loop
 120          K := Get_Key (W);
 121          if K in Special_Key_Code'Range then
 122             case K is
 123                when HELP_CODE           => Explain_Context;
 124                when EXPLAIN_CODE        => Explain ("FORMKEYS");
 125                when Key_Home            => return F_First_Field;
 126                when Key_End             => return F_Last_Field;
 127                when QUIT_CODE           => return QUIT;
 128                when Key_Cursor_Down     => return F_Down_Char;
 129                when Key_Cursor_Up       => return F_Up_Char;
 130                when Key_Cursor_Left     => return F_Left_Char;
 131                when Key_Cursor_Right    => return F_Right_Char;
 132                when Key_Next_Page       => return F_ScrollForward_Line;
 133                when Key_Previous_Page   => return F_ScrollBackward_Line;
 134                when Key_Backspace       => return F_Delete_Previous;
 135                when others              => return K;
 136             end case;
 137          elsif K in Normal_Key_Code'Range then
 138             Ch := Character'Val (K);
 139             case Ch is
 140                when DC1 => return QUIT;                  -- CTRL-Q
 141                when ACK => return F_Next_Page;           -- CTRL-F
 142                when STX => return F_Previous_Page;       -- CTRL-B
 143                when SO  => return F_Next_Field;          -- CTRL-N
 144                when DLE => return F_Previous_Field;      -- CTRL-P
 145                when FF  => return F_Left_Field;          -- CTRL-L
 146                when DC2 => return F_Right_Field;         -- CTRL-R
 147                when NAK => return F_Up_Field;            -- CTRL-U
 148                when EOT => return F_Down_Field;          -- CTRL-D
 149                when ETB => return F_Next_Word;           -- CTRL-W
 150                when DC4 => return F_Previous_Word;       -- CTRL-T
 151                when DC3 => return F_Begin_Field;         -- CTRL-S
 152                when ENQ => return F_End_Field;           -- CTRL-E
 153                when HT  => return F_Insert_Char;         -- CTRL-I
 154                when SI  => return F_Insert_Line;         -- CTRL-O
 155                when SYN => return F_Delete_Char;         -- CTRL-V
 156                when BS  => return F_Delete_Previous;     -- CTRL-H
 157                when EM  => return F_Delete_Line;         -- CTRL-Y
 158                when BEL => return F_Delete_Word;         -- CTRL-G
 159                when VT  => return F_Clear_EOF;           -- CTRL-K
 160                when CAN => return F_Clear_Field;         -- CTRL-X
 161                when SOH => return F_Next_Choice;         -- CTRL-A
 162                when SUB => return F_Previous_Choice;     -- CTRL-Z
 163                when CR | LF  =>
 164                   if Handle_CRLF then
 165                      return F_New_Line;
 166                   else
 167                      return K;
 168                   end if;
 169                when others => return K;
 170             end case;
 171          else
 172             return K;
 173          end if;
 174       end loop;
 175    end Get_Request;
 176
 177    function Make (Top         : Line_Position;
 178                   Left        : Column_Position;
 179                   Text        : String) return Field
 180    is
 181       Fld : Field;
 182       C : Column_Count := Column_Count (Text'Length);
 183    begin
 184       Fld := New_Field (1, C, Top, Left);
 185       Set_Buffer (Fld, 0, Text);
 186       Switch_Options (Fld, (Active => True, others => False), False);
 187       if Has_Colors then
 188          Set_Background (Fld => Fld, Color => Default_Colors);
 189       end if;
 190       return Fld;
 191    end Make;
 192
 193    function Make  (Height      : Line_Count := 1;
 194                    Width       : Column_Count;
 195                    Top         : Line_Position;
 196                    Left        : Column_Position;
 197                    Off_Screen  : Natural := 0) return Field
 198    is
 199       Fld : Field := New_Field (Height, Width, Top, Left, Off_Screen);
 200    begin
 201       if Has_Colors then
 202          Set_Foreground (Fld => Fld, Color => Form_Fore_Color);
 203          Set_Background (Fld => Fld, Color => Form_Back_Color);
 204       else
 205          Set_Background (Fld, (Reverse_Video => True, others => False));
 206       end if;
 207       return Fld;
 208    end Make;
 209
 210    function Default_Driver (F : Form;
 211                             K : Key_Code;
 212                             P : Panel) return Boolean
 213    is
 214    begin
 215       if K in User_Key_Code'Range and then K = QUIT then
 216          if Driver (F, F_Validate_Field) = Form_Ok  then
 217             return True;
 218          end if;
 219       end if;
 220       return False;
 221    end Default_Driver;
 222
 223    function Count_Active (F : Form) return Natural
 224    is
 225       N : Natural := 0;
 226       O : Field_Option_Set;
 227       A : constant Field_Array_Access := Fields (F);
 228       H : constant Natural := Field_Count (F);
 229    begin
 230       if H > 0 then
 231          for I in 1 .. H loop
 232             Get_Options (A.all (I), O);
 233             if O.Active then
 234                N := N + 1;
 235             end if;
 236          end loop;
 237       end if;
 238       return N;
 239    end Count_Active;
 240
 241 end Sample.Form_Demo.Aux;