--::::::::::
--screen.ads
--::::::::::
package Screen is

  -- simple ANSI terminal emulator
  -- Michael Feldman, The George Washington University
  -- July, 1995

  ScreenHeight : constant Integer := 24;
  ScreenWidth : constant Integer := 80;

  subtype Height is Integer range 1..ScreenHeight;
  subtype Width  is Integer range 1..ScreenWidth;

  type Position is record
    Row   : Height := 1;
    Column: Width := 1;
  end record;

  procedure Beep; 
  -- Pre:  none
  -- Post: the terminal beeps once
  
  procedure ClearScreen; 
  -- Pre:  none
  -- Post: the terminal screen is cleared
  
  procedure MoveCursor (To: in Position);
  -- Pre:  To is defined
  -- Post: the terminal cursor is moved to the given position
  
end Screen;   


--::::::::::
--arrival.adb
--::::::::::
with Bricks, Wall, Calendar; 
with Text_IO;

package body Arrival is 

   Initial_Delay : constant := 0.6; 
   Delay_Time    : Duration; 

   type Unsigned is range 0..2**16;

   use Calendar;
   Seed : Unsigned := Unsigned(FLOAT(Seconds(Clock))/10.0); -- in range

   function Cheap_Random return Integer is
   begin
      Seed := (Seed * 25173 + 13849) mod 2**16;
      return Integer(Seed mod 2**15);
   end Cheap_Random;


   task body Manager is 
      Style : Wall.Styles; 
      Done  : Boolean;  
   begin
      Outer : loop
         Text_IO.Put_Line("Manager");
         accept Start; 
         Middle : loop
            Style := Wall.Styles(Cheap_Random mod Wall.Styles'LAST + 1); 
            select
               accept Tick; 
            or 
               accept Stop; 
               exit Middle;
            or
               delay Delay_Time;
            end select; 
            Bricks.Move.Put(X     => 5, 
                            Y     => 2, 
                            Brick => Wall.Pick(Style), 
                            Done  => Done); 
            if Done then 
               accept Stop; 
               exit Middle; 
            end if; 
            for Y in Wall.Height'First + 1 .. Wall.Height'Last loop
               declare
                  Ok : Boolean; 
               begin
                  select
                     accept Tick;
                  or
                     accept Stop; 
                     exit Middle; 
                  or 
                     delay Delay_Time;
                  end select;
                  Bricks.Move.Drop(Ok); 
                  if not Ok then 
                     exit; 
                  end if; 
               end; 
            end loop; 
            Wall.Erase_Lines; 
         end loop Middle; 
      end loop Outer; 
   exception 
      when others => Text_IO.Put_Line("Manager error");
   end Manager; 

   task body Timer is 
   begin
      Outer : loop
         Delay_Time := Initial_Delay; 
         Text_IO.Put_Line("Timer");
         accept Start; 
         Main : loop
            select
               accept Stop; 
               exit Main;
            or 
               delay Delay_Time; 
            end select; 
            select
               Manager.Tick; 
            else
               null;
            end select;
         end loop Main;
      end loop Outer; 
   exception 
      when others => Text_IO.Put_Line("Timer error");
   end Timer; 


   task body Speeder is 
   begin
      Delay_Time := Initial_Delay; 
      Outer : loop
         Text_IO.Put_Line("Speeder");
         accept Start; 
         Middle : loop
            for I in 1 .. 100 loop
               select
                  accept Stop; 
                  exit Middle; 
               or 
                  delay Delay_Time; 
               end select; 
            end loop; 
            Delay_Time := Delay_Time*9/10; 
         end loop Middle; 
      end loop Outer; 
   exception 
      when others => Text_IO.Put_Line("Speeder error");
   end Speeder; 

end Arrival; 


--::::::::::
--arrival.ads
--::::::::::
package Arrival is         
   pragma Elaborate_Body;

   task Manager is         -- Starts the dropping bricks 
      pragma Priority(8); 
      entry Tick; 
      entry Start; 
      entry Stop; 
   end Manager; 

   task Timer is           -- Timing between events
      pragma Priority(6); 
      entry Start; 
      entry Stop; 
   end Timer; 

   task Speeder is         -- Picks up the pace after certain time
      pragma Priority(7);  
      entry Start; 
      entry Stop; 
   end Speeder; 

end Arrival; 


--::::::::::
--bricks.adb
--::::::::::
with Text_IO;
with Screen;
package body Bricks is 
   Finished_Flag : Boolean := False; 

   function Finished return Boolean is 
   begin
      return Finished_Flag; 
   end Finished; 

   task body Move is 
      X, NX            : Wall.Width; 
      Y, NY            : Wall.Height; 
      New_Brick, Brick : Wall.Brick_Type; 
      Exit_Flag        : Boolean := False; 

      procedure Rotate(Brick     : in     Wall.Brick_Type; 
                       New_Brick :    out Wall.Brick_Type) is 
         X, Y : Integer; 
         B    : Wall.Brick_Type; 
      begin
         for I in Brick'range loop
            X := Brick(I).Y + 1; 
            Y :=  -(Brick(I).X - 1); 
            B(I).X := X; 
            B(I).Y := Y; 
         end loop; 
         New_Brick := B; 
      end Rotate; 

   begin
      Outer : loop
         Text_IO.Put_Line("Move");
         accept Start; 
         Finished_Flag := False; 
         Middle : loop
            Exit_Flag := False; 
            accept Put(X     : in     Wall.Width; 
                       Y     : in     Wall.Height; 
                       Brick : in     Wall.Brick_Type; 
                       Done  :    out Boolean) do
               if Wall.Examine(Brick, X, Y) then 
                  Done := False; 
               else 
                  Done := True; 
                  Finished_Flag := True; 
                  Screen.MoveCursor((Column => 10, Row => 12));
                  Text_IO.Put_Line ("Try Again [Y/N] ?");
               end if; 
               Move.X := X; 
               Move.Y := Y; 
               Move.Brick := Brick; 
            end Put; 
            Wall.Put(Brick, X, Y); 
            Inner : loop
               select
                  accept Right do
                     if X < Wall.Width'Last then 
                        NX := X + 1; 
                        if Wall.Examine(Brick, NX, Y) then 
                           Wall.Erase(Brick, X, Y); 
                           X := NX; 
                           Wall.Put(Brick, X, Y); 
                        end if; 
                     end if; 
                  end Right; 
               or 
                  accept Left do
                     if Wall.Width'First < X then 
                        NX := X - 1; 
                        if Wall.Examine(Brick, NX, Y) then 
                           Wall.Erase(Brick, X, Y); 
                           X := NX; 
                           Wall.Put(Brick, X, Y); 
                        end if; 
                     end if; 
                  end Left; 
               or 
                  accept Rotation do
                     Rotate(Brick, New_Brick); 
                     if Wall.Examine(New_Brick, X, Y) then 
                        Wall.Erase(Brick, X, Y); 
                        Brick := New_Brick; 
                        Wall.Put(Brick, X, Y); 
                     end if; 
                  end Rotation; 
               or 
                  accept Drop(Ok : out Boolean) do
                     NY := Y + 1; 
                     if Wall.Examine(Brick, X, NY) then 
                        Wall.Erase(Brick, X, Y); 
                        Y := NY; 
                        Wall.Put(Brick, X, Y); 
                        Ok := True; 
                     else 
                        Wall.Place(Brick, X, Y); 
                        Ok := False; 
                        Exit_Flag := True; 
                     end if; 
                  end Drop; 
               or 
                  accept Stop; 
                  exit Middle; 
               end select; 
               if Exit_Flag then 
                  select
                     accept Drop(Ok : out Boolean) do
                        Ok := FALSE;
                     end Drop;
                  or
                     delay 1.0;
                  end select;
                  exit Inner; 
               end if; 
            end loop Inner; 
         end loop Middle; 
      end loop Outer; 
   exception 
      when others => Text_IO.Put_Line("Move error");
   end Move; 

end Bricks; 


--::::::::::
--bricks.ads
--::::::::::
with Wall;
package Bricks is 
   pragma Elaborate_Body;

   function Finished return Boolean; 

   task Move is            -- User moves bricks according to key pressed
      pragma Priority(5); 
      entry Start; 
      entry Put(X     : in     Wall.Width; 
                Y     : in     Wall.Height; 
                Brick : in     Wall.Brick_Type; 
                Done  :    out Boolean); 
      entry Right; 
      entry Left; 
      entry Rotation; 
      entry Drop(Ok : out Boolean); 
      entry Stop; 
   end Move; 

end Bricks; 


--::::::::::
--screen.adb
--::::::::::
with Text_IO;
package body Screen is

  -- simple ANSI terminal emulator
  -- Michael Feldman, The George Washington University
  -- July, 1995

  -- These procedures will work correctly only if the actual
  -- terminal is ANSI compatible. ANSI.SYS on a DOS machine
  -- will suffice.

  package Int_IO is new Text_IO.Integer_IO (Num => Integer);

  procedure Beep is
  begin
    Text_IO.Put (Item => ASCII.BEL);
  end Beep;

  procedure ClearScreen is
  begin
    Text_IO.Put (Item => ASCII.ESC);
    Text_IO.Put (Item => "[2J");
  end ClearScreen;

  procedure MoveCursor (To: in Position) is
  begin                                                
    Text_IO.New_Line;
    Text_IO.Put (Item => ASCII.ESC);
    Text_IO.Put ("[");
    Int_IO.Put (Item => To.Row, Width => 1);
    Text_IO.Put (Item => ';');
    Int_IO.Put (Item => To.Column, Width => 1);
    Text_IO.Put (Item => 'f');
  end MoveCursor;  

end Screen;


--::::::::::
--tetris.adb
--::::::::::
with Screen, Bricks, Wall, Arrival, Text_IO; 
procedure Tetris is 

   pragma Priority(4); 

   Ch : Character; 
   Available : Boolean;
   Ok : Boolean; 

begin
   loop
      Screen.ClearScreen; 

      Wall.Initialize; 
      Screen.MoveCursor((Column => 10, Row => 3)); 
      Text_IO.Put_Line( " TETRIS Ada " );
      Screen.MoveCursor((Column => 1, Row => 5)); 
      Text_IO.Put_Line( "2=drop 4=left 5=spin 6=right");

      Bricks.Move.Start; 
      Arrival.Manager.Start; 
      Arrival.Timer.Start; 
      Arrival.Speeder.Start; 

      Outer : loop
         loop
            Get_Immediate(Ch, Available);
            exit when Available;
            delay 0.01;
         end loop;
         exit Outer when Bricks.Finished; 
         case Ch is 
            when '2' => -- Down arrow
               loop
                  select
                     Bricks.Move.Drop(Ok); 
                  else
                     Ok := TRUE; -- Keep dropping the brick
                  end select;
                  exit when not Ok; 
               end loop; 
               delay 1.0;
            when '4' => -- Left arrow
               select
                  Bricks.Move.Left; 
               else 
                  null; 
               end select; 
            when '5' => -- blank
               select
                  Bricks.Move.Rotation; 
               else 
                  null; 
               end select; 
            when '6' => -- Right arrow
               select
                  Bricks.Move.Right; 
               else 
                  null; 
               end select; 
            when others => 
               null; 
         end case; 
      end loop Outer; 

      Arrival.Speeder.Stop; 
      Arrival.Timer.Stop; 
      Bricks.Move.Stop; 
      Arrival.Manager.Stop; 

      exit when Ch /= 'Y' and Ch /= 'y';

   end loop; 

   Screen.ClearScreen;
   abort Bricks.Move; 
   abort Arrival.Timer; 
   abort Arrival.Manager; 
   abort Arrival.Speeder; 

end Tetris; 


--::::::::::
--wall.adb
--::::::::::
with Screen, Text_IO; 
package body Wall is 

   subtype Width_Inner is Width range 
      Width'Succ(Width'First) .. Width'Pred(Width'Last); 
   subtype Height_Inner is Height range 
      Height'First .. Height'Pred(Height'Last); 

   Pick_Array : array(Styles) of Brick_Type := 
    (((-1, 1), (0, 1), (1, 1), (2, 1)), -- Long
     ((0, 0), (0, 1), (0, 2), (1, 2)), 
     ((0, 0), (1, 0), (0, 1), (0, 2)), 
     ((0, 0), (0, 1), (1, 0), (1, 1)),  -- Square
     ((0, 0), (0, 1), (1, 1), (1, 2)), 
     ((1, 0), (1, 1), (0, 1), (0, 2)), 
     ((1, 0), (0, 1), (1, 1), (1, 2))); 

   type Line is array(Width) of BOOLEAN; 
   type Wall_Type is array(Height) of Line; 
   Tetris_Wall : Wall_Type; 

   function Pick ( Style : in Styles ) return Brick_Type is
   begin
      return Pick_Array ( Style );
   end Pick;

   procedure Put_Wall is 
      Tetris_Piece : BOOLEAN; 
   begin
      for Y in Height'First .. Height'Last loop
         for X in Width'First .. Width'Last loop
            Tetris_Piece := Tetris_Wall(Y)(X); 
            Screen.MoveCursor((Column => 30 + X*2, Row => 2 + Y)); 
            if Y in Height_Inner'First .. Height_Inner'Last and 
               X in Width_Inner'First .. Width_Inner'Last then 
               if Tetris_Piece then
                  Text_IO.Put_Line("[]");
               else
                  Text_IO.Put_Line("  ");
               end if;
            else 
               Text_IO.Put_Line("##");
            end if; 
         end loop; 
      end loop; 
   end Put_Wall; 

   procedure Initialize is 
   begin
      for I in Height'First .. Height'Last - 1 loop
         Tetris_Wall(I) := 
           (Width'First | Width'Last                          => TRUE, 
            Width'Succ(Width'First) .. Width'Pred(Width'Last) => FALSE); 
      end loop; 
      Tetris_Wall(Height'Last) := (others => TRUE); 
      Put_Wall; 
   end Initialize; 

   procedure Put(Brick : in Brick_Type; 
                 X     : in Width; 
                 Y     : in Height) is 
      Bx, By : Natural; 
   begin
      for I in Brick'range loop
         Bx := X + Brick(I).X; 
         By := Y + Brick(I).Y; 
         Screen.MoveCursor((Column => 30 + Bx*2, Row => 2 + By)); 
         Text_IO.Put_Line("[]");
      end loop; 
   end Put; 

   procedure Put(X     : in Width; 
                 Y     : in Height; 
                 Attr  : in BOOLEAN) is 
   begin
      Screen.MoveCursor((Column => 30 + X*2, Row => 2 + Y)); 
      if Attr then
         Text_IO.Put_Line("[]");
      else
         Text_IO.Put_Line("--");
      end if;         
   end Put; 

   procedure Erase(Brick : in Brick_Type; 
                   X     : in Width; 
                   Y     : in Height) is 
      Bx, By : Natural; 
   begin
      for I in Brick'range loop
         Bx := X + Brick(I).X; 
         By := Y + Brick(I).Y; 
         Screen.MoveCursor((Column => 30 + Bx*2, Row => 2 + By)); 
         Text_IO.Put_Line("  ");
      end loop; 
   end Erase; 

   procedure Place(Brick : in Brick_Type; 
                   X     : in Width; 
                   Y     : in Height) is 
      Bx, By : Natural; 
   begin
      for I in Brick'range loop
         Bx := X + Brick(I).X; 
         By := Y + Brick(I).Y; 
         Tetris_Wall(By)(Bx) := TRUE; 
      end loop; 
   end Place; 

   function Examine(Brick : in Brick_Type; 
                    X     : in Width; 
                    Y     : in Height) return Boolean is 
      Bx, By : Natural; 
   begin
      for I in Brick'range loop
         Bx := X + Brick(I).X; 
         By := Y + Brick(I).Y; 
         if not (Bx in Width_Inner) or else not (By in Height_Inner) then 
            return False; 
         elsif Tetris_Wall(By)(Bx) then 
            return False; 
         end if; 
      end loop; 
      return True; 
   end Examine; 

   procedure Erase_Lines is 
      Line_No     : array(Height_Inner) of Height_Inner; 
      No_Of_Lines : Natural := Height_Inner'First - 1; 
      Attribute   : BOOLEAN := TRUE;
   begin
      for Y in Height_Inner loop
         for X in Width_Inner loop
            exit when not Tetris_Wall(Y)(X); 
            if X = Width_Inner'Last then 
               No_Of_Lines := No_Of_Lines + 1; 
               Line_No(No_Of_Lines) := Y; 
            end if; 
         end loop; 
      end loop; 
      if Height_Inner'First <= No_Of_Lines then 
         for I in 1 .. 8 loop
            Attribute := not Attribute;
            for I in Height_Inner'First .. No_Of_Lines loop
               for X in Width_Inner loop
                  Put(X, Line_No(I), Attribute); 
               end loop; 
            end loop; 
            delay 0.1; 
         end loop; 
         for I in Height_Inner'First .. No_Of_Lines loop
            Tetris_Wall(Height_Inner'First + 1 .. Line_No(I)) := 
               Tetris_Wall(Height_Inner'First .. Line_No(I) - 1); 
         end loop; 
         Put_Wall; 
      end if; 
   end Erase_Lines; 

end Wall; 


--::::::::::
--wall.ads
--::::::::::
package Wall is 

   subtype Styles is INTEGER range 1..7;

   type Brick_Section is 
      record
         Y, X : Integer; 
      end record; 

   type Brick_Type is array(1 .. 4) of Brick_Section; 

   function Pick ( Style : in Styles ) return Brick_Type;

   subtype Width is Integer range 0 .. 11; 
   subtype Height is Integer range 1 .. 21; 

   procedure Initialize; 

   procedure Put(Brick : in Brick_Type; 
                 X     : in Width; 
                 Y     : in Height); 

   procedure Erase(Brick : in Brick_Type; 
                   X     : in Width; 
                   Y     : in Height); 

   procedure Place(Brick : in Brick_Type; 
                   X     : in Width; 
                   Y     : in Height); 

   function Examine(Brick : in Brick_Type; 
                    X     : in Width; 
                    Y     : in Height) return Boolean; 

   procedure Erase_Lines; 


end Wall; 


--::::::::::
--wtetris.ads
--::::::::::
-- Version for Win95 or WinNt in DOS mode
with Win_Get_Immediate;
with Tetris;
procedure WTetris is new Tetris(Win_Get_Immediate);


--::::::::::
--tetris.ads
--::::::::::
--	Tetris Ada
--
-- This version of Tetris uses Ada tasking and a text-mode screen.
-- 
-- Before running, note the following:
--  1. You must have ANSI screen character handling (i.e. ANSI.SYS for DOS)
--     ANSI.SYS is apparently built-in for Win95 and OS2 
--  2. Use the numeric key-pad arrows (i.e. NumLock on DOS).
--     Otherwise, use the numeric keys: 2=down, 4=left, 5=rotate, 6=right
--
-- Portability issues:
--  1. Get_Immediate is non-portable code for getting chars.
--     Instantiate generic Tetris with version appropriate for OS
generic
   with procedure Get_Immediate( Item : out CHARACTER;
                                 Available : out BOOLEAN );
procedure Tetris;


--::::::::::
--Win_Get_Immediate.ads
--::::::::::
procedure Win_Get_Immediate( Item : out CHARACTER;
                             Available : out BOOLEAN );


--::::::::::
--Win_Get_Immediate.adb
--::::::::::
procedure Win_Get_Immediate ( Item : out CHARACTER;
                              Available : out BOOLEAN ) is
   function getch return INTEGER;
     pragma Import(C, getch, "_getch");   -- from Win32.ConIO
   function kbhit return INTEGER;    
     pragma Import(C, kbhit, "_kbhit");   -- from Win32.ConIO
begin
   Available := kbhit /= 0;
   if Available then
      Item := CHARACTER'VAL(getch);
   end if;
end Win_Get_Immediate;


--::::::::::
--dtetris.adb
--::::::::::
-- Version for DOS/DJGPP GNAT compiler
with DOS_Get_Immediate;
with Tetris;
procedure DTetris is new Tetris(DOS_Get_Immediate);


--::::::::::
--atetris.ads
--::::::::::
-- Version using builtin Get_Immediate of Ada 95
-- This will work only if Get_Immediate is implemented correctly,
-- such as on Solaris GNAT

with Ada.Text_IO;
with Tetris;
procedure ATetris is new Tetris(Ada.Text_IO.Get_Immediate);


--::::::::::
--dogetimm.ads
--::::::::::
procedure DOS_Get_Immediate( Item : out CHARACTER;
                             Available : out BOOLEAN );


--::::::::::
--dogetimm.adb
--::::::::::
procedure DOS_Get_Immediate( Item : out CHARACTER;
                             Available : out BOOLEAN ) is
   function getkey ( Cmd : in INTEGER ) return INTEGER;
   pragma Import(C, getkey, "bioskey");
begin
   if getkey(1) = 0 then
      Available := FALSE;
   else
      Item := CHARACTER'VAL(getkey(0) mod 16#100#); 
      Available := TRUE;
   end if;
end DOS_Get_Immediate;


--::::::::::
--openget.adb
--::::::::::
with TTY;
procedure OpenAda_Get_Immediate( Item : out CHARACTER;
                                 Available : out BOOLEAN ) is
begin
   Available := FALSE;
   if TTY.Char_Ready then
      Item := TTY.Get(No_Echo => TRUE);
      Available := TRUE;
   end if;
end OpenAda_Get_Immediate;


--::::::::::
--openget.ads
--::::::::::
procedure OpenAda_Get_Immediate( Item : out CHARACTER;
                                 Available : out BOOLEAN );


--::::::::::
--otetris.ads
--::::::::::
-- Version of Tetris for OpenAda for DOS (Ada 83 compiler)
with OpenAda_Get_Immediate;
with Tetris;
procedure OTetris is new Tetris(OpenAda_Get_Immediate);