CLASS windows IS

 PASSIVE

pragmas

PRAGMA init_bloc
        (init_op => initialize)

spec

-- Dining Philosophers - Ada 95 edition
-- 
-- Manager for simple, nonoverlapping screen windows.
-- 
-- Michael B. Feldman, The George Washington University, July 1995.
-- HOOD version by Pierre Dissaux, TNI, June 1998.


--  required interface : 
--   Required OPERATION :
--     OPERATION : ClearScreen of object : screen
--     OPERATION : MoveCursor of object : screen
--     OPERATION : New_Line of object : text_io
--     OPERATION : Put of object : text_io
--   Required EXCEPTION : NONE
--   Required TYPE :
--     TYPE : Height of object : screen
--     TYPE : Width of object : screen
--     TYPE : Position of object : screen
--     TYPE : Character of object : standard
--     TYPE : String of object : standard
--   Required CONSTANT : NONE
--   Required DATA : NONE

--  visibility on required modules : 
with screen;
use type screen.Height;
use type screen.Width;
use type screen.Position;

package windows is

  type Window is private;

  -- Pre:        UpperLeft, Weight, and Width are defined
  -- Post:        returns a Window with the given upper-left corner, height, and width
  function open (
    UpperLeft : IN Screen.Position; 
    Height : IN Screen.Height; 
    Width : IN Screen.Width)
     return Window;

  -- Pre:         me, Name, and Under are defined
  -- Post:        Name is displayed at the top of the window me, underlined with the
  --  character Under
  procedure title (
    me : IN OUT Window; 
    Name : IN String; 
    Under : IN Character);

  -- Pre:        All parameters are defined
  -- Post:        Draw border around current writable area in window with characters
  --  specified. 
  --         Call this BEFORE Title.
  procedure borders (
    me : IN OUT Window; 
    Corner : IN Character; 
    Down : IN Character; 
    Across : IN Character);

  -- Pre:        me, and P are defined, and P lies within the area of me
  -- Post:        Cursor is moved to the specified position.
  --         Coordinates are relative to the upper left corner of me, which is (1,1)
  procedure movecursor (
    me : IN OUT Window; 
    P : IN Screen.Position);

  -- Pre:        me, and Ch are defined.
  -- Post:        Ch is displayed in the window at the next available position.
  --         If end of column, go to the next row.
  --         If end of window, go to the top of the window.
  procedure put (
    me : IN OUT Window; 
    Ch : IN Character);

  -- Pre:        me, and S are defined.
  -- Post:        Ch is displayed in the window, "line-wrapped" if necessary
  procedure put (
    me : IN OUT Window; 
    S : IN String);

  -- Pre:        me is defined.
  -- Post:        Cursor moves to beginning of next line of me;
  --         line is not blanked until next character is written
  procedure new_line (
    me : IN OUT Window);

private

  -- First : coordinates of upper left corner;
  -- Last : coordinates of lower right corner;
  -- Current : current cursor position.
  type Window is tagged 
  record 
    First : screen.Position;
    Last : screen.Position;
    Current : screen.Position;
  end record;

end windows;

body

-- Dining Philosophers - Ada 95 edition
-- 
-- Manager for simple, nonoverlapping screen windows.
-- 
-- Michael B. Feldman, The George Washington University, July 1995.
-- HOOD version by Pierre Dissaux, TNI, June 1998.


--  visibility on required modules : 
with text_io;

--  visibility on objects required by nested operation bodies : 

package body windows is

  -- Used to erase partially the screen.
  procedure erasetoendofline (
    me : IN OUT Window);

  -- Instanciates a new Window named "Result"
  -- Sets Result attributes (Current, First and Last)
  -- Returns Result.
  function open (
    UpperLeft : IN Screen.Position; 
    Height : IN Screen.Height; 
    Width : IN Screen.Width)
     return Window is
    Result : Window;
  begin
    Result.Current := UpperLeft;
    Result.First := UpperLeft;
    Result.Last := (Row => UpperLeft.Row + Height - 1,
                    Column => UpperLeft.Column + Width - 1);
    return Result;
  end open;

  -- Sets cursor at the beginning of first line.
  -- Writes title string
  -- If "Under" is blank then continue
  -- else draw a separation line
  -- Reduces writable area as required.
  procedure title (
    me : IN OUT Window; 
    Name : IN String; 
    Under : IN Character) is
  begin
  
    -- Put name on top line
    me.Current := me.First;
    Put(me, Name);
    New_Line(me);
  
    -- Underline name if desired, and reduce the writable area
    -- of the window by one line
    if Under = ' ' then
      -- no underlining
      me.First.Row := me.First.Row + 1;
    else
      -- go across the row, underlining
      for Count in me.First.Column..me.Last.Column loop
        Put(me, Under);
      end loop;
      New_Line(me);
      -- reduce writable area
      me.First.Row := me.First.Row + 2;
    end if;
  end title;

  -- Draws top line border.
  -- Draws the two side lines.
  -- Draws the bottom line of the border.
  -- Make the Window smaller by one character on each side.
  procedure borders (
    me : IN OUT Window; 
    Corner : IN Character; 
    Down : IN Character; 
    Across : IN Character) is
  begin
  
    -- Put top line of border
    Screen.MoveCursor(me.First);
    Text_IO.Put(Corner);
    for Count in me.First.Column+1 .. me.Last.Column-1 loop
      Text_IO.Put(Across);
    end loop;
    Text_IO.Put(Corner);
  
    -- Put the two side lines
    for Count in me.First.Row+1 .. me.Last.Row-1 loop
      Screen.MoveCursor((Row => Count,Column => me.First.Column));
      Text_IO.Put(Down);
      Screen.MoveCursor((Row => Count,Column => me.Last.Column));
      Text_IO.Put(Down);
    end loop;
  
    -- Put the bottom line of the border
    Screen.MoveCursor((Row => me.Last.Row,Column => me.First.Column));
    Text_IO.Put(corner);
    for Count in me.First.Column+1 .. me.Last.Column-1 loop
      Text_IO.Put (Across);
    end loop;
    Text_IO.Put(Corner);
  
    -- Make the Window smaller by one character on each side
    me.First := (Row => me.First.Row+1,Column => me.First.Column+1);
    me.Last := (Row => me.Last.Row-1,Column => me.Last.Column-1);
    me.Current := me.First;
  end borders;

  -- Cursor position passed as parameter is relative to window boundaries.
  procedure movecursor (
    me : IN OUT Window; 
    P : IN Screen.Position) is
  -- Relative to writable Window boundaries, of course
  begin
    me.Current.Row := me.First.Row + P.Row;
    me.Current.Column := me.First.Column + P.Column;
  end movecursor;

  -- If at end of current line then move to next line.
  -- If at beginning of current line then erase the entire line.
  -- Writes given character.
  procedure put (
    me : IN OUT Window; 
    Ch : IN Character) is
  begin
  
    -- If at end of current line, move to next line
    if me.Current.Column > me.Last.Column then
      if me.Current.Row = me.Last.Row then
        me.Current.Row := me.First.Row;
      else
        me.Current.Row := me.Current.Row + 1;
      end if;
      me.Current.Column := me.First.Column;
    end if;
  
    -- If at First char, erase line
    if me.Current.Column = me.First.Column then
      EraseToEndOfLine(me);
    end if;
  
    Screen.MoveCursor(To => me.Current);
  
    -- here is where we actually write the character!
    Text_IO.Put(Ch);
    me.Current.Column := me.Current.Column + 1;
  end put;

  -- Uses put#1 to write each character of the string.
  procedure put (
    me : IN OUT Window; 
    S : IN String) is
  begin
    for Count in S'Range loop
      Put(me, S (Count));
    end loop;
  end put;

  -- If cursor is at beginning of a line then first erase this line.
  -- If cursor is on last line then put it on first line.
  -- Else put it on next line.
  procedure new_line (
    me : IN OUT Window) is
  begin
    if me.Current.Column = 1 then
      EraseToEndOfLine(me);
    end if;
    if me.Current.Row = me.Last.Row then
      me.Current.Row := me.First.Row;
    else
      me.Current.Row := me.Current.Row + 1;
    end if;
    me.Current.Column := me.First.Column;
  end new_line;

  -- Puts blank characters from current cursor position to the end of current
  --  line.
  -- Current cursor position remains unchanged.
  procedure erasetoendofline (
    me : IN OUT Window) is
  begin
    Screen.MoveCursor (me.Current);
      for Count in me.Current.Column .. me.Last.Column loop
        Text_IO.Put (' ');
      end loop;
    Screen.MoveCursor (me.Current);
  end erasetoendofline;

begin
  Text_IO.New_Line;
  Screen.ClearScreen;
  Text_IO.New_Line;

end windows;

END windows