libtexttools3-dev 2.0.7-2 / usr / share / ada / adainclude / texttools / userio.adb

------------------------------------------------------------------------------
-- USER IO (package body)                                                   --
--                                                                          --
-- Part of TextTools                                                        --
-- Designed and Programmed by Ken O. Burtch                                 --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
--                 Copyright (C) 1999-2007 Ken O. Burtch                    --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- This is maintained at http://www.pegasoft.ca/tt.html                     --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Strings, Interfaces.C;
with Gen_List;
  pragma Elaborate( Gen_List );
with strings; use strings;

package body userio is

PackageRunning : boolean := false;

---> Global variables
--
-- Background Colour

BackgroundIsBlue : boolean;

-- Font Characteristics

SystemFontName    : constant str255 := To255( "System Font" ); -- fake for text screen
SystemFontSize    : constant natural := 12;

-- Pen Characteristics

CurrentStyle      : ATextStyle;     -- last text style selected
CurrentColour     : APenColourName; -- last text colour (unused)
CurrentPenColour  : APenColourName; -- last pen colour selected
CurrentAngle      : float;          -- last pen angle (turtle graphics)
CurrentSize       : Points;         -- last pen size
ErrorLine         : integer;        -- y coordinate for next error message
SpoolCounter      : natural;        -- number of times WaitToReval called

--> Macro variables

MacroFile         : constant APathName := To255( "$SYS/macro_file" );
                    -- macro file path
Macros            : Str255List.List;  -- contents of macro file:
                                        -- the key + string to equate
AreMacros         : boolean;          -- true if macro file was loaded
MacroInProgress   : boolean;          -- true if "do macro" key pressed

IdleJobsDone      : boolean;          -- true if IdleUserIO jobs incomplete

---> Sound Support

SoundFlag        : constant APathName := To255( "$SYS/play_sound" );
HasSounds        : boolean;

---> C routines to support Curses library

Colour_Flag : integer;
pragma Import( C, Colour_Flag, "colour_flag" );

--  colour : integer; -- 0 if monochrome
--    pragma Import( C, colour, "colour" );
lines  : integer; -- # lines
  pragma Import( C, lines, "lines" );
cols   : integer; -- # columns
  pragma Import( C, cols, "cols" );
C_hasmouse    : integer; -- GPM mouse if 1
  pragma Import( C, C_hasmouse, "C_hasmouse" );
C_mousebutton : integer;
  pragma Import( C, C_mousebutton, "C_mousebutton" );
C_mousex      : integer;
  pragma Import( C, C_mousex, "C_mousex" );
C_mousey      : integer;
  pragma Import( C, C_mousey, "C_mousey" );

procedure StartupCurses;
  pragma Import( C, StartupCurses, "StartupCurses" );
procedure ShutdownCurses;
  pragma Import( C, ShutdownCurses, "ShutdownCurses" );
procedure ResetCurses;
  pragma Import( C, ResetCurses, "ResetCurses" );
--procedure Cls;
  --pragma Import( C, Cls, "Cls" );        -- Curses move/clrtobot
--procedure FlushKeys;                   -- Curses' flushinp
  --pragma Import( C, FlushKeys, "FlushKeys" );
function CGetXY return long_integer;    -- Curses' getyx
  pragma Import( C, CGetXY, "CGetXY" );
function CGetKey return integer;        -- Curses' getch (cbreak)
  pragma Import( C, CGetKey, "CGetKey");
function CKeypress return integer;     -- Curses' getch (nodelay)
  pragma Import( C, CKeypress, "CKeypress");
function CKeyDelay return integer;     -- halfdelay
  pragma Import( C, CKeyDelay, "CKeyDelay" );
--  procedure DrawChar( ch : character );  -- Curses' echoch
--    pragma Import( C, DrawChar, "DrawChar");
procedure SpoolChar( ch : character ); -- Curses' addch
  pragma Import( C, SpoolChar, "SpoolChar" );
procedure CSpoolRect( left, top, right, bottom : integer;
  ch : character );
  pragma Import( C, CSpoolRect, "CSpoolRect" );
type SpecialChar is ( upperleft, lowerleft, upperright, lowerright,
     hline, vline );
procedure SpoolSpecial( s : specialChar ); -- line graphics
  pragma Import( C, SpoolSpecial, "SpoolSpecial" );
procedure CANSIColour( i : integer );
  pragma Import( C, CANSIColour, "CANSIColour" );
procedure Refresh;                     -- Curses' refresh
  pragma Import( C, Refresh, "Refresh" );
procedure CMoveTo( x, y : integer );   -- Curses' move
  pragma Import( C, CMoveTo, "CMoveTo" );
function  CGetChar( x, y : integer ) return character;  -- Curses' mvinch
  pragma Import( C, CGetChar, "CGetChar" );
procedure CTextStyle( bold, so, under : character );
  pragma Import( C, CTextStyle, "CTextStyle" ); -- Curses' attron/off
procedure CBeep;
  pragma Import( C, CBeep, "CBeep" ); -- beep terminal
procedure SetColour( cmode : integer );
  pragma Import( C, SetColour, "SetColour" );

---> Basic Terminal Control


  procedure GetDisplayInfo( info : in out ADisplayInfoRec ) is
  -- Return general info about the display device
    MaxX, MaxY : integer;
  begin
    -- C routines expect no wider than 180
    -- enforce a reasonable value for lines
    MaxX := cols;
    MaxY := lines;
    if cols > 180 then
       MaxX := 180;
    end if;
    if lines > 180 then
       MaxY := 180;
    end if;
    -- assume standard monochrome text terminal
    info.Fields    :=    8;     -- number of valid fields (excluding itself)
    info.TextBased := true;     -- is text terminal
    info.H_Res     := MaxX;     -- 80 columns
    info.V_Res     := MaxY;     -- 23 rows (24th for status bar on Wyse)
    if Colour_Flag > 0 then
       info.C_Res     :=  1;       -- has (ANSI) colour
    else
       info.C_Res     :=  0;       -- no colour
    end if;
    info.P_Len     :=  0;       -- no palette
    info.D_Buf     :=  1;       -- 1 buffer
    info.S_Res     :=  0;       -- no sound (besides beep)
    if IsLocal and NotEmpty( To255( "$SYS/beeps_file.zoo" ) ) then
       info.Y_Res     :=  1;       -- no sound [channels]
    else
       info.Y_Res     :=  0;       -- no sound [channels]
    end if;
  end GetDisplayInfo;

  procedure GetInputInfo( info : in out AnInputInfoRec ) is
  -- Return general info about the input devices
  begin
    info.Fields       := 4;     -- number of valid fields (excl. itself)
    info.HasKeyboard  := true;  -- has a keyboard
    info.HasDirection := false; -- no directional device (eg. joystick)
    info.HasVelocity  := false; -- no direction device => no velocity
    info.HasLocator   := C_hasmouse=1; -- locator device (eg. mouse)
  end GetInputInfo;


  ---> Pen Attributes
  --
  -- Name2RGB - convert a colour name to it's RGB components
  -- RGB2Name - convert RGB components to their colour name

  procedure Name2RGB( colour : APenColourName; redC, greenC, blueC :
    in out ARGBComponent ) is
  -- utility procedure to change from name to RGB
  begin
    -- for a terminal, fake reasonable values
    redC   := 100.0; -- default white
    blueC  := 100.0;
    greenC := 100.0;
    case Colour is
    when ScrollBack  => redC := 50.0; blueC := 50.0; greenC := 50.0;
    when ScrollThumb => null;
    when ThermBack   => redC := 50.0; blueC := 50.0; greenC := 50.0;
    when ThermFore   => null;
    when Red         => greenC := 0.0; blueC := 0.0;
    when Purple      => greenC := 0.0;
    when Green       => redC := 0.0; blueC := 0.0;
    when Blue        => redC := 0.0; greenC := 0.0;
    when Yellow      => blueC := 0.0;
    when Black       => redC := 0.0; blueC := 0.0; greenC := 0.0;
    when others      => null;
    end case;
  end Name2RGB;

  procedure RGB2Name( redC, greenC, blueC : ARGBComponent; colour :
    in out APenColourName ) is
  -- utility procedure to change from RGB to name
  begin
    if redC > 50.0 then
       Colour := red;
       if greenC > 50.0 and then blueC > 50.0 then
          Colour := white;
       elsif GreenC > 50.0 then
          Colour := yellow;
       elsif BlueC > 50.0 then
          Colour := purple;
       end if;
    else
       Colour := black;
       if greenC > 50.0 and then blueC > 50.0 then
          Colour := green;
       elsif greenC > 50.0 then
          Colour := green;
       elsif blueC > 50.0 then
          Colour := blue;
       end if;
    end if;
  end RGB2Name;

procedure SetPenColour( name : APenColourName ) is
-- Set the current pen colour by colour name
begin
  -- CTextStyle can override colour, so we always send the ASCII seq
  CurrentPenColour := Name;
  if Colour_Flag > 0 then
     case name is
     when none => CANSIColour( 0 );
     when outline => CANSIColour( 7 );
     when scrollBack => CANSIColour( 10 );
     when scrollThumb => CANSIColour( 12 );
     when thermBack => CANSIColour( 11 );
     when thermFore => CANSIColour( 9 );
     when White => CANSIColour( 7 );
     when Red => CANSIColour( 1 );
     when Purple => CANSIColour( 5 );
     when Green => CANSIColour( 2 );
     when Blue => CANSIColour( 4 );
     when Yellow => CANSIColour( 3 );
     when Black => CANSIColour( 0 );
     end case;
   end if;
end SetPenColour;

  procedure SetPenColour( redC, greenC, blueC : ARGBComponent ) is
  -- Select the current pen colour by RGB values
    PenColour : APenColourName := none;
  begin
    -- for a terminal, equate to reasonable colour name
    RGB2Name( redC, greenC, blueC, PenColour );
    if PenColour /= CurrentPenColour then
       SetPenColour( PenColour );
    end if;
  end SetPenColour;

  procedure SetPenColour( colour : APaletteColour ) is
  -- Select the current pen colour from the palette (no effect here)
  begin
    null;
  end SetPenColour;

  procedure SetPaletteColour( colour : APaletteColour; name : APenColourName ) is
  -- Set a palette colour by colour name (no palette = no effect)
  begin
    null;
  end SetPaletteColour;

  procedure SetPaletteColour( colour : APaletteColour; redC, greenC, blueC
    : ARGBComponent ) is
  -- Set a palette colour by RGB (no palette = no effect)
  begin
    null;
  end SetPaletteColour;

  procedure GetPaletteColour( colour : APaletteColour; redC, greenC, blueC
    : in out ARGBComponent ) is
  -- Get a palette colour's RGB (no palette = no effect)
  begin
    null;
  end GetPaletteColour;

  function GetPaletteColour( colour : APaletteColour ) return APenColourName is
     pragma Unreferenced (Colour);
     -- Get a palette colour's RGB (no palette - just returns white)
  begin
    return White;
  end GetPaletteColour;

  function FindPaletteColour( redC, greenC, blueC : ARGBComponent )
    return APaletteColour is
    pragma Unreferenced (RedC, GreenC, BlueC);
    -- search for the closest palette colour (meaningless)
  begin
    return 0;
  end FindPaletteColour;

procedure GetPenColour( redC, greenC, blueC : in out ARGBComponent ) is
-- Return the current pen colour (as RGB components)
begin
  NoError;
  Name2RGB( CurrentPenColour, redC, greenC, blueC );
end GetPenColour;

function GetPenColour return APenColourName is
-- Return the current pen colour (as a name)
begin
  NoError;
  return CurrentPenColour;
end GetPenColour;

function GetPenColour return APaletteColour is
-- Return the current pen colour as a palette entry (no effect)
begin
  NoError;
  return 0;
end GetPenColour;

function GetPenColour( colour : APaletteColour ) return APenColourName is
   pragma Unreferenced (Colour);
   -- Return a palette colour as a name (no palette - just return white)
begin
  NoError;
  return White;
end GetPenColour;

--  procedure GetPenColour( colour : APaletteColour; redC, greenC, blueC
--    : in out ARGBComponent ) is
--     pragma Unreferenced (Colour, Redc, Greenc, Bluec);
--  -- Return a palette colour as RGB (no palette = no effect)
--  begin
--    Error( TT_NotYetWritten );
--  end GetPenColour;

procedure GetPenPos( x, y : out integer ) is
    temp : long_integer;
  begin
    NoError;
    temp := CGetXY;
    x := integer( temp mod 256 );
    y := integer( temp / 256 );
  end GetPenPos;

procedure SetPenSize( p : points ) is
begin
  NoError;
  CurrentSize := p;
end SetPenSize;

function GetPenSize return points is
begin
  NoError;
  return CurrentSize;
end GetPenSize;

procedure GetPixel( x, y : integer; redC, greenC, blueC:out ARGBComponent ) is
  ch : character;
begin
  ch := CGetChar( x, y );
  -- No inverse function to get draw char yet
  if ch = ' ' then
     redC := 0.0;
     greenC := 0.0;
     blueC := 0.0;
  else
     redC := 100.0;
     greenC := 100.0;
     blueC := 100.0;
  end if;
end GetPixel;

-- Turtle Graphics

procedure SetPenAngle( angle : float ) is
begin
  CurrentAngle := float( integer(angle) mod 360 ); --rounding error
end SetPenAngle;

procedure ChangePenAngle( degrees : float ) is
begin
  CurrentAngle := float(integer(CurrentAngle + degrees) mod 360); --rounding error
end ChangePenAngle;

function GetPenAngle return float is
begin
  return CurrentAngle;
end GetPenAngle;

procedure DrawForward( dist : float ) is
  OldX, OldY, NewX, NewY : integer;
begin
  GetPenPos( OldX, OldY );
  NewX := OldX + Integer( Cos( CurrentAngle ) * dist );
  NewY := OldY + Integer( Sin( CurrentAngle ) * dist );
  DrawLine( OldX, OldY, NewX, NewY );
end DrawForward;

procedure MoveForward( dist : float ) is
  OldX, OldY, NewX, NewY : integer;
begin
  GetPenPos( OldX, OldY );
  NewX := OldX + Integer( Cos( CurrentAngle ) * dist );
  NewY := OldY + Integer( Sin( CurrentAngle ) * dist );
  MoveToGlobal( NewX, NewY );
end MoveForward;


  ---> Text Attributes


  procedure SetTextStyle( style : ATextStyle ) is
  -- Change the current text style
  begin
    if CurrentStyle = Input and Colour_Flag > 0 then
       SetPenColour( CurrentColour ); -- kludge: input changes colour
    end if;
    case style is
    when Normal =>
       CTextStyle( 'n', 'n', 'n');
    when Bold =>
       CTextStyle( 'y', 'n', 'n');
    when Italic =>
       CTextStyle( 'n', 'n', 'y');
    when Underline =>
       CTextStyle( 'n', 'n', 'y');
    when BoldItalic =>
       CTextStyle( 'y', 'n', 'n');
    when BoldUnderline =>
       CTextStyle( 'y', 'n', 'y');
    when ItalicUnderline =>
       CTextStyle( 'n', 'n', 'y');
    when BoldItalicUnderline =>
       CTextStyle( 'y', 'y', 'y');
    when Success =>
       CTextStyle( 'y', 'n', 'n');
    when Failure =>
       CTextStyle( 'n', 'y', 'n');
    when Warning =>
       if Colour_Flag > 0 then
          CTextStyle( 'y', 'n', 'n');
          SetPenColour( yellow );
       else
          CTextStyle( 'y', 'n', 'n');
       end if;
    when Status =>
       CTextStyle( 'n', 'n', 'n');
    when Citation =>
       CTextStyle( 'n', 'n', 'n');
    when SectionHeading =>
       CTextStyle( 'n', 'y', 'n');
    when Heading =>
       if Colour_Flag > 0 then
          CTextStyle( 'n', 'n', 'y');
          SetPenColour( yellow );
       else
          CTextStyle( 'n', 'n', 'y');
       end if;
    when SubHeading =>
       CTextStyle( 'y', 'n', 'n');
    when Title =>
       CTextStyle( 'y', 'n', 'n');
    when Emphasis =>
       CTextStyle( 'y', 'n', 'n');
    when Marquee =>
       if Colour_Flag > 0 then
          CTextStyle( 'y', 'n', 'y');
          SetPenColour( red );
       else
          CTextStyle( 'y', 'y', 'y');
       end if;
    when HeadLine =>
       CTextStyle( 'y', 'y', 'y');
    when FinePrint =>
       CTextStyle( 'n', 'n', 'n');
    when DefinedTerm =>
       CTextStyle( 'n', 'n', 'y');
    when Input =>
       if Colour_Flag > 0 then
          CTextStyle( 'n', 'n', 'n' );
          SetPenColour( white );
          CANSIColour( 8 ); -- background colour
       else
          CTextStyle( 'n', 'y', 'n');
       end if;
    when Footnote =>
       CTextStyle( 'n', 'n', 'n');
    when ToAddress =>
       CTextStyle( 'n', 'n', 'n');
    when FromAddress =>
       CTextStyle( 'n', 'n', 'n');
    when SubScript =>
       CTextStyle( 'n', 'n', 'n');
    when SuperScript =>
       CTextStyle( 'n', 'n', 'n');
       CTextStyle( 'n', 'n', 'n');
    end case;
    CurrentStyle := style;
  end SetTextStyle;

  function GetTextStyle return ATextStyle is
  -- Get the current text style
  begin
    return CurrentStyle;
  end GetTextStyle;

  procedure SetTextColour( name : APenColourName ) is
  -- Set the text colour (recorded, but no effect)
  begin
    CurrentColour := name;
    -- change colour here
  end SetTextColour;

  procedure SetTextFont( font : str255; size : natural := 0 ) is
  -- Set the text font and size (no fonts = no effect)
  begin
    null;
  end SetTextFont;

  procedure SetTextFont( fonts : Str255List.List; size : natural := 0 ) is
  begin
    null;
  end SetTextFont;

  function GetTextColour return APenColourName is
  -- Get the text colour
  begin
    return White; -- CurrentColour
  end GetTextColour;

  procedure GetTextFont( font : in out str255; size : in out natural ) is
  -- Get the text font and size (no fonts = reasonable estimate)
  begin
    font := SystemFontName; -- return a reasonable pseudo font & size
    size := SystemFontSize;
  end GetTextFont;

  procedure GetFontNameList( TheList : in out Str255List.List ) is
  -- get a list of available fonts
  begin
    Str255List.Clear( TheList );
    Str255List.Push( TheList, SystemFontName );
  end GetFontNameList;

  procedure GetFontSizeList( font : str255; TheList : in out Str255List.List ) is
     pragma Unreferenced (Font);
     -- get a list of sizes for a font
  begin
   Str255List.Clear( TheList );
   Str255List.Push( TheList, To255( natural'image(SystemFontSize) ) );
  end GetFontSizeList;

  function GetTextHeight( ch : character ) return integer is
     pragma Unreferenced (Ch);
  begin
    return 1;
  end GetTextHeight;

  function GetTextHeight( s : str255 ) return integer is
     pragma Unreferenced (S);
  begin
    return 1;
  end GetTextHeight;

  function GetTextWidth( ch : character ) return integer is
     pragma Unreferenced (Ch);
  begin
    return 1;
  end GetTextWidth;

  function GetTextWidth( s : str255 ) return integer is
  begin
    return length( s );
  end GetTextWidth;


---> Misc procedures


procedure MoveToGlobal( x, y : in integer ) is
-- Move to cursor (global coordinates)
begin
  CMoveTo( x, y );
end MoveToGlobal;

procedure Beep( style : BeepStyles ) is
-- Make the terminal beep (or play a sound effect)
-- beeps should really be extracted and moved to a temp file name!!!!
  BeepFile : APathName;
  OldPath  : APathName;
begin
  NoError;
  if HasSounds then
     OldPath := GetPath;
     SetPath( To255( "$SYS" ) );
     BeepFile := To255( BeepStyles'image( style ) );
     if NotEmpty( BeepFile ) then
        SessionLog( "Beep: playing " & BeepFile);
        PlaySound( BeepFile );
        if LastError /= TT_OK then
           SessionLog( "Beep: Error playing " & BeepFile, LastError );
        else
           SetPath( OldPath );
           return; -- don't CBeep
        end if;
     end if;
     SetPath( OldPath );
  end if;
  -- either no sound capability, or no sound to play for this beep style
  case style is
  when StartUp  => null;  -- no need to beep on startup
  when ShutDown => null;  -- no need to beep on shutdown
  when Status   => null;  -- no need to beep on a status message
  when HourChime => null;
  when QuarterChime1 => null;
  when QuarterChime2 => null;
  when QuarterChime3 => null;
  when others   => CBeep; -- assume worst: notify with beep by default
  end case;
end Beep;


  ---> Basic Input


  procedure GetKey( c : out character ) is
  -- Wait for a keypress and return it
  begin
    c := character'val( CGetKey );
  end GetKey;

  function Keypress( shortblock : boolean ) return character is
  -- Check for a keypress and return it (or else return NullKey)
  begin
    if ShortBlock then
       return character'val( CKeypress );
    else
       return character'val( CKeyDelay );
    end if;
  end Keypress;

  procedure GetDirection( direction : out ADirection;
                          velocity  : out AVelocity ) is
  -- Get the direction device's values (no device = return 0)
  begin
    direction := 0.0;
    velocity  := 0.0;
  end GetDirection;

  procedure GetLocation( x, y : out integer ) is
  -- Get the location device's values (no device = 0,0)
  begin
    x := 0;
    y := 0;
  end GetLocation;


  ---> Basic Output


  procedure Draw( s : string ) is
  -- Draw a string
  begin
    for i in s'first..s'last loop
        SpoolChar( s(i) );
    end loop;
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end Draw;

procedure Draw( s : str255; fieldwidth : integer; elipsis : boolean :=false)is
-- Draw a str255 strings with a fieldwidth an optional elipsis (if too long)
  OverflowLength : integer;
  OldStyle : ATextStyle; -- pad spaces must be in "normal" style
  OldColour: APenColourName;
begin
  OldStyle := GetTextStyle;
  OldColour := GetPenColour;
  OverflowLength := length( s ) - fieldwidth;
  if OverflowLength = 0 then
     Draw( s );
  elsif OverflowLength > 0  then
     if elipsis and fieldwidth > 3 then
        Draw( Head( s, fieldwidth-3 ) );
        Draw( "..." );
     else
        Draw( Head( s, fieldwidth ) );
     end if;
  else
     Draw( s );
     SetTextStyle( Normal );
     SetPenColour( White );
     for i in 1..-OverflowLength loop
         SpoolChar( ' ' );
     end loop;
     SetTextStyle( OldStyle );
     SetPenColour( OldColour );
  end if;
  if SpoolCounter = 0 then
     Refresh;
  end if;
  exception when others => DrawErrLn;
                           DrawErr("Draw(e) exception");
                           raise;
end Draw;

 procedure DrawEdit( s : str255; fieldwidth : integer; am : boolean )is
 -- Draw a str255 strings for an edit line with a fieldwidth
    OverflowLength : integer;
    OldStyle : ATextStyle; -- pad spaces must be in "normal" style
    OldColour : APenColourName;
  begin
    OldStyle := GetTextStyle;
    OldColour := GetPenColour;
    if am then -- advance mode: add a ">" at the far right
       OverflowLength := length( s ) - FieldWidth + 1;
       if OverflowLength = 0 then
          Draw( s );
       elsif OverflowLength > 0 then
          Draw( head( s, FieldWidth-1, Drop => Ada.Strings.Left) );
       else
          Draw( s );
          for i in 1..-OverflowLength loop
              SpoolChar( ' ' );
          end loop;
       end if;
       SpoolChar( '>' );
    else -- normal (no advance mode)
       OverflowLength := length( s ) - fieldwidth;
       if OverflowLength = 0 then
          Draw( s );
       elsif OverflowLength > 0  then
          Draw( Head( s, fieldwidth, Drop => Ada.Strings.Right) );
       else
          Draw( s );
          for i in 1..-OverflowLength loop
              SpoolChar( ' ' );
          end loop;
       end if;
    end if;
    SetTextStyle( OldStyle );
    SetPenColour( OldColour );
    if SpoolCounter = 0 then
       Refresh;
    end if;
    exception when others => DrawErrLn;
                             DrawErr( "DrawEdit exception" );
                             raise;
  end DrawEdit;

  procedure Draw( s : str255 ) is
  -- Draw a str255 string
  begin
    for i in 1..length( s ) loop
        SpoolChar( Element( s, i ) );
    end loop;
    if SpoolCounter = 0 then
       Refresh;
    end if;
    exception when others => DrawErrLn;
                             DrawErr("Draw(str255) exception");
                             raise;
  end Draw;

  procedure Draw( c : character ) is
  -- Draw a single character
  begin
    SpoolChar( c );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end Draw;

  procedure Draw( i : integer ) is
  -- Draw an integer
  begin
    Draw( integer'image( i ) );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end Draw;

  procedure Draw( l : long_integer ) is
  -- Draw a long integer
  begin
    Draw( long_integer'image( l ) );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end Draw;

procedure Draw( f : float ) is
-- Draw a float
begin
  Draw( float'image( f ) );
  if SpoolCounter = 0 then
     Refresh;
  end if;
end Draw;

procedure DrawCString( s : c_string ) is
-- Draw a C string (for C++)
  use Interfaces.C;
  i : Size_T;
begin
  i := 0;
  while character( s(i) ) /= ASCII.NUL and i < s'last loop
      SpoolChar( character( s(i) ) );
      i := i + 1;
  end loop;
  if SpoolCounter = 0 then
     Refresh;
  end if;
end DrawCString;

procedure DrawCoord( r : ARect ) is
-- Draw a rectangle's coordinates
begin
  Draw( r.left );
  Draw( ',' );
  Draw( r.top );
  Draw( '-' );
  Draw( r.right );
  Draw( ',' );
  Draw( r.bottom );
end DrawCoord;

procedure DrawLn is
-- Advance to the next line
  temp : long_integer;
  y : integer;
begin
  -- This used to work in early version of ncurses!
  -- SpoolChar( character'val(10) );
  -- SpoolChar( character'val(13) );
  temp := CGetXY;
  -- x := integer( temp mod 256 );
  y := integer( temp / 256 )+1;
  if y >= lines then
     y := 0;
  end if;
  CMoveTo( 0, y );
  if SpoolCounter = 0 then
     Refresh;
  end if;
end DrawLn;


  --- Error Output


  procedure DrawErr( s : string ) is
  -- Draw a string error message
  begin
    SetTextStyle( Normal );
    Draw( s );
    Refresh;
  end DrawErr;

  procedure DrawErr( i : integer ) is
  -- Draw an error integer
  begin
    SetTextStyle( Normal );
    Draw( i );
    Refresh;
  end DrawErr;

  procedure DrawErr( l : long_integer ) is
  -- Draw an error long integer
  begin
    SetTextStyle( Normal );
    Draw( l );
    Refresh;
  end DrawErr;

  procedure DrawErr( i : AnInputRecord ) is
  -- Draw an error input record
  begin
    SetTextStyle( Normal );
    MoveToGlobal( 1, ErrorLine );
    Draw( AnInput'image( i.InputType ) );
    Draw( '[' );
    case i.InputType is
    when NullInput       => null;
    when KeyInput        => Draw( i.Key );
    when HeldKeyInput    => Draw( i.HeldKey );
    when DirectionInput  => Draw( long_integer( i.Direction ) );
                            Draw( ',' );
                            Draw( long_integer( i.Velocity ) );
    when LocationInput   => Draw( i.x ); Draw( ',' ); Draw( i.y );
    when ButtonDownInput => Draw( i.DownButton );
    when ButtonUpInput   => Draw( i.UpButton );
    when HeartBeatInput  => null;
    when UserInput       => Draw( i.id );
    when others          => Draw( '?' );
    end case;
    Draw( ']' );
    Refresh;
  end DrawErr;

  procedure DrawErrLn is
  -- Advance to the next line for errors
  begin
    SetTextStyle( Normal );
    ErrorLine := ( ErrorLine + 1 ) mod 24;
    MoveToGlobal( 1, ErrorLine );
    Refresh;
  end DrawErrLn;

procedure DrawCErr( s : c_string ) is
begin
  SetTextStyle( Normal );
  DrawCString( s );
  Refresh;
end DrawCErr;


  ---> Drawing functions


procedure GetDrawChar( PenColour : APenColourName;
                       ch : out character ) is
  -- char to use to simulate a colour on monochrome terminals
  -- may affect scrren attributes
  begin
    ch := ' ';
    case PenColour is
    when Outline => ch := '+';
    when ScrollBack  => CTextStyle( 'n', 'y', 'n' );
    when ScrollThumb => CTextStyle( 'y', 'y', 'n' );
    when ThermBack   => CTextStyle( 'n', 'y', 'n' );
    when ThermFore   => CTextStyle( 'y', 'y', 'n' );
    when Red    => ch := '+';
    when Purple => ch := '%';
    when Green  => ch := '*';
    when Blue   => ch := '=';
    when Yellow => ch := '@';
    when Black  => null; -- a space
    when others => ch := '#';
    end case;
  end GetDrawChar;

  procedure DoneDrawing is
  -- counterpart of GetDrawChar: restore screen status, if necessary
  begin
    SetTextStyle( CurrentStyle );
  end DoneDrawing;
  pragma Inline( DoneDrawing );

  procedure DrawLine( x1, y1, x2, y2 : in integer ) is
  -- Draw a line between the coordinates in the current colour
    XLo, XHi  : integer;
    YLo, YHi  : integer;
    dx, dy    : integer;
    x, y      : integer;
    ch        : character;
  begin
    GetDrawChar( CurrentPenColour, ch );
    dx := x2 - x1;
    dy := y2 - y1;
    if dx = 0 and dy = 0 then
       MoveToGlobal( x1, y1 );
       SpoolChar( ch );
    elsif abs(dx) > abs(dy) then
       if x1 > x2 then
          XLo := x2;
          XHi := x1;
          YLo := y2;
          YHi := y1;
          dx := -dx;
          dy := -dy;
       else
          XLo := x1;
          XHi := x2;
          YLo := y1;
          YHi := y2;
       end if;
       for x in XLo..XHi loop
           y := YLo + ( dy * ( x - XLo ) ) / dx ;
           MoveToGlobal( x, y );
           SpoolChar( ch );
       end loop;
    else
       if y1 > y2 then
          XLo := x2;
          XHi := x1;
          YLo := y2;
          YHi := y1;
          dx := -dx;
          dy := -dy;
       else
          XLo := x1;
          XHi := x2;
          YLo := y1;
          YHi := y2;
       end if;
       for y in YLo..YHi loop
           x := XLo + ( dx * ( y - YLo ) ) / dy ;
           MoveToGlobal( x, y );
           SpoolChar( ch );
       end loop;
    end if;
    MoveToGlobal( x2, y2 );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end DrawLine;

  procedure DrawHorizontalLine( x1, x2, y1 : in integer ) is
  -- Draw a line between the coordinates in the current colour
  begin
    MoveToGlobal( x1, y1 );
    for x in x1..x2 loop
        MoveToGlobal( x, y1 );
        SpoolSpecial( hline );
    end loop;
    MoveToGlobal( x2, y1 );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end DrawHorizontalLine;

  procedure DrawVerticalLine( y1, y2, x1 : in integer ) is
  -- Draw a line between the coordinates in the current colour
  begin
    MoveToGlobal( x1, y1 );
    for y in y1..y2 loop
        MoveToGlobal( x1, y );
        SpoolSpecial( vline );
    end loop;
    MoveToGlobal( x1, y2 );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end DrawVerticalLine;

  procedure FrameRect( r : in ARect ) is
  -- Outline a rectangle
    lenx, leny: integer;
    ch : character;
    OldStyle : ATextStyle;
    OldPenColour : APenColourName;
  begin
    OldStyle := GetTextStyle;
    OldPenColour := CurrentPenColour;
    SetTextStyle( normal );
    if Colour_Flag > 0 then
       CurrentPenColour := outline; -- ok to draw with special chars in
    end if;                         -- colour, no need to fake colour
    if CurrentPenColour = Outline then
       MoveToGlobal(r.left, r.top);
       SpoolSpecial( upperleft );
       MoveToGlobal(r.left, r.bottom);
       SpoolSpecial( lowerleft );
       MoveToGlobal(r.right, r.top);
       SpoolSpecial( upperright );
       MoveToGlobal(r.right, r.bottom);
       SpoolSpecial( lowerright );
       lenx := r.right - r.left;
       leny := r.bottom - r.top;
       MoveToGlobal(r.left+1, r.top);
       for line in 2..LenX loop
           SpoolSpecial( hline );
       end loop;
       MoveToGlobal(r.left+1, r.bottom);
       for line in 2..LenX loop
           SpoolSpecial( hline );
       end loop;
       for line in 1..LenY-1 loop
           MoveToGlobal( r.left, r.top+line );
           SpoolSpecial( vline );
           MoveToGlobal( r.right, r.top+line );
           SpoolSpecial( vline );
       end loop;
    else
       -- fake colour drawing in different characters for different
       -- colours
       GetDrawChar( CurrentPenColour, ch );
       MoveToGlobal(r.left, r.top);
       SpoolChar( ch );
       MoveToGlobal(r.left, r.bottom);
       SpoolChar( ch );
       MoveToGlobal(r.right, r.top);
       SpoolChar( ch );
       MoveToGlobal(r.right, r.bottom);
       SpoolChar( ch );
       lenx := r.right - r.left;
       leny := r.bottom - r.top;
       MoveToGlobal(r.left+1, r.top);
       for line in 2..LenX loop
           SpoolChar( ch );
       end loop;
       MoveToGlobal(r.left+1, r.bottom);
       for line in 2..LenX loop
           SpoolChar( ch );
       end loop;
       for line in 1..LenY-1 loop
           MoveToGlobal( r.left, r.top+line );
           SpoolChar( ch );
           MoveToGlobal( r.right, r.top+line );
           SpoolChar( ch );
       end loop;
       DoneDrawing;
    end if;
    SetTextStyle( OldStyle );
    CurrentPenColour := OldPenColour;
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end FrameRect;

procedure FrameRect3D( r : in ARect ) is
-- Outline a rectangle, hilighting like SuSE 3D effect
  lenx, leny: integer;
  OldStyle     : ATextStyle;
  OldPenColour : APenColourName;
begin
  OldStyle := GetTextStyle;
  OldPenColour := CurrentPenColour;
  SetTextStyle( normal );
  if Colour_Flag > 0 then
     CurrentPenColour := outline; -- ok to draw with special chars in
  end if;                         -- colour, no need to fake colour
  if Colour_Flag > 0 and CurrentPenColour = Outline then
     CTextStyle( 'y', 'n', 'n' ); -- hilight
     MoveToGlobal( r.left, r.top ); -- top-left
     SpoolSpecial( upperleft );
     MoveToGlobal( r.right, r.top ); -- and top-right
     SpoolSpecial( upperright );
     CTextStyle( 'n', 'n', 'n' );  -- no hilight on others
     MoveToGlobal( r.left, r.bottom );
     SpoolSpecial( lowerleft );
     MoveToGlobal( r.right, r.bottom );
     SpoolSpecial( lowerright );
     lenx := r.right - r.left; -- computer width and height
     leny := r.bottom - r.top;
     MoveToGlobal( r.left+1, r.top );
     CTextStyle( 'y', 'n', 'n' ); -- top side hilighted
     for line in 2..LenX loop
         SpoolSpecial( hline );
     end loop;
     MoveToGlobal( r.left+1, r.bottom );
     CTextStyle( 'n', 'n', 'n' );
     for line in 2..LenX loop
         SpoolSpecial( hline );
     end loop;
     for line in 1..LenY-1 loop
         MoveToGlobal( r.right, r.top+line );
         SpoolSpecial( vline );
     end loop;
     CTextStyle( 'y', 'n', 'n' ); -- left side also hilighted
     for line in 1..LenY-1 loop
         MoveToGlobal( r.left, r.top+line );
         SpoolSpecial( vline );
     end loop;
  else
     FrameRect( r );
  end if;
  SetTextStyle( OldStyle );
  CurrentPenColour := OldPenColour;
  if SpoolCounter = 0 then
     Refresh;
  end if;
end FrameRect3D;

  procedure FramedRect( r : in ARect; ForeColour, BackColour : in APenColourName ) is
  -- Outline and fill a rectangle (ignores current colour settings)
    lenx, leny: integer;
    ch : character;
    OldStyle  : ATextStyle;
    OldColour : APenColourName;
  begin
    OldColour := GetPenColour;
    OldStyle := GetTextStyle;
    SetTextStyle( normal ); -- delete?
    SetPenColour( ForeColour );
    if ForeColour = Outline or Colour_Flag > 0 then
       MoveToGlobal(r.left, r.top);
       SpoolSpecial( upperleft );
       MoveToGlobal(r.left, r.bottom);
       SpoolSpecial( lowerleft );
       MoveToGlobal(r.right, r.top);
       SpoolSpecial( upperright );
       MoveToGlobal(r.right, r.bottom);
       SpoolSpecial( lowerright );
       lenx := r.right - r.left;
       leny := r.bottom - r.top;
       MoveToGlobal(r.left+1, r.top);
       for line in 2..LenX loop
           SpoolSpecial( hline );
       end loop;
       MoveToGlobal(r.left+1, r.bottom);
       for line in 2..LenX loop
           SpoolSpecial( hline );
       end loop;
       for line in 1..LenY-1 loop
           MoveToGlobal( r.left, r.top+line );
           SpoolSpecial( vline );
           MoveToGlobal( r.right, r.top+line );
           SpoolSpecial( vline );
       end loop;
    else
       GetDrawChar( ForeColour, ch );
       MoveToGlobal(r.left, r.top);
       SpoolChar( ch );
       MoveToGlobal(r.left, r.bottom);
       SpoolChar( ch );
       MoveToGlobal(r.right, r.top);
       SpoolChar( ch );
       MoveToGlobal(r.right, r.bottom);
       SpoolChar( ch );
       lenx := r.right - r.left;
       leny := r.bottom - r.top;
       MoveToGlobal(r.left+1, r.top);
       for line in 2..LenX loop
           SpoolChar( ch );
       end loop;
       MoveToGlobal(r.left+1, r.bottom);
       for line in 2..LenX loop
           SpoolChar( ch );
       end loop;
       for line in 1..LenY-1 loop
           MoveToGlobal( r.left, r.top+line );
           SpoolChar( ch );
           MoveToGlobal( r.right, r.top+line );
           SpoolChar( ch );
       end loop;
       --DoneDrawing;
    end if;
    SetPenColour( BackColour );
    GetDrawChar( BackColour, ch );
    CSpoolRect( r.left+1, r.top+1, r.right-1, r.bottom-1, ch );
    DoneDrawing;
    SetTextStyle( OldStyle );
    SetPenColour( OldColour );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end FramedRect;

  procedure FillRect( r : in ARect; Colour : APenColourName ) is
  -- Fill in a rectangle with the specified colour
    ch : character;
    OldColour : APenColourName;
  begin
    OldColour := GetPenColour;
    SetPenColour( Colour );
    GetDrawChar( Colour, ch );
    CSpoolRect( r.left, r.top, r.right, r.bottom, ch );
    DoneDrawing;
    SetPenColour( OldColour );
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end FillRect;

  procedure PaintRect( r : ARect ) is
  -- Fill in a rectangle with the current pen colour
  begin
    FillRect( r, CurrentPenColour );
  end PaintRect;

  procedure EraseRect( r : in ARect ) is
  -- Erase a rectangle (to black)
    OldColour : APenColourName;
    OldStyle : ATextStyle;
  begin
    OldStyle := GetTextStyle;
    if Colour_Flag > 0 then
       OldColour := CurrentPenColour;
       SetTextStyle( Normal );
       SetPenColour( Black );
    else
       SetTextStyle( Normal );
    end if;
    CSpoolRect( r.left, r.top, r.right, r.bottom, ' ' );
    MoveToGlobal( r.left, r.top );
    SetTextStyle( OldStyle );
    if Colour_Flag > 0 then
       SetPenColour( OldColour );
    end if;
    if SpoolCounter = 0 then
       Refresh;
    end if;
  end EraseRect;

  ---> Sound
  --
  -- Just for show

  procedure PlaySound( sound : ASound ) is
  -- Play the specified sound
  begin
    NoError;
    if IsLocal then
       if NotEmpty( sound ) then
          UNIX( "wavplay -q " & sound & " &" );
       else
          Error( TT_FileExistance );
       end if;
    end if;
  end PlaySound;

  procedure PlaySound( voice : AVoice; sound : ASound;
                       angle  : float := 0.0;
                       volume : float := 100.0;
                       freqchange : float := 0.0 ) is
  -- Play the specified sound with some special effects
  begin
    null;
  end PlaySound;

  procedure StopSound( voice : AVoice ) is
  -- Stop a sound
  begin
    null;
  end StopSound;

  procedure StopSounds is
  -- Stop all sounds
  begin
    null;
  end StopSounds;

  procedure PlaySong( song : ASong ) is
  -- Play a song
  begin
    null;
  end PlaySong;

  procedure StopSong is
  -- Stop playing a song
  begin
    null;
  end StopSong;

  function GetFreeVoice return AVoice is
  -- Get a free sound channel
  begin
    return 0;
  end GetFreeVoice;

  procedure SetMasterVolume( volume : float ) is
  -- Change the master volume
  begin
    null;
  end SetMasterVolume;

  function GetMasterVolume return float is
  -- Get the master volume
  begin
    return 100.0;
  end GetMasterVolume;

  ---> Input Event Handling
  --
  -- The Input Queue (sorted by arrival time)

  function InputGreaterThan( left, right : AnInputPtr ) return boolean is
  begin
    return left.TimeStamp > right.TimeStamp;
  end InputGreaterThan;
  package InputList is new Gen_List( AnInputPtr, "=", InputGreaterThan );
  InputQueue : InputList.List; -- input events, sorted by time

  --- Input Subprograms

  procedure DoMacro( k : character ) is
  -- look up and process a macro for character k
    Macro    : Str255List.AListIndex;
    MacroStr : str255;
    --EventPtr : AnInputPtr;
  begin
    Macro := 1;
    while Macro <= Str255List.Length( Macros ) loop
          Str255List.Find( Macros, Macro, MacroStr );
          if Element( MacroStr, 1 ) = k then
             SetInputString( Tail( MacroStr, Length( MacroStr )-1 ) );
             exit;
          end if;
          macro := macro + 1;
    end loop;
  end DoMacro;

  procedure PollInput( Response : AResponseTime := Blocking ) is
  -- check queue and add input
    k   : character; -- character pulled from input device
    k2  : character; -- for interpreting alt key press
    eventPtr : AnInputPtr;
  begin
    -- check for input: wait if waiting is allowed and queue is empty
    if InputList.Length( InputQueue ) = 0 then
       --
       -- Mouse Support for GPM Library
       --
       -- check mouse first since it's not blocking
       -- if C_mousebutton = 1 then
       --    EventPtr := new AnInputRecord'(InputType => ButtonDownInput,
       --                                   TimeStamp => GetTimeStamp,
       --                                   UpLocationX => C_mousex,
       --                                   UpLocationY => C_mousey,
       --                                   UpButton    => 1); -- every button is 1
       -- SessionLog( "Mouse up at " & integer'image( EventPtr.UpLocationX ) &
       --      ", " & integer'image( EventPtr.UpLocationY ) );
       --    InputList.Insert( InputQueue, EventPtr );
       --    k := NullKey;
       --    C_mousebutton := -1;
       -- elsif C_mousebutton = 0 then
       --    EventPtr := new AnInputRecord'(InputType => ButtonUpInput,
       --                                   TimeStamp => GetTimeStamp,
       --                                   DownLocationX => C_mousex,
       --                                   DownLocationY => C_mousey,
       --                                   DownButton    => 1); -- every button is 1
       -- SessionLog( "Mouse down at " & integer'image( EventPtr.DownLocationX ) &
       --      ", " & integer'image( EventPtr.DownLocationY ) );
       --    InputList.Insert( InputQueue, EventPtr );
       --    k := NullKey;
       --    C_mousebutton := -1;
       -- elsif Response = Blocking then
       -- ------------- END OF GPM Mouse Support ----------
       if Response = Blocking then
           k := character'val( CGetKey ); -- wait for keypress availability
       elsif Response = Instant then
           k := character'val( CKeypress ); -- quick check
       else
           k := character'val( CKeyDelay ); -- semi-blocked
       end if;
       -- ncurses mouse support - ASCII 255 = button 1 clicked
       if character'pos( k ) = 254 then
          EventPtr := new AnInputRecord'(InputType => MoveInput,
                                         TimeStamp => GetTimeStamp,
                                         MoveLocationX => C_Mousex,
                                         MoveLocationY => C_Mousey);
          InputList.Insert( InputQueue, EventPtr ); -- queue event
          k := NullKey;                       -- discard ASCII 255
       elsif character'pos( k ) = 255 then
          EventPtr := new AnInputRecord'(InputType => ButtonUpInput,
                                         TimeStamp => GetTimeStamp,
                                         UpLocationX => C_Mousex,   -- where
                                         UpLocationY => C_Mousey,
                                         UpButton    => 1);          -- which - button 1
           InputList.Insert( InputQueue, EventPtr ); -- queue event
           k := NullKey;                       -- discard ASCII 255
       end if;
    else
       k := character'val( CKeypress ); -- check for queued keypresses
    end if;
    -- if new input, add it to the queue
    if MacroInProgress and k /= NullKey then
       DoMacro( k );
       MacroInProgress := false;
    elsif k = MacroKey and AreMacros then
       MacroInProgress := true;
    elsif k /= NullKey then
       -- IBM keyboard: alt = esc + character.  Return with high bit set.
       -- Note: can't do alt-ctrl-@ this way, since that's alt-nullkey
       if k = character'val( 27 ) then
          k2 := character'val( CKeypress ); -- quick check for another
          if k2 /= NullKey then
             k := character'val( 128 + character'pos( k2 ) );
          end if;
       end if;
       EventPtr := new AnInputRecord'(InputType => KeyInput,
                                      TimeStamp => GetTimeStamp,
                                      Key => K);
       InputList.Insert( InputQueue, EventPtr );
       -- reminder: do not "Free"--memory still in use.
    end if;
  end PollInput;

  -- I wonder whether this does not crash, since a pulled
  --  event'discriminant cannot be predicted.
  procedure GetInput (E        :    out AnInputRecord;
                      Response : in     AResponseTime := Blocking ) is
  begin
     PollInput( Response );
     if InputList.Length( InputQueue ) = 0 then
        E := (InputType => NullInput, Timestamp => GetTimeStamp);
     else
        declare
           NextEvent : AnInputPtr;
        begin
           InputList.Pull( InputQueue, Nextevent);
           e := NextEvent.all;
           Free( NextEvent );
        end;
     end if;
  end GetInput;

  procedure SetInput( e : AnInputRecord; usetime : boolean := false ) is
  -- add an input event to the input queue
     eventPtr : AnInputPtr;
  begin
    eventPtr := new AnInputRecord'(e); -- create new input rec
    if not UseTime then
       eventptr.TimeStamp := GetTimeStamp;        -- stamp it
    end if;
    InputList.Insert( InputQueue, eventPtr );     -- and sort by timestamp
    PollInput( Response => Instant );
  end SetInput;

  procedure SetInputString( s : str255 ) is
  -- post a string as a series of key presses
    KeyEvent : AnInputPtr;
  begin
    for i in 1..length( s ) loop
       KeyEvent := new AnInputRecord'(InputType => KeyInput,
                                      TimeStamp => GetTimeStamp,
                                      key => Element( s, i ));
       InputList.Insert( InputQueue, KeyEvent );
    end loop;
    PollInput( Response => Instant );
  end SetInputString;

  procedure HeartBeat is
  -- post a heart beat
  begin
     SetInput( AnInputRecord'(InputType => HeartBeatInput,
                              Timestamp => Gettimestamp) );
  end HeartBeat;

  procedure FlushInput is
  -- flush the input queue
    eventPtr : AnInputPtr;
  begin
    FlushKeys;
    while InputList.Length( InputQueue ) > 0 loop
          InputList.Pull( InputQueue, eventPtr );
          Free( eventPtr );
    end loop;
    MacroInProgress := false;
  end FlushInput;

  procedure WaitFor( ticks : integer ) is
  -- check queue and add input, with timeout
    k : character;
    LoopTime : integer;
  begin
    looptime := ticks / 6;
    if looptime < 0 then
       PollInput( Response => Instant );
    else
       for i in 1..LoopTime loop
           -- check for input: wait if waiting is allowed and queue is empty
           k := character'val( CKeyDelay ); -- check for waiting keypress
           -- if new input, add it to the queue
           if MacroInProgress then
              DoMacro( k );
              MacroInProgress := false;
           elsif k = MacroKey and AreMacros then
              MacroInProgress := true;
           elsif k /= NullKey then
              InputList.Insert( InputQueue,
                                new AnInputRecord'(InputType => KeyInput,
                                                   TimeStamp => GetTimeStamp,
                                                   Key => K));
              -- reminder: do not "Free"--memory still in use.
           end if;
       end loop;
    end if;
  end WaitFor;

  function GetInputLength return long_integer is
  -- return the length of the input queue
  begin
    return long_integer( InputList.Length( InputQueue ) );
  end GetInputLength;


---> Regions
--
-- Mostly just for show, for now.

procedure RectInRegionSubRect( rect : ARect; region : in out ARegion;
  Result : out boolean ) is
  -- support procedures if InRegion calls
  -- determine if a rectangle is in any of the rectangles in a region
  RegionRect : ARect;
begin
  Result := false;
  for i in 1..RectList.length( region ) loop
      RectList.Find( region, i, regionrect );
      if InsideRect( Inner => rect, Outer => regionrect ) then
         Result := true;
         exit;
      end if;
  end loop;
end RectInRegionSubRect;

procedure SetRectRegion( region : in out ARegion; rect : ARect ) is
begin
  RectList.Clear( region );
  RectList.Insert( region, rect );
end SetRectRegion;

procedure OffsetRegion( region : in out ARegion; dx, dy : integer ) is
  SubRect : ARect;
begin
  for i in 1..RectList.Length( region ) loop
      RectList.Find( region, i, SubRect );
      OffsetRect( SubRect, dx, dy );
      RectList.Replace( region, i, SubRect );
  end loop;
end OffsetRegion;

procedure InRegion( x, y : integer; region : in out ARegion;
  result : out boolean ) is
  RegionRect : ARect;
begin
  result := false;
  for i in 1..RectList.Length( region ) loop
      RectList.Find( Region, i, RegionRect );
      if InRect( x, y, RegionRect ) then
         result := true;
         exit;
      end if;
  end loop;
end InRegion;

procedure InRegion( r : ARect; region : in out ARegion;
   result : out boolean ) is
   SubRect : ARect;
-- is a rectangle contained in a region?
   CenterX, CenterY : integer;
   Subresult : boolean;

begin
  -- a region is a list of rectangles, so start with the elementary
  -- case of a retangle in a rectangle composing the region.
  RectInRegionSubRect( r, region, subresult );
  if subresult then
     Result := true;
  else
     -- check corner points...they should all be in the region
     InRegion( r.left, r.top, region, subresult );
     if not subresult then
        Result := false;
        return;
     end if;
     InRegion( r.right, r.top, region, subresult );
     if not subresult then
        Result := false;
        return;
     end if;
     InRegion( r.left, r.bottom, region, subresult );
     if not subresult then
        Result := false;
        return;
     end if;
     InRegion( r.right, r.bottom, region, subresult );
     if not subresult then
        Result := false;
        return;
     end if;
     -- OK?  well that may be because the rectangle overlaps adjacent
     -- rectangles in the region.  All we can do is recursively subdivide
     -- the rectangle into sub rectangles that fall into one or another
     -- of the adjacent rectangles in the region.  If all succeed, then
     -- the rectangle is in the region.
     CenterX := (r.right-r.left)/2+r.left;
     CenterY := (r.bottom-r.top)/2+r.top;
     SubRect.left   := r.left; -- top-left
     SubRect.right  := CenterX;
     SubRect.top    := r.top;
     SubRect.bottom := CenterY;
     if not IsEmptyRect( SubRect ) then
        InRegion( SubRect, Region, subresult );
        if not subresult then
           result := false;
           return;
        end if;
     end if;
     SubRect.left   := CenterX + 1; -- top-right
     SubRect.right  := r.right;
     if not IsEmptyRect( Subrect ) then
        InRegion( SubRect, Region, subresult );
        if not subresult then
           result := false;
           return;
        end if;
     end if;
     SubRect.left := r.left; -- bottom-left
     SubRect.right := CenterX;
     SubRect.top  := CenterY+1;
     SubRect.bottom := r.bottom;
     if not IsEmptyRect( Subrect ) then
        InRegion( SubRect, Region, subresult);
        if not subresult then
           result := false;
           return;
        end if;
     end if;
     SubRect.left := CenterX+1; -- bottom-right
     SubRect.right := r.right;
     if not IsEmptyRect( SubRect ) then
        InRegion( SubRect, Region, subresult );
        if not subresult then
           result := false;
           return;
        end if;
     end if;
     Result := true; -- all subrects in the region?  great!
   end if;
end InRegion;

procedure InRegion( r, region : in out ARegion; result : out boolean ) is
  subresult : boolean;
  RegionRect : ARect;
begin
  result := true;
  for i in 1..RectList.Length( r ) loop
      RectList.Find( r, i, RegionRect );
      InRegion( RegionRect, region, subresult );
      if not subresult then
         result := false;
         exit;
      end if;
  end loop;
end InRegion;

procedure AddRegion( region, region2add : in out ARegion ) is
  NewSubRect : ARect;
  result     : boolean;
-- add two regions together by adding all parts that aren't
-- common to both
begin
  for i in 1..RectList.Length( region2add ) loop
      RectList.Find( region2add, i, NewSubRect );
      RectInRegionSubRect( NewSubRect, region, result );
      if not result then
         RectList.Insert( region, NewSubRect );
      end if;
  end loop;
end AddRegion;

--  procedure SetClipRegion( R : in out ARegion ) is
--  begin
--     Error( TT_NotYetWritten );
--  end SetClipRegion;

---> Pictures

type APictureType is (TextImage, PixelImage);
pragma Unreferenced (Pixelimage);
type APictureRecord is record
     path : str255;
     --kind : APictureType;
end record;
function PictureSorting( left, right : APictureRecord ) return boolean is
begin
  return left.path >= right.path;
end PictureSorting;

package PictureList is new Gen_List( APictureRecord, "=", PictureSorting );
Pictures : PictureList.List;

function RegisterPicture( path : str255 ) return APictureID is
  NewPicture : APictureRecord;
begin
  NewPicture.path := path;
  --NewPicture.kind := TextImage;
  PictureList.Queue( Pictures, NewPicture );
  return APictureID( PictureList.Length( Pictures ) );
end RegisterPicture;

function SavePicture( path, title : str255; bounds : ARect )
    return APictureID is
  NewPicture : APictureRecord;
  PictureFile: Str255List.List;
  TempInt : integer;
  es : EncodedString;
begin
  NewPicture.path := path;
  --NewPicture.kind := TextImage;
  PictureList.Queue( Pictures, NewPicture );
  es := NullStr255;
  Encode( es, title );
  Str255list.Queue( PictureFile, title );
  es := NullStr255;
  TempInt := APictureType'pos( TextImage );
  Encode( es, TempInt );
  Encode( es, bounds );
  Str255List.Queue( PictureFile, es );
  for y in bounds.top..bounds.bottom loop
      es := NullStr255;
      for x in bounds.left..bounds.right loop
          Encode( es, CGetChar( x, y ) ); -- fake for now
      end loop;
      Str255List.Queue( PictureFile, es );
  end loop;
  SaveList( path, PictureFile );
  Str255List.Clear( PictureFile );
  return APictureID( PictureList.Length( Pictures ) );
end SavePicture;

procedure DrawPicture( picture : APictureID; bounds : ARect ) is
  TempInt      : integer;
  PictureFile  : Str255List.List;
  es           : EncodedString;
  ThePicture   : APictureRecord;
  PictureWidth : integer;
  PictureHeight: integer;
  PictureType  : APictureType;
  PictureBounds: ARect;
  ch           : character;
begin
  PictureList.Find( Pictures, Str255List.AListIndex(Picture), ThePicture );
  LoadList( ThePicture.path, PictureFile );
  Str255List.Pull( PictureFile, es ); -- discard title
  Str255List.Pull( PictureFile, es ); -- rectangle
  Decode( es, TempInt );
  PictureType := APictureType'val( TempInt );
  Decode( es, PictureBounds );
  PictureWidth := PictureBounds.right - PictureBounds.left;
  if PictureWidth >= bounds.right - bounds.left then
     PictureWidth := bounds.right - bounds.left;
  end if;
  PictureHeight := PictureBounds.bottom - PictureBounds.top;
  if PictureHeight >= bounds.bottom - bounds.top then
     PictureHeight := bounds.bottom - bounds.top;
  end if;
  if PictureType = TextImage then
     for y in bounds.top..bounds.top + PictureHeight loop
         Str255List.Pull( PictureFile, es );
         MoveToGlobal( bounds.left, y );
         for x in bounds.left..bounds.left + PictureWidth loop
             Decode( es, ch );
             SpoolChar( ch );
         end loop;
     end loop;
  else -- unknown type
     EraseRect( bounds );
  end if;
  Str255List.Clear( PictureFile );
  if SpoolCounter = 0 then
     Refresh;
  end if;
end DrawPicture;

procedure ScreenDump is
  info : ADisplayInfoRec;
  scrn : ARect;
  id   : APictureID;
  pragma Unreferenced (Id);
begin
  GetDisplayInfo( info );
  scrn.top := 0;
  scrn.bottom := info.V_Res - 1;
  scrn.left := 0;
  scrn.right := info.H_Res - 1;
  id := SavePicture( To255( "./ScreenDump" ), GetTime, scrn );
  -- discard from stack (optional)
end ScreenDump;


---> Output Spooling


procedure WaitToReveal is
-- Increment the wait to reveal counter
begin
  --null; -- kludge for ncurses 1.9.9: spooling doesn't work right
  SpoolCounter := SpoolCounter + 1;
  -- NOTE: CSpoolRect is also klugded
end WaitToReveal;

procedure Reveal is
-- Decrement the wait to reveal counter, redraw if 0
begin
  -- kludge for ncurses 1.9.9: spooling doesn't work right
  if SpoolCounter > 0 then
     SpoolCounter := SpoolCounter - 1;
  end if;
  if SpoolCounter = 0 then
     Refresh;
  end if;
end Reveal;

procedure RevealNow is
-- Force a screen refresh of spooled data
begin
  Refresh;
end RevealNow;

procedure BlueBackground( blueOn : boolean ) is
begin
  NoError;
  BackgroundIsBlue := blueOn;
  if blueOn then
     SetColour( 0 );
  else
     SetColour( 1 );
  end if;
end BlueBackground;

function IsBlueBackground return boolean is
begin
  return BackgroundIsBlue;
end IsBlueBackground;

---> Housekeeping

procedure StartupUserIO is
-- Initialize this package, set defaults
begin
  NoError;
  if PackageRunning then
     return;
  end if;
  CurrentAngle := 0.0;
  ErrorLine := 2;
  SpoolCounter := 0;
  StartupCurses;
  CurrentPenColour := none;
  CurrentSize := 1;
  SetPenColour( outline );
  --if C_hasmouse = 1 then
  --   SessionLog( "StartupUserIO: GPM Mouse detected" );
  --else
  --   SessionLog( "StartupUserIO: No GPM Mouse was detected" );
  --end if;
  C_mousebutton := -1; -- clear input

  -- Load Macros

  if NotEmpty( MacroFile ) then
     LoadList( MacroFile, Macros );
     if LastError /= TT_OK then
        SessionLog( "StartupUserIO: Unable to load macro file ", LastError );
        AreMacros := false;
     else
        SessionLog( "StartupUserIO: macro file loaded" );
        AreMacros := true;
     end if;
  else
     SessionLog( "StartupUserIO: no macro file detected" );
     AreMacros := false;
  end if;
  MacroInProgress := false;

  -- Play Sounds?

  HasSounds := IsFile( SoundFlag );
  if HasSounds then
     SessionLog( "StartupUserIO: sound flag file detected" );
  else
     SessionLog( "StartupUserIO: no sound flag file detected" );
  end if;
  IdleJobsDone := false;
  CLS;
  CMoveTo( 0, 0 );
  PackageRunning := true;
  BackgroundIsBlue := true;
end StartupUserIO;

procedure IdleUserIO( IdlePeriod : ATimeStamp ) is
begin
  if IdlePeriod < 60 then -- do jobs once after 1 minute
     IdleJobsDone := false;
  elsif not IdleJobsDone then
     RevealNow;
     if AreMacros then
        Str255List.Compact( Macros );
     end if;
     PictureList.Compact( Pictures );
     InputList.Compact( InputQueue );
     IdleJobsDone := true;
  end if;
end IdleUserIO;

procedure ShutdownUserIO is
-- Shut down this package
begin
  NoError;
  if PackageRunning then
     if AreMacros then
        Str255List.Clear( Macros );
     end if;
     PictureList.Clear( Pictures );
     InputList.Clear( InputQueue );
     RevealNow;
     ShutdownCurses;
     PackageRunning := false;
  end if;
end ShutdownUserIO;

procedure ResetUserIO is
  -- call when refreshing desktop.  Clear curses cache.
begin
  ResetCurses;
  --ShutdownCurses;
  --StartupCurses;
  --CurrentPenColour := none;
  --CurrentSize := 1;
  --SetPenColour( outline );
end ResetUserIO;

end userio;