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,098 | 0.08 | 0.09 | ? | 7416 | 0% 0% 11% 100% |
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 (Ubuntu/Linaro 4.7.3-1ubuntu1) 4.7.3
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
Sat, 27 Apr 2013 23:33:03 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.51s 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