diff options
Diffstat (limited to 'ncurses-5.3/Ada95/samples/sample-explanation.adb')
| -rw-r--r-- | ncurses-5.3/Ada95/samples/sample-explanation.adb | 409 |
1 files changed, 0 insertions, 409 deletions
diff --git a/ncurses-5.3/Ada95/samples/sample-explanation.adb b/ncurses-5.3/Ada95/samples/sample-explanation.adb deleted file mode 100644 index e24e8d5..0000000 --- a/ncurses-5.3/Ada95/samples/sample-explanation.adb +++ /dev/null @@ -1,409 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT ncurses Binding Samples -- --- -- --- Sample.Explanation -- --- -- --- B O D Y -- --- -- ------------------------------------------------------------------------------- --- Copyright (c) 1998 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: Juergen Pfeifer, 1996 --- Contact: http://www.familiepfeifer.de/Contact.aspx?Lang=en --- Version Control --- $Revision$ --- Binding Version 01.00 ------------------------------------------------------------------------------- --- Poor mans help system. This scans a sequential file for key lines and --- then reads the lines up to the next key. Those lines are presented in --- a window as help or explanation. --- -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Deallocation; -with Terminal_Interface.Curses; use Terminal_Interface.Curses; -with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; - -with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; -with Sample.Manifest; use Sample.Manifest; -with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; -with Sample.Helpers; use Sample.Helpers; - -package body Sample.Explanation is - - Help_Keys : constant String := "HELPKEYS"; - In_Help : constant String := "INHELP"; - - File_Name : String := "explain.msg"; - F : File_Type; - - type Help_Line; - type Help_Line_Access is access Help_Line; - pragma Controlled (Help_Line_Access); - type String_Access is access String; - pragma Controlled (String_Access); - - type Help_Line is - record - Prev, Next : Help_Line_Access; - Line : String_Access; - end record; - - procedure Explain (Key : in String; - Win : in Window); - - procedure Release_String is - new Ada.Unchecked_Deallocation (String, - String_Access); - procedure Release_Help_Line is - new Ada.Unchecked_Deallocation (Help_Line, - Help_Line_Access); - - function Search (Key : String) return Help_Line_Access; - procedure Release_Help (Root : in out Help_Line_Access); - - procedure Explain (Key : in String) - is - begin - Explain (Key, Null_Window); - end Explain; - - procedure Explain (Key : in String; - Win : in Window) - is - -- Retrieve the text associated with this key and display it in this - -- window. If no window argument is passed, the routine will create - -- a temporary window and use it. - - function Filter_Key return Real_Key_Code; - procedure Unknown_Key; - procedure Redo; - procedure To_Window (C : in out Help_Line_Access; - More : in out Boolean); - - Frame : Window := Null_Window; - - W : Window := Win; - K : Real_Key_Code; - P : Panel; - - Height : Line_Count; - Width : Column_Count; - Help : Help_Line_Access := Search (Key); - Current : Help_Line_Access; - Top_Line : Help_Line_Access; - - Has_More : Boolean; - - procedure Unknown_Key - is - begin - Add (W, "Help message with ID "); - Add (W, Key); - Add (W, " not found."); - Add (W, Character'Val (10)); - Add (W, "Press the Function key labelled 'Quit' key to continue."); - end Unknown_Key; - - procedure Redo - is - H : Help_Line_Access := Top_Line; - begin - if Top_Line /= null then - for L in 0 .. (Height - 1) loop - Add (W, L, 0, H.Line.all); - exit when H.Next = null; - H := H.Next; - end loop; - else - Unknown_Key; - end if; - end Redo; - - function Filter_Key return Real_Key_Code - is - K : Real_Key_Code; - begin - loop - K := Get_Key (W); - if K in Special_Key_Code'Range then - case K is - when HELP_CODE => - if not Find_Context (In_Help) then - Push_Environment (In_Help, False); - Explain (In_Help, W); - Pop_Environment; - Redo; - end if; - when EXPLAIN_CODE => - if not Find_Context (Help_Keys) then - Push_Environment (Help_Keys, False); - Explain (Help_Keys, W); - Pop_Environment; - Redo; - end if; - when others => exit; - end case; - else - exit; - end if; - end loop; - return K; - end Filter_Key; - - procedure To_Window (C : in out Help_Line_Access; - More : in out Boolean) - is - L : Line_Position := 0; - begin - loop - Add (W, L, 0, C.Line.all); - L := L + 1; - exit when C.Next = null or else L = Height; - C := C.Next; - end loop; - if C.Next /= null then - pragma Assert (L = Height); - More := True; - else - More := False; - end if; - end To_Window; - - begin - if W = Null_Window then - Push_Environment ("HELP"); - Default_Labels; - Frame := New_Window (Lines - 2, Columns, 0, 0); - if Has_Colors then - Set_Background (Win => Frame, - Ch => (Ch => ' ', - Color => Help_Color, - Attr => Normal_Video)); - Set_Character_Attributes (Win => Frame, - Attr => Normal_Video, - Color => Help_Color); - Erase (Frame); - end if; - Box (Frame); - Set_Character_Attributes (Frame, (Reverse_Video => True, - others => False)); - Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls"); - Set_Character_Attributes (Frame); -- Back to default. - Window_Title (Frame, "Explanation"); - W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1); - Refresh_Without_Update (Frame); - Get_Size (W, Height, Width); - Set_Meta_Mode (W); - Set_KeyPad_Mode (W); - Allow_Scrolling (W, True); - Set_Echo_Mode (False); - P := Create (Frame); - Top (P); - Update_Panels; - else - Clear (W); - Refresh_Without_Update (W); - end if; - - Current := Help; Top_Line := Help; - - if null = Help then - Unknown_Key; - loop - K := Filter_Key; - exit when K = QUIT_CODE; - end loop; - else - To_Window (Current, Has_More); - if Has_More then - -- This means there are more lines available, so we have to go - -- into a scroll manager. - loop - K := Filter_Key; - if K in Special_Key_Code'Range then - case K is - when Key_Cursor_Down => - if Current.Next /= null then - Move_Cursor (W, Height - 1, 0); - Scroll (W, 1); - Current := Current.Next; - Top_Line := Top_Line.Next; - Add (W, Current.Line.all); - end if; - when Key_Cursor_Up => - if Top_Line.Prev /= null then - Move_Cursor (W, 0, 0); - Scroll (W, -1); - Top_Line := Top_Line.Prev; - Current := Current.Prev; - Add (W, Top_Line.Line.all); - end if; - when QUIT_CODE => exit; - when others => null; - end case; - end if; - end loop; - else - loop - K := Filter_Key; - exit when K = QUIT_CODE; - end loop; - end if; - end if; - - Clear (W); - - if Frame /= Null_Window then - Clear (Frame); - Delete (P); - Delete (W); - Delete (Frame); - Pop_Environment; - end if; - - Update_Panels; - Update_Screen; - - Release_Help (Help); - - end Explain; - - function Search (Key : String) return Help_Line_Access - is - Last : Natural; - Buffer : String (1 .. 256); - Root : Help_Line_Access := null; - Current : Help_Line_Access; - Tail : Help_Line_Access := null; - - function Next_Line return Boolean; - - function Next_Line return Boolean - is - H_End : constant String := "#END"; - begin - Get_Line (F, Buffer, Last); - if Last = H_End'Length and then H_End = Buffer (1 .. Last) then - return False; - else - return True; - end if; - end Next_Line; - begin - Reset (F); - Outer : - loop - exit Outer when not Next_Line; - if Last = (1 + Key'Length) and then Key = Buffer (2 .. Last) - and then Buffer (1) = '#' then - loop - exit when not Next_Line; - exit when Buffer (1) = '#'; - Current := new Help_Line'(null, null, - new String'(Buffer (1 .. Last))); - if Tail = null then - Release_Help (Root); - Root := Current; - else - Tail.Next := Current; - Current.Prev := Tail; - end if; - Tail := Current; - end loop; - exit Outer; - end if; - end loop Outer; - return Root; - end Search; - - procedure Release_Help (Root : in out Help_Line_Access) - is - Next : Help_Line_Access; - begin - loop - exit when Root = null; - Next := Root.Next; - Release_String (Root.Line); - Release_Help_Line (Root); - Root := Next; - end loop; - end Release_Help; - - procedure Explain_Context - is - begin - Explain (Context); - end Explain_Context; - - procedure Notepad (Key : in String) - is - H : constant Help_Line_Access := Search (Key); - T : Help_Line_Access := H; - N : Line_Count := 1; - L : Line_Position := 0; - W : Window; - P : Panel; - begin - if H /= null then - loop - T := T.Next; - exit when T = null; - N := N + 1; - end loop; - W := New_Window (N + 2, Columns, Lines - N - 2, 0); - if Has_Colors then - Set_Background (Win => W, - Ch => (Ch => ' ', - Color => Notepad_Color, - Attr => Normal_Video)); - Set_Character_Attributes (Win => W, - Attr => Normal_Video, - Color => Notepad_Color); - Erase (W); - end if; - Box (W); - Window_Title (W, "Notepad"); - P := New_Panel (W); - T := H; - loop - Add (W, L + 1, 1, T.Line.all, Integer (Columns - 2)); - L := L + 1; - T := T.Next; - exit when T = null; - end loop; - T := H; - Release_Help (T); - Refresh_Without_Update (W); - Notepad_To_Context (P); - end if; - end Notepad; - -begin - Open (F, In_File, File_Name); -end Sample.Explanation; - |