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-2006,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: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000 38-- Version Control 39-- $Revision: 1.9 $ 40-- $Date: 2020/02/02 23:34:34 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43with ncurses2.util; use ncurses2.util; 44 45with Terminal_Interface.Curses; use Terminal_Interface.Curses; 46with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; 47with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; 48 49procedure ncurses2.menu_test is 50 function menu_virtualize (c : Key_Code) return Key_Code; 51 procedure xAdd (l : Line_Position; c : Column_Position; s : String); 52 53 function menu_virtualize (c : Key_Code) return Key_Code is 54 begin 55 case c is 56 when Character'Pos (newl) | Key_Exit => 57 return Menu_Request_Code'Last + 1; -- MAX_COMMAND? TODO 58 when Character'Pos ('u') => 59 return M_ScrollUp_Line; 60 when Character'Pos ('d') => 61 return M_ScrollDown_Line; 62 when Character'Pos ('b') | Key_Next_Page => 63 return M_ScrollUp_Page; 64 when Character'Pos ('f') | Key_Previous_Page => 65 return M_ScrollDown_Page; 66 when Character'Pos ('n') | Key_Cursor_Down => 67 return M_Next_Item; 68 when Character'Pos ('p') | Key_Cursor_Up => 69 return M_Previous_Item; 70 when Character'Pos (' ') => 71 return M_Toggle_Item; 72 when Key_Mouse => 73 return c; 74 when others => 75 Beep; 76 return c; 77 end case; 78 end menu_virtualize; 79 80 MENU_Y : constant Line_Count := 8; 81 MENU_X : constant Column_Count := 8; 82 83 type String_Access is access String; 84 85 animals : constant array (Positive range <>) of String_Access := 86 (new String'("Lions"), 87 new String'("Tigers"), 88 new String'("Bears"), 89 new String'("(Oh my!)"), 90 new String'("Newts"), 91 new String'("Platypi"), 92 new String'("Lemurs")); 93 94 items_a : constant Item_Array_Access := 95 new Item_Array (1 .. animals'Last + 1); 96 97 tmp : Event_Mask; 98 99 procedure xAdd (l : Line_Position; c : Column_Position; s : String) is 100 begin 101 Add (Line => l, Column => c, Str => s); 102 end xAdd; 103 104 mrows : Line_Count; 105 mcols : Column_Count; 106 107 menuwin : Window; 108 109 m : Menu; 110 111 c1 : Key_Code; 112 113 c : Driver_Result; 114 r : Key_Code; 115begin 116 tmp := Start_Mouse; 117 xAdd (0, 0, "This is the menu test:"); 118 xAdd (2, 0, " Use up and down arrow to move the select bar."); 119 xAdd (3, 0, " 'n' and 'p' act like arrows."); 120 xAdd (4, 0, " 'b' and 'f' scroll up/down (page), 'u' and 'd' (line)."); 121 xAdd (5, 0, " Press return to exit."); 122 Refresh; 123 124 for i in animals'Range loop 125 items_a.all (i) := New_Item (animals (i).all); 126 end loop; 127 items_a.all (animals'Last + 1) := Null_Item; 128 129 m := New_Menu (items_a); 130 131 Set_Format (m, Line_Position (animals'Last + 1) / 2, 1); 132 Scale (m, mrows, mcols); 133 134 menuwin := Create (mrows + 2, mcols + 2, MENU_Y, MENU_X); 135 Set_Window (m, menuwin); 136 Set_KeyPad_Mode (menuwin, True); 137 Box (menuwin); -- 0,0? 138 139 Set_Sub_Window (m, Derived_Window (menuwin, mrows, mcols, 1, 1)); 140 141 Post (m); 142 143 loop 144 c1 := Getchar (menuwin); 145 r := menu_virtualize (c1); 146 c := Driver (m, r); 147 exit when c = Unknown_Request; -- E_UNKNOWN_COMMAND? 148 if c = Request_Denied then 149 Beep; 150 end if; 151 -- continue ? 152 end loop; 153 154 Move_Cursor (Line => Lines - 2, Column => 0); 155 Add (Str => "You chose: "); 156 Add (Str => Name (Current (m))); 157 Add (Ch => newl); 158 Pause; -- the C version didn't use Pause, it spelled it out 159 160 Post (m, False); -- unpost, not clear :-( 161 declare begin 162 Delete (menuwin); 163 exception when Curses_Exception => null; end; 164 -- menuwin has children so will raise the exception. 165 166 Delete (m); 167 168 End_Mouse (tmp); 169end ncurses2.menu_test; 170