performance measurements

Each table row shows performance measurements for this Ada 2005 GNAT program with a particular command-line input value N.

 N  CPU secs Elapsed secs Memory KB Code B ≈ CPU Load
2,0980.080.09?7416  0% 0% 0% 91%

Read the ↓ make, command line, and program output logs to see how this program was run.

Read meteor-contest benchmark to see what this program should do.

 notes

GNAT 4.6

gcc version 4.8.2 (Ubuntu 4.8.2-19ubuntu1)

 meteor-contest Ada 2005 GNAT program source code

-- The Computer Language Benchmarks Game
-- http://benchmarksgame.alioth.debian.org/
--
-- Translation of the C++ version of Ben St. John
-- by Francois Fabien (novembre 2011)
--  + addition of the incomplete search of solutions.
--
-- Expected build command:
-- gnatchop -w meteor.gnat
-- gnatmake  -O3 -gnatp -gnatn -f meteor.adb -o meteor.gnat_run -largs -s
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
with Interfaces; use Interfaces;

package Meteors is

   N_COL : constant := 5;
   N_ROW : constant := 10;

   N_ELEM : constant := 5;
   N_PIECE_TYPE : constant := 10;
   type Ext_Piecenr is range 0 .. N_PIECE_TYPE;
   for Ext_Piecenr'Size use 8;

   No_Piece : constant Ext_Piecenr := N_PIECE_TYPE;

   subtype Piecenr is Ext_Piecenr range 0 .. N_PIECE_TYPE - 1;

   N_ORIENT : constant := 12;
   type ExtOrientation is range -1 .. N_ORIENT - 1;
   for ExtOrientation'Size use 8;
   subtype Orientation is ExtOrientation range 0 .. N_ORIENT - 1;

   type Trow is range 0 .. N_ROW - 1;
   for Trow'Size use 8;
   type Tcol is range 0 .. N_COL - 1;
   for Tcol'Size use 8;

   type Parity is (Even, Odd);
   for Parity'Size use 8;
   for Parity use (Even => 0, Odd => 1);

   -- warning => First row is Trow = 0 and is even
   function Row_Parity (R : Trow) return Parity;
   pragma Inline_Always(Row_Parity);
   function Parity_to_Row is new Ada.Unchecked_Conversion (Parity, Trow);


   type TElement is range 0 .. N_ELEM - 1;
   for TElement'Size use 8;

   type Dimensions is (dimx, dimy);
   -- Coordinates of the points of a given element
   type TPts is array (TElement, Dimensions) of Integer_8;

   type BitVecs is new Unsigned_32;

   function toBitVector (pts : TPts) return BitVecs;
   pragma Inline(ToBitVector);
   function setCoordList (vec : in BitVecs) return TPts;


   function Get_First_One
     (V        : BitVecs;
      Startpos : Natural := 0)
      return     Natural;
   pragma Inline(Get_First_One);

   S_FirstOne : constant array (0 .. 31) of Natural := (
   0, 0, 1, 0,   2, 0, 1, 0,   3, 0, 1, 0,   2, 0, 1, 0,
   4, 0, 1, 0,   2, 0, 1, 0,   3, 0, 1, 0,   2, 0, 1, 0);
end Meteors;
------------------------------------------------------------------------------

package body Meteors is

   function Row_Parity (R : Trow) return Parity is
      function Unsigned_To_Parity is new Ada.Unchecked_Conversion (
         Unsigned_8,
         Parity);
   begin
      return Unsigned_To_Parity (Unsigned_8 (R) and 1);
   end Row_Parity;

   function toBitVector (pts : TPts) return BitVecs is
      Result : BitVecs := 0;
      x, y   : Integer_8;
   begin
      for Element in TElement'Range loop
         x      := pts (Element, dimx);
         y      := pts (Element, dimy);
         Result := Result or Shift_Left (1, Natural (y * N_COL + x));
      end loop;
      return Result;
   end toBitVector;

   function setCoordList (vec : in BitVecs) return TPts is
      iPt  : TElement := 0;
      Mask : BitVecs  := 1;
      Pts  : TPts;

   begin

      Outer : for y in Trow'Range loop
         for x in Tcol'Range loop
            if ((Mask and vec) /= 0) then
               Pts (iPt, dimx) := Integer_8 (x);
               Pts (iPt, dimy) := Integer_8 (y);
               exit Outer when iPt = TElement'Last;
               iPt := iPt + 1;
            end if;
            Mask := Shift_Left (Mask, 1);
         end loop;
      end loop Outer;
      return Pts;
   end setCoordList;

   function Get_First_One
     (V        : BitVecs;
      Startpos : Natural := 0)
      return     Natural
   is
      IPos              : Natural := Startpos;
      mask              : BitVecs;
      Result, Resultlow : BitVecs;
   begin
      if V = 0 then
         return 0;
      end if;

      mask := Shift_Left (16#ff#, Startpos);
      while (mask and V) = 0 loop
         mask := Shift_Left (mask, 8);
         IPos := IPos + 8;
      end loop;

      Result    := Shift_Right (mask and V, IPos);
      Resultlow := Result and 16#0f#;
      if Resultlow /= 0 then
         IPos := IPos + S_FirstOne (Integer (Resultlow));
      else
         IPos := IPos + 4 + S_FirstOne (Integer (Shift_Right (Result, 4)));
      end if;
      return IPos;
   end Get_First_One;

end Meteors;
------------------------------------------------------------------------------
--   Operations On Pieces
------------------------------------------------------------------------------
package Meteors.Pieces is

   SKIP_PIECE : constant := 5;
   type Instance is record
      m_allowed : Unsigned_64 :=0;
      m_vec     : BitVecs     :=0;
      m_offset  : Integer_8   :=0;
   end record;

   type M_Instance_Type is array (Parity) of Instance;

   type Piece is record
      m_instance : M_Instance_Type;
   end record;

   s_basePiece : array (Piecenr, Orientation) of Piece;

   BaseVecs : constant array (Piecenr) of BitVecs :=
     (16#10f#, 16#0cb#,  16#1087#, 16#427#, 16#465#,
      16#0c7#, 16#8423#, 16#0a7#,  16#187#, 16#08f#);

   function getPiece
     (IPiece  : Piecenr;
      iOrient : Orientation;
      iParity : Parity)
      return    Instance;

   procedure gen_orientation
     (vec     : BitVecs;
      iOrient : Orientation;
      target  : in out Piece);
   procedure shiftUpLines (pts : in out TPts; shift : Integer_8);
   procedure shiftToX0
     (pts       : in out TPts;
      Inst      : in out Instance;
      Offsetrow : Integer_8;
      W         : out Integer_8);
   procedure Set_Ok_Positions
     (Self  : in out Piece;
      isOdd : Parity;
      W, H  : Integer_8);
   procedure Gen_All_Orientations;

   type NPieces_Type is array (Piecenr) of ExtOrientation;
   type PieceVec_Type is array (Piecenr, Orientation) of BitVecs;

   type OkPieces is record
      nPieces  : NPieces_Type  := (others => -1); -- -1 for empty piecevec
      pieceVec : PieceVec_Type := (others => (others => 0));
   end record;

   g_okPieces        : array (Trow, Tcol) of OkPieces;

end Meteors.Pieces;
------------------------------------------------------------------------------
with Meteors.Board; use Meteors.Board;
package body Meteors.Pieces is

   function floor (top, bottom : Integer_8) return Integer_8 is
      toZero : Integer_8;
   begin
      toZero := top / bottom;
      --  negative numbers should be rounded down, not towards zero
      if (toZero * bottom /= top) and ((top < 0) xor (bottom <= 0)) then
         toZero := toZero - 1;
      end if;
      return toZero;
   end floor;

   function getPiece
     (IPiece  : Piecenr;
      iOrient : Orientation;
      iParity : Parity)
      return    Instance
   is
   begin
      return s_basePiece (IPiece, iOrient).m_instance (iParity);
   end getPiece;
   pragma Inline (getPiece);

   procedure gen_orientation
     (vec     : BitVecs;
      iOrient : Orientation;
      target  : in out Piece)
   is
      pts        : TPts;
      X, Y       : Integer_8;
      H, W       : Integer_8;
      Ymin, Ymax : Integer_8;
      rot        : Orientation;
      Even_inst  : Instance renames target.m_instance (Even);
      Odd_inst   : Instance renames target.m_instance (Odd);
   begin
      --  get (x,y) coordinates
      pts := setCoordList (vec);

      -- flip
      if (iOrient >= 6) then
         for iPt in TElement'Range loop
            pts (iPt, dimy) := -pts (iPt, dimy);
         end loop;
      end if;

      --  rotate as necessary
      rot := iOrient mod 6;
      while rot > 0 loop

         for iPt in TElement'Range loop
            X := pts (iPt, dimx);
            Y := pts (iPt, dimy);

            --  I just worked this out by hand. Took a while.
            pts (iPt, dimx) := floor ((2 * X - 3 * Y + 1), 4);
            pts (iPt, dimy) := floor ((2 * X + Y + 1), 2);
         end loop;
         rot := rot - 1;
      end loop;

      --  determine vertical shift
      Ymin := pts (0, dimy);
      Ymax := Ymin;
      for iPt in TElement'Range loop
         Y := pts (iPt, dimy);

         if Y < Ymin then
            Ymin := Y;
         elsif Y > Ymax then
            Ymax := Y;
         end if;
      end loop;
      H := Ymax - Ymin;

      shiftUpLines (pts, Ymin);
      shiftToX0 (pts, Even_inst, 0, W);
      Set_Ok_Positions (target, Even, W, H);
      Even_inst.m_vec :=
         Shift_Right (Even_inst.m_vec, Natural (Even_inst.m_offset));

      -- shift down one line
      shiftUpLines (pts, -1);
      shiftToX0 (pts, Odd_inst, 1, W);

      -- shift the bitmask back one line
      Odd_inst.m_vec := Shift_Right (Odd_inst.m_vec, N_COL);
      Set_Ok_Positions (target, Odd, W, H);
      Odd_inst.m_vec :=
         Shift_Right (Odd_inst.m_vec, Natural (Odd_inst.m_offset));
   end gen_orientation;

   procedure shiftUpLines (pts : in out TPts; shift : Integer_8) is
   begin
      --  vertical shifts have a twist if shift is odd and Y is odd
      for iPt in TElement'Range loop
         if (shift mod 2 = 1) and (pts (iPt, dimy) mod 2) = 1 then
            pts (iPt, dimx) := pts (iPt, dimx) + 1;
         end if;
         pts (iPt, dimy) := pts (iPt, dimy) - shift;
      end loop;
   end shiftUpLines;

   procedure shiftToX0
     (pts       : in out TPts;
      Inst      : in out Instance;
      Offsetrow : Integer_8;
      W         : out Integer_8)
   is
      x          : Integer_8;
      Offset     : Integer_8;
      Xmin, Xmax : Integer_8 := pts (0, dimx);
   begin
      --determine shift
      for iPt in 1 .. TElement'Last loop
         x := pts (iPt, dimx);
         if x < Xmin then
            Xmin := x;
         elsif x > Xmax then
            Xmax := x;
         end if;
      end loop;

      Offset := N_ELEM;
      for iPt in TElement'Range loop

         pts (iPt, dimx) := pts (iPt, dimx) - Xmin;
         --  check offset -- leftmost cell on top line
         if (pts (iPt, dimy) = Offsetrow) and
            (pts (iPt, dimx) < Offset)
         then
            Offset := pts (iPt, dimx);
         end if;
      end loop;

      Inst.m_offset := Offset;
      Inst.m_vec    := toBitVector (pts);
      W             := Xmax - Xmin;
   end shiftToX0;

   procedure Set_Ok_Positions
     (Self  : in out Piece;
      isOdd : Parity;
      W, H  : Integer_8)
   is
      Y        : Integer_8;
      Inst     : Instance renames Self.m_instance (isOdd);
      PosMask  : Unsigned_64 :=
         Shift_Left (1, N_COL * Natural (Parity_to_Row (isOdd)));
      PieceVec : BitVecs;
   begin
      Inst.m_allowed := 0;

      Y := Integer_8 (Parity_to_Row (isOdd));
      while Y < N_ROW - H loop

         if Inst.m_offset /= 0 then
            PosMask := Shift_Left (PosMask, Natural (Inst.m_offset));
         end if;

         for Xpos in 0 .. (N_COL - 1 - Inst.m_offset) loop
            --  check if the new position is on the board

            if Xpos < (N_COL - W) then
               --move it to the desired location
               PieceVec := Shift_Left (Inst.m_vec, Natural (Xpos));
               if not Has_Bad_Islands_Single (PieceVec, Trow (Y)) then
                  -- position is allowed
                  Inst.m_allowed := Inst.m_allowed or PosMask;
               end if;
            end if;
            PosMask := Shift_Left (PosMask, 1);
         end loop;

         exit when (Y > N_ROW - 3);
         Y       := Y + 2;
         PosMask := Shift_Left (PosMask, N_COL);
      end loop;

   end Set_Ok_Positions;

   procedure Gen_All_Orientations is
      refpiece  : BitVecs;
      n, npiece : Unsigned_8 := 0;
      Mask      : Unsigned_64;
      Inst      : Instance;
   begin
      -- Filling s_basePiece
      for iPiece in Piecenr'Range loop
         refpiece := BaseVecs (iPiece);
         for iOrient in Orientation'Range loop
            declare
               P : Piece renames s_basePiece (iPiece, iOrient);
            begin
               gen_orientation (refpiece, iOrient, P);
               if (iPiece = SKIP_PIECE) and
                  ((Unsigned_8 (iOrient / 3) and 1) /= 0)
               then
                  P.m_instance (Even).m_allowed := 0;
                  P.m_instance (Odd).m_allowed  := 0;
               end if;
            end;
         end loop;
      end loop;

      -- Filling array g_okPieces
      for iPiece in Piecenr'Range loop
         for iOrient in Orientation'Range loop

            Mask := 1;
            for iRow in Trow'Range loop
               Inst := getPiece (iPiece, iOrient, Row_Parity (iRow));
               for iCol in Tcol'Range loop
                  declare
                     Allowed : OkPieces renames g_okPieces (iRow, iCol);
                     nPiece  : ExtOrientation renames Allowed.nPieces (iPiece);
                  begin
                     if ((Inst.m_allowed and Mask) /= 0) then
                        nPiece                            := nPiece + 1;
                        Allowed.pieceVec (iPiece, nPiece) :=
                           Shift_Left (Inst.m_vec, Natural (iCol));
                     end if;
                  end;
                  Mask := Shift_Left (Mask, 1);
               end loop;
            end loop;

         end loop;
      end loop;
   end Gen_All_Orientations;

end Meteors.Pieces;
------------------------------------------------------------------------------
--   Operations On Board
------------------------------------------------------------------------------
with Meteors.Pieces;   use Meteors.Pieces;
with Meteors.Solution; use Meteors.Solution;

package Meteors.Board is

   L_EDGE_MASK : constant BitVecs :=
      2#0100_0010_0001_0000_1000_0100_0010_0001#;
   R_EDGE_MASK : constant BitVecs := Shift_Left (L_EDGE_MASK, 4);
   TOP_ROW     : constant BitVecs := Shift_Left (1, N_COL) - 1;
   ROW_0_MASK  : constant BitVecs :=
      TOP_ROW or
      Shift_Left (TOP_ROW, 10) or
      Shift_Left (TOP_ROW, 20) or
      Shift_Left (TOP_ROW, 30);
   ROW_1_MASK  : constant BitVecs := Shift_Left (ROW_0_MASK, 5);
   BOARD_MASK  : constant BitVecs := Shift_Left (1, 30) - 1;
   LAST_ROW    : constant BitVecs := Shift_Left (TOP_ROW, 5 * N_COL);

   type Goodbad is (Good, Bad, Always_Bad);

   type Fixed is (Open, Closed);

   type Has_Bad_Array is array (Fixed, Parity) of BitVecs;
   type Is_Known_Array is array (Fixed, Parity) of BitVecs;
   type AlwaysBad_Array is array (Parity) of BitVecs;

   type islandinfo is record
      has_bad   : Has_Bad_Array   := (others => (others => 0));
      is_known  : Is_Known_Array  := (others => (others => 0));
      alwaysBad : AlwaysBad_Array := (others => 0);
   end record;

   MAX_ISLAND_OFFSET : constant := 1024;
   g_islandInfo      : array (0 .. MAX_ISLAND_OFFSET - 1) of islandinfo;

   procedure badregion
     (to_fill : in out BitVecs;
      rnew    : BitVecs;
      Isbad   : out Boolean);

   function Has_Bad_Islands (boardVec : BitVecs; row : Trow) return Goodbad;

   function Calc_Bad_Islands
     (boardVec : BitVecs;
      row      : Trow)
      return     Goodbad;

   procedure Calc_Always_Bad;

   function Has_Bad_Islands_Single
     (boardVec : BitVecs;
      row      : Trow)
      return     Boolean;

   procedure Gen_All_Solutions
     (boardVec     : BitVecs;
      placedPieces : BitVecs;
      Row          : Trow);

   procedure Record_Solution (s : in out Soln);

   m_minSoln            : Soln := init (N_PIECE_TYPE);
   m_curSoln, m_maxSoln : Soln := init (0);

   M_NSoln   : Natural := 0;
   Max_NSoln : Natural := 3000; -- above 2098

   g_firstRegion : constant array (0 .. 31) of BitVecs := (
      16#00#, 16#01#, 16#02#, 16#03#,   16#04#, 16#01#, 16#06#, 16#07#,
      16#08#, 16#01#, 16#02#, 16#03#,   16#0c#, 16#01#, 16#0e#, 16#0f#,

      16#10#, 16#01#, 16#02#, 16#03#,   16#04#, 16#01#, 16#06#, 16#07#,
      16#18#, 16#01#, 16#02#, 16#03#,   16#1c#, 16#01#, 16#1e#, 16#1f#);

   g_flip : constant array (0 .. 31) of BitVecs := (
     16#00#, 16#10#, 16#08#, 16#18#, 16#04#, 16#14#, 16#0c#, 16#1c#,
     16#02#, 16#12#, 16#0a#, 16#1a#, 16#06#, 16#16#, 16#0e#, 16#1e#,

     16#01#, 16#11#, 16#09#, 16#19#, 16#05#, 16#15#, 16#0d#, 16#1d#,
     16#03#, 16#13#, 16#0b#, 16#1b#, 16#07#, 16#17#, 16#0f#, 16#1f#);

end Meteors.Board;
------------------------------------------------------------------------------
with Meteors.Solution; use Meteors.Solution;
with Meteors.Pieces;   use Meteors.Pieces;

package body Meteors.Board is

   procedure badregion
     (to_fill : in out BitVecs;
      rnew    : BitVecs;
      Isbad   : out Boolean)
   is
      function count_ones (v : BitVecs) return Integer_8 is
         Result : Integer_8 := 0;
         Vect   : BitVecs   := v;
      begin
         while Vect /= 0 loop
            Result := Result + 1;
            Vect   := Vect and (Vect - 1);
         end loop;
         return Result;
      end count_ones;

      lrnew                   : BitVecs := rnew;
      region                  : BitVecs;
      Even_Region, Odd_Region : BitVecs;
      ncells                  : Integer_8;

   begin
      --  Grow empty region, until it doesn't change any more.
      loop
         region      := lrnew;
         Even_Region := region and (ROW_0_MASK and not L_EDGE_MASK);
         Odd_Region  := region and (ROW_1_MASK and not R_EDGE_MASK);
         --  simple grow up/down
         lrnew := lrnew or Shift_Right (region, N_COL);
         lrnew := lrnew or Shift_Left (region, N_COL);

         --  grow right/left
         lrnew := lrnew or Shift_Right (region and not L_EDGE_MASK, 1);
         lrnew := lrnew or Shift_Left (region and not R_EDGE_MASK, 1);

         --  tricky growth
         lrnew := lrnew or Shift_Right (Even_Region, N_COL + 1);
         lrnew := lrnew or Shift_Left (Even_Region, N_COL - 1);
         lrnew := lrnew or Shift_Right (Odd_Region, N_COL - 1);
         lrnew := lrnew or Shift_Left (Odd_Region, N_COL + 1);
         --clamp against existing pieces
         lrnew := lrnew and to_fill;
         exit when (lrnew = to_fill) or (lrnew = region);
      end loop;

      --  Subtract empty region from board.
      to_fill := to_fill xor lrnew;
      ncells  := count_ones (to_fill);
      Isbad   := (ncells mod N_ELEM) /= 0;
   end badregion;

   function Has_Bad_Islands (boardVec : BitVecs; row : Trow) return Goodbad is
      iInfo         : Natural;
      Mask, lastrow : BitVecs;
      isodd         : Parity;
      isclosed      : Fixed;
      lboardVec     : BitVecs := boardVec;

      lrow   : Trow := row;
      Result : Goodbad;
   begin
      --  skip over any filled rows
      while (lboardVec and TOP_ROW) = TOP_ROW loop
         lboardVec := Shift_Right (lboardVec, N_COL);
         if lrow = Trow'Last then -- the board is filled
            return Good;
         else
            lrow := lrow + 1;
         end if;
      end loop;

      iInfo := Natural (lboardVec and (Shift_Left (1, 2 * N_COL) - 1));
      declare
         info : islandinfo renames g_islandInfo (iInfo);
      begin
         lastrow := Shift_Right (lboardVec, 2 * N_COL) and TOP_ROW;
         Mask    := Shift_Left (1, Natural (lastrow));
         isodd   := Row_Parity (lrow);

         if (info.alwaysBad (isodd) and Mask) /= 0 then
            return Bad;
         end if;

         if (lboardVec and Shift_Left (TOP_ROW, N_COL * 3)) /= 0 then
            return Calc_Bad_Islands (lboardVec, lrow);
         end if;
         if lrow > 6 then -- we track 3 rows
            isclosed := Closed;
         else
            isclosed := Open;
         end if;
         declare
            Isknownvector : BitVecs renames info.is_known (isclosed, isodd);
            badislevector : BitVecs renames info.has_bad (isclosed, isodd);
         begin
            if (Isknownvector and Mask) /= 0 then
               if (badislevector and Mask) = 0 then
                  return Good;
               else
                  return Bad;
               end if;
            end if;

            if lboardVec = 0 then
               return Good;
            end if;

            Result        := Calc_Bad_Islands (lboardVec, lrow);
            Isknownvector := Isknownvector or Mask;
            if Result /= Good then
               badislevector := badislevector or Mask;
            end if;
         end;
         return Result;
      end;
   end Has_Bad_Islands;

   function Calc_Bad_Islands
     (boardVec : BitVecs;
      row      : Trow)
      return     Goodbad
   is
      tofill, boardmask, bottom, startregion : BitVecs;
      Boardmaskshift                         : Natural;
      filled                                 : Boolean;
      Lrow                                   : Trow := row;
      Isbad                                  : Boolean;
      Ipos                                   : Natural;
   begin
      tofill := not boardVec;
      --  Compensate for odd rows.
      if Row_Parity (Lrow) = Odd then
         Lrow   := Lrow - 1;
         tofill := Shift_Left (tofill, N_COL);
      end if;

      boardmask := BOARD_MASK; --  all but the first two bits

      if Lrow > 4 then
         Boardmaskshift := Natural (Lrow - 4) * N_COL;
         boardmask      := Shift_Right (boardmask, Boardmaskshift);
      end if;
      tofill := tofill and boardmask;

      --  a little pre-work to speed things up
      bottom := Shift_Left (TOP_ROW, 5 * N_COL);
      filled := (bottom and tofill) = bottom;
      while (bottom and tofill) = bottom loop
         tofill := tofill xor bottom;
         bottom := Shift_Right (bottom, N_COL);
      end loop;

      if filled or (Lrow < 4) then
         startregion := bottom and tofill;
      else
         startregion := g_firstRegion (Natural (tofill and TOP_ROW));
         if startregion = 0 then
            startregion := Shift_Right (tofill, N_COL) and TOP_ROW;
            startregion := g_firstRegion (Natural (startregion));
            startregion := Shift_Left (startregion, N_COL);
         end if;
         startregion := startregion or
                        (Shift_Right (startregion, N_COL) and tofill);
      end if;

      while tofill /= 0 loop
         badregion (tofill, startregion, Isbad);
         if Isbad then
            if tofill /= 0 then
               return Always_Bad;
            else
               return Bad;
            end if;
         end if;
         Ipos        := Get_First_One (tofill);
         startregion := Shift_Left (1, Ipos);
      end loop;

      return Good;
   end Calc_Bad_Islands;

   procedure Calc_Always_Bad is

      function Flip_Two_Rows (Bits : Integer) return Integer is
         result  : Integer := 0;
         Flipped : BitVecs := Shift_Right (BitVecs (Bits), N_COL);
         interim : BitVecs := BitVecs (Bits) and TOP_ROW;
      begin
         Flipped := Shift_Left (g_flip (Natural (Flipped)), N_COL);
         result  := Integer (Flipped or g_flip (Natural (interim)));
         return result;
      end Flip_Two_Rows;

      procedure Markbad
        (Info   : in out islandinfo;
         Mask   : in BitVecs;
         Eo     : in Parity;
         Always : in Boolean)
      is
      begin
         Info.has_bad (Open, Eo)   := Info.has_bad (Open, Eo) or Mask;
         Info.has_bad (Closed, Eo) := Info.has_bad (Closed, Eo) or Mask;
         if Always then
            Info.alwaysBad (Eo) := Info.alwaysBad (Eo) and Mask;
         end if;
      end Markbad;

      Mask, Flipmask, boardvec : BitVecs;
      hasbad                   : Goodbad;
      always                   : Boolean;

   begin
      for iWord in 1 .. MAX_ISLAND_OFFSET - 1 loop
         declare
            IsleInfo : islandinfo renames g_islandInfo (iWord);
            flipped  : islandinfo renames g_islandInfo (Flip_Two_Rows
                                                           (iWord));
         begin
            Mask := 1;
            for i in 0 .. 31 loop

               boardvec := Shift_Left (BitVecs (i), 2 * N_COL) or
                           BitVecs (iWord);

               if ((IsleInfo.is_known (Open, Even) and Mask) = 0) then
                  hasbad := Calc_Bad_Islands (boardvec, 0);
                  if hasbad /= Good then
                     always := (hasbad = Always_Bad);
                     Markbad (IsleInfo, Mask, Even, always);
                     Flipmask := Shift_Left (1, Natural (g_flip (i)));
                     Markbad (flipped, Flipmask, Odd, always);
                  end if;
               end if;
               Mask := Shift_Left (Mask, 1);
            end loop;
            IsleInfo.is_known (Open, Even) := BitVecs (BitVecs'Last);
            flipped.is_known (Open, Odd)   := BitVecs (BitVecs'Last);

         end;
      end loop;
   end Calc_Always_Bad;

   function has_bad_islands_single
     (boardVec : BitVecs;
      row      : Trow)
      return     Boolean
   is
      Isbad                          : Boolean;
      tofill, startregion, boardmask : BitVecs;
      isodd                          : Boolean := Row_Parity (row) = Odd;
      lrow                           : Trow    := row;
      Ipos                           : Natural;
   begin
      tofill := not boardVec;
      if isodd then
         lrow   := lrow - 1;
         tofill := Shift_Left (tofill, N_COL);--  shift to even aligned
         tofill := tofill or TOP_ROW;
      end if;

      startregion := TOP_ROW;
      boardmask   := BOARD_MASK; --  all but the first two bits

      if lrow >= 4 then
         boardmask := Shift_Right (boardmask, Natural (lrow - 4) * N_COL);
      elsif isodd or (lrow = 0) then
         startregion := LAST_ROW;
      end if;

      tofill      := tofill and boardmask;
      startregion := startregion and tofill;

      while tofill /= 0 loop
         badregion (tofill, startregion, Isbad);
         if Isbad then
            return True;
         end if;
         Ipos        := Get_First_One (tofill);
         startregion := Shift_Left (1, Ipos);
      end loop;
      return False;
   end has_bad_islands_single;

   procedure Gen_All_Solutions
     (boardVec     : BitVecs;
      placedPieces : BitVecs;
      Row          : Trow)
   is

      l_boardVec     : BitVecs := boardVec;
      l_placedPieces : BitVecs := placedPieces;
      l_Row          : Trow    := Row;

      ALL_PIECE_MASK : constant BitVecs := 2#11_1111_1111#;

      INextFill           : Tcol;
      ipiece              : Piecenr;
      Piecemask, piecevec : BitVecs;
   begin
      while (l_boardVec and TOP_ROW) = TOP_ROW loop
         l_boardVec := Shift_Right (l_boardVec, N_COL);
         l_Row      := l_Row + 1;
      end loop;

      INextFill :=
        Tcol (S_FirstOne (Natural ((not l_boardVec) and TOP_ROW)));
      declare
         Allowed : OkPieces renames g_okPieces (l_Row, INextFill);
      begin
         ipiece    := Piecenr (Get_First_One (not l_placedPieces));
         Piecemask := Shift_Left (1, Natural (ipiece));
         loop

         -- go on only if we've not already used this piece
            if (Piecemask and l_placedPieces) = 0 then
               l_placedPieces := l_placedPieces or Piecemask;

               for Iorient in 0 .. Allowed.nPieces (ipiece) loop
                  piecevec := Allowed.pieceVec (ipiece, Iorient);

                  --check if piece conflicts with other pieces
                  if (piecevec and l_boardVec) = 0 then
                     -- add the piece to the board
                     l_boardVec := l_boardVec or piecevec;
                     if Has_Bad_Islands (l_boardVec, l_Row) = Good then

                        pushPiece (m_curSoln, piecevec, ipiece, l_Row);
                        -- recur or record solution
                        if (l_placedPieces /= ALL_PIECE_MASK) then
                           Gen_All_Solutions
                             (l_boardVec,
                              l_placedPieces,
                              l_Row);
                        else
                           Record_Solution (m_curSoln);
                           popPiece (m_curSoln);
                           return;
                        end if;
                        if M_NSoln >= Max_NSoln then
                           return;
                        end if;
                        popPiece (m_curSoln);
                     end if;
                     -- remove the piece before continuing with a new piece
                     l_boardVec := l_boardVec xor piecevec;
                  end if;
               end loop;

               l_placedPieces := l_placedPieces xor Piecemask;
            end if;
            exit when ipiece = Piecenr'Last;
            ipiece    := ipiece + 1;
            Piecemask := Shift_Left (Piecemask, 1);
         end loop;
      end;
   end Gen_All_Solutions;

   procedure record_solution (S : in out Soln) is
      spun : Soln;
   begin
      setCells (s);
      M_NSoln := M_NSoln + 2; --  add solution and its rotation

      if isEmpty (m_minSoln) then
         m_minSoln := s;
         m_maxSoln := s;
         return;
      end if;

      if s < m_minSoln then
         m_minSoln := s;
      elsif m_maxSoln < s then
         m_maxSoln := s;
      end if;

      spin (s, spun);
      if spun < m_minSoln then
         m_minSoln := spun;
      elsif m_maxSoln < spun then
         m_maxSoln := spun;
      end if;
   end record_solution;

end Meteors.Board;
------------------------------------------------------------------------------
--   Operations on Solutions
------------------------------------------------------------------------------
package Meteors.Solution is

   type Soln is private;

   procedure setCells (Self : in out Soln);
   -- Left and right must be synched by setcells before comparaison.
   function "<" (Left : Soln; Right : Soln) return Boolean;
   function init (value : Ext_Piecenr := No_Piece) return Soln;
   procedure spin (Self : in out Soln; spun : out Soln);

   function isEmpty (Self : Soln) return Boolean;

   procedure popPiece (Self : in out Soln);
   pragma Inline (popPiece);

   procedure pushPiece
     (Self     : in out Soln;
      A_vec    : BitVecs;
      A_iPiece : Piecenr;
      A_row    : Trow);
   pragma Inline (pushPiece);

   procedure Output (Nbr_Sol : Natural; Smin, Smax : Soln);

private
   type Spieces is record
      bitvec : BitVecs;
      ipiece : Piecenr;
      row    : Trow;
   end record;

   type M_Pieces_Type is array (Piecenr) of Spieces;
   type M_Cells_Type is array (Trow, Tcol) of Ext_Piecenr;

   type Soln is record
      m_pieces  : M_Pieces_Type;
      m_nPiece  : Ext_Piecenr := 0;
      m_cells   : M_Cells_Type;
      m_synched : Boolean     := True;
   end record;

end Meteors.Solution;
------------------------------------------------------------------------------
with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with Unchecked_Conversion;
with Ada.Text_IO;           use Ada.Text_IO;

package body Meteors.Solution is

   procedure setCells (Self : in out Soln) is
      nNewcells : Natural;
   begin
      if Self.m_synched then
         return;
      end if;
      for iPiece in 0 .. Self.m_nPiece - 1 loop
         declare
            P         : Spieces renames Self.m_pieces (iPiece);
            Vec       : BitVecs     := P.bitvec;
            pID       : Ext_Piecenr := P.ipiece;
            RowOffset : Trow        := P.row;
         begin
            nNewcells := 0;
            Outer : for y in RowOffset .. Trow'Last loop
               for x in Tcol'Range loop
                  if ((Vec and 1) /= 0) then
                     Self.m_cells (y, x) := pID;
                     nNewcells           := nNewcells + 1;
                     exit Outer when nNewcells = N_ELEM;
                  end if;
                  Vec := Shift_Right (Vec, 1);
               end loop;
            end loop Outer;
         end;
      end loop;
      Self.m_synched := True;
   end setCells;

   function "<" (Left : Soln; Right : Soln) return Boolean is
      lval, rval : Ext_Piecenr;
   begin
      if not (Left.m_synched and Right.m_synched) then
         raise Constraint_Error;
      end if;
      if Left.m_pieces (0).ipiece /= Right.m_pieces (0).ipiece then
         return Left.m_pieces (0).ipiece < Right.m_pieces (0).ipiece;
      end if;

      for y in Trow'Range loop
         for x in Tcol'Range loop
            lval := Left.m_cells (y, x);
            rval := Right.m_cells (y, x);
            if lval /= rval then
               return lval < rval;
            end if;
         end loop;
      end loop;
      --  solutions are equal
      return False;
   end "<";

   function init (value : Ext_Piecenr := No_Piece) return Soln is
      Self : Soln;
   begin
      for I in Trow'Range loop
         for J in Tcol'Range loop
            Self.m_cells (I, J) := value;
         end loop;
      end loop;
      Self.m_synched := True;
      Self.m_nPiece  := 0;
      return Self;
   end init;

   procedure spin (Self : in out Soln; spun : out Soln) is
   begin
      setCells (Self);
      --  swap cells
      for y in Trow'Range loop
         for x in Tcol'Range loop
            spun.m_cells (y, x) :=
              Self.m_cells (Trow'Last - y, Tcol'Last - x);
         end loop;
      end loop;
      --  swap first and last pieces (the rest aren't used)
      spun.m_pieces (0).ipiece := Self.m_pieces (Piecenr'Last).ipiece;
      spun.m_synched           := True;
   end spin;

   function isEmpty (Self : Soln) return Boolean is
   begin
      return (Self.m_nPiece = 0);
   end isEmpty;

   procedure popPiece (Self : in out Soln) is
   begin
      Self.m_nPiece  := Self.m_nPiece - 1;
      Self.m_synched := False;
   end popPiece;

   procedure pushPiece
     (Self     : in out Soln;
      A_vec    : in BitVecs;
      A_iPiece : in Piecenr;
      A_row    : in Trow)
   is

      P : Spieces renames Self.m_pieces (Self.m_nPiece);
   begin
      P.bitvec       := A_vec;
      P.ipiece       := A_iPiece;
      P.row          := A_row;
      Self.m_nPiece  := Self.m_nPiece + 1;
      Self.m_synched := False;
   end pushPiece;

   procedure Output (Nbr_Sol : Natural; Smin, Smax : Soln) is
      use Ada.Streams, ASCII;

      package Int_IO is new Integer_IO (Integer);

      subtype Item is String (1 .. 254);

      subtype Index is Stream_Element_Offset range
         Stream_Element_Offset (Item'First) ..
         Stream_Element_Offset (Item'Last);
      subtype XBytes is Stream_Element_Array (Index);
      function To_Bytes is new Unchecked_Conversion (
         Source => Item,
         Target => XBytes);

      Stdout : Stream_IO.File_Type;
      Result : Item;

      function To_String (S : Soln) return String is
         N   : Natural := 0;
         Res : String (1 .. 116);
      begin
         for I in Trow'Range loop
            if (I mod 2) = 1 then--  indent every second line
               N       := N + 1;
               Res (N) := ' ';
            end if;

            for J in Tcol'Range loop
               N := N + 1;
               Int_IO.Put (Res (N .. N), Integer (S.m_cells (I, J)));
               N       := N + 1;
               Res (N) := ' ';
            end loop;
            N       := N + 1;
            Res (N) := LF;
         end loop;
         N       := N + 1;
         Res (N) := LF;
         return Res;
      end To_String;

   begin
      Int_IO.Put (Result (1 .. 4), Nbr_Sol);
      Result (5 .. 22)    := (" solutions found" & LF & LF);
      Result (23 .. 138)  := (To_String (Smin));
      Result (139 .. 254) := (To_String (Smax));

      Stream_IO.Open (File => Stdout, Mode => Out_File, Name => "/dev/stdout");
      Stream_IO.Write (Stdout, To_Bytes (Result));
      Stream_IO.Close (Stdout);
   end Output;

end Meteors.Solution;
------------------------------------------------------------------------------
with Meteors;          use Meteors;
with Meteors.Pieces;
with Meteors.Solution; use Meteors.Solution;
with Meteors.Board;    use Meteors.Board;
with Ada.Command_Line; use Ada.Command_Line;

procedure Meteor is
begin
   if Argument_Count > 0 then
      --Program will search only max number of solutions.
      Max_NSoln := Natural'Value (Argument (1));
   end if;
   Pieces.Gen_All_Orientations;
   Calc_Always_Bad;
   Gen_All_Solutions (0, 0, 0);
   Output (M_NSoln, m_minSoln, m_maxSoln);
end Meteor;

 make, command-line, and program output logs

Sun, 27 Apr 2014 02:14:01 GMT

MAKE:
/usr/bin/gnatchop -r -w meteor.gnat
splitting meteor.gnat into:
   meteors.ads
   meteors.adb
   meteors-pieces.ads
   meteors-pieces.adb
   meteors-board.ads
   meteors-board.adb
   meteors-solution.ads
   meteors-solution.adb
   meteor.adb
/usr/bin/gnatmake -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp -f meteor.adb -o meteor.gnat_run 
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp meteor.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp meteors.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp meteors-board.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp meteors-pieces.adb
meteor.gnat:229:04: warning: pragma appears too late, ignored
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp meteors-solution.adb
gnatbind -x meteor.ali
gnatlink meteor.ali -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -o meteor.gnat_run
1.52s to complete and log all make actions

COMMAND LINE:
./meteor.gnat_run 2098

PROGRAM OUTPUT:
2098 solutions found

0 0 0 0 1 
 2 2 2 0 1 
2 6 6 1 1 
 2 6 1 5 5 
8 6 5 5 5 
 8 6 3 3 3 
4 8 8 9 3 
 4 4 8 9 3 
4 7 4 7 9 
 7 7 7 9 9 

9 9 9 9 8 
 9 6 6 8 5 
6 6 8 8 5 
 6 8 2 5 5 
7 7 7 2 5 
 7 4 7 2 0 
1 4 2 2 0 
 1 4 4 0 3 
1 4 0 0 3 
 1 1 3 3 3 

Revised BSD license

  Home   Conclusions   License   Play