• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
1------------------------------------------------------------------------------
2--                                                                          --
3--                       GNAT ncurses Binding Samples                       --
4--                                                                          --
5--                                 Sample                                   --
6--                                                                          --
7--                                 B O D Y                                  --
8--                                                                          --
9------------------------------------------------------------------------------
10-- Copyright 2020 Thomas E. Dickey                                          --
11-- Copyright 1998-2008,2011 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:  Juergen Pfeifer, 1996
38--  Version Control
39--  $Revision: 1.19 $
40--  $Date: 2020/02/02 23:34:34 $
41--  Binding Version 01.00
42------------------------------------------------------------------------------
43with Text_IO;
44
45with Ada.Exceptions; use Ada.Exceptions;
46
47with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels;
49with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus;
50with Terminal_Interface.Curses.Menus.Menu_User_Data;
51with Terminal_Interface.Curses.Menus.Item_User_Data;
52
53with Sample.Manifest; use Sample.Manifest;
54with Sample.Function_Key_Setting; use Sample.Function_Key_Setting;
55with Sample.Keyboard_Handler; use Sample.Keyboard_Handler;
56with Sample.Header_Handler; use Sample.Header_Handler;
57with Sample.Explanation; use Sample.Explanation;
58
59with Sample.Menu_Demo.Handler;
60with Sample.Curses_Demo;
61with Sample.Form_Demo;
62with Sample.Menu_Demo;
63with Sample.Text_IO_Demo;
64
65with GNAT.OS_Lib;
66
67package body Sample is
68
69   type User_Data is
70      record
71         Data : Integer;
72      end record;
73   type User_Access is access User_Data;
74
75   package Ud is new
76     Terminal_Interface.Curses.Menus.Menu_User_Data
77     (User_Data, User_Access);
78
79   package Id is new
80     Terminal_Interface.Curses.Menus.Item_User_Data
81     (User_Data, User_Access);
82
83   procedure Whow is
84      procedure Main_Menu;
85      procedure Main_Menu
86      is
87         function My_Driver (M : Menu;
88                             K : Key_Code;
89                             Pan : Panel) return Boolean;
90
91         package Mh is new Sample.Menu_Demo.Handler (My_Driver);
92
93         I : Item_Array_Access := new Item_Array'
94           (New_Item ("Curses Core Demo"),
95            New_Item ("Menu Demo"),
96            New_Item ("Form Demo"),
97            New_Item ("Text IO Demo"),
98            Null_Item);
99
100         M : Menu := New_Menu (I);
101
102         D1, D2 : User_Access;
103         I1, I2 : User_Access;
104
105         function My_Driver (M : Menu;
106                             K : Key_Code;
107                             Pan : Panel) return Boolean
108         is
109            Idx : constant Positive := Get_Index (Current (M));
110         begin
111            if K in User_Key_Code'Range then
112               if K = QUIT then
113                  return True;
114               elsif K = SELECT_ITEM then
115                  if Idx <= 4 then
116                     Hide (Pan);
117                     Update_Panels;
118                  end if;
119                  case Idx is
120                     when 1 => Sample.Curses_Demo.Demo;
121                     when 2 => Sample.Menu_Demo.Demo;
122                     when 3 => Sample.Form_Demo.Demo;
123                     when 4 => Sample.Text_IO_Demo.Demo;
124                     when others => null;
125                  end case;
126                  if Idx <= 4 then
127                     Top (Pan);
128                     Show (Pan);
129                     Update_Panels;
130                     Update_Screen;
131                  end if;
132               end if;
133            end if;
134            return False;
135         end My_Driver;
136
137      begin
138
139         if (1 + Item_Count (M)) /= I'Length then
140            raise Constraint_Error;
141         end if;
142
143         D1 := new User_Data'(Data => 4711);
144         Ud.Set_User_Data (M, D1);
145
146         I1 := new User_Data'(Data => 1174);
147         Id.Set_User_Data (I.all (1), I1);
148
149         Set_Spacing (Men => M, Row => 2);
150
151         Default_Labels;
152         Notepad ("MAINPAD");
153
154         Mh.Drive_Me (M, " Demo ");
155
156         Ud.Get_User_Data (M, D2);
157         pragma Assert (D1 = D2);
158         pragma Assert (D1.Data = D2.Data);
159
160         Id.Get_User_Data (I.all (1), I2);
161         pragma Assert (I1 = I2);
162         pragma Assert (I1.Data = I2.Data);
163
164         Delete (M);
165         Free (I, True);
166      end Main_Menu;
167
168   begin
169      Initialize (PC_Style_With_Index);
170      Init_Header_Handler;
171      Init_Screen;
172
173      if Has_Colors then
174         Start_Color;
175
176         Init_Pair (Pair => Default_Colors,  Fore => Black,   Back => White);
177         Init_Pair (Pair => Menu_Back_Color, Fore => Black,   Back => Cyan);
178         Init_Pair (Pair => Menu_Fore_Color, Fore => Red,     Back => Cyan);
179         Init_Pair (Pair => Menu_Grey_Color, Fore => White,   Back => Cyan);
180         Init_Pair (Pair => Notepad_Color,   Fore => Black,   Back => Yellow);
181         Init_Pair (Pair => Help_Color,      Fore => Blue,    Back => Cyan);
182         Init_Pair (Pair => Form_Back_Color, Fore => Black,   Back => Cyan);
183         Init_Pair (Pair => Form_Fore_Color, Fore => Red,     Back => Cyan);
184         Init_Pair (Pair => Header_Color,    Fore => Black,   Back => Green);
185
186         Set_Background (Ch => (Color => Default_Colors,
187                                Attr  => Normal_Video,
188                                Ch    => ' '));
189         Set_Character_Attributes (Attr  => Normal_Video,
190                                   Color => Default_Colors);
191         Erase;
192
193         Set_Soft_Label_Key_Attributes (Color => Header_Color);
194         --  This propagates the attributes to the label window
195         Refresh_Soft_Label_Keys;
196      end if;
197
198      Init_Keyboard_Handler;
199
200      Set_Echo_Mode (False);
201      Set_Raw_Mode;
202      Set_Meta_Mode;
203      Set_KeyPad_Mode;
204
205      --  Initialize the Function Key Environment
206      --  We have some fixed key throughout this sample
207      Main_Menu;
208      End_Windows;
209      Curses_Free_All;
210
211   exception
212      when Event : others =>
213         Terminal_Interface.Curses.End_Windows;
214         Text_IO.Put ("Exception: ");
215         Text_IO.Put (Exception_Name (Event));
216         Text_IO.New_Line;
217         GNAT.OS_Lib.OS_Exit (1);
218
219   end Whow;
220
221end Sample;
222