From 4edf4de9558c13ca177e887d315caf24263f0367 Mon Sep 17 00:00:00 2001 From: daniel Date: Sun, 29 Apr 2007 19:19:16 +0000 Subject: [PATCH] + Meteor benchmark git-svn-id: trunk@7197 - --- .gitattributes | 1 + tests/bench/shootout/src/meteorshower.pp | 887 +++++++++++++++++++++++ 2 files changed, 888 insertions(+) create mode 100644 tests/bench/shootout/src/meteorshower.pp diff --git a/.gitattributes b/.gitattributes index 88640a3a05..069e022f5b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -5538,6 +5538,7 @@ tests/bench/shootout/src/binarytrees.pp svneol=native#text/plain tests/bench/shootout/src/hello.pp svneol=native#text/plain tests/bench/shootout/src/knucleotide.pp svneol=native#text/plain tests/bench/shootout/src/mandelbrot.pp svneol=native#text/plain +tests/bench/shootout/src/meteorshower.pp svneol=native#text/x-pascal tests/bench/shootout/src/nsieve.pp svneol=native#text/plain tests/bench/shootout/src/partialsums.pp svneol=native#text/plain tests/bench/shootout/src/recursive.pp svneol=native#text/plain diff --git a/tests/bench/shootout/src/meteorshower.pp b/tests/bench/shootout/src/meteorshower.pp new file mode 100644 index 0000000000..723779b5f5 --- /dev/null +++ b/tests/bench/shootout/src/meteorshower.pp @@ -0,0 +1,887 @@ +program meteorshower; + +{Shootout Meteor puzzle implementation + + by Daniel Mantione + + mostly based on Ben St. John's implementation.} + +{$Q-} + +uses dos; + +const N_COL = 5; + N_ROW = 10; + N_CELL = N_COL * N_ROW; + N_PIECE_TYPE = 10; + + N_ELEM=5; + N_ORIENT=12; + ALL_PIECE_MASK=[0..N_PIECE_TYPE-1]; + SKIP_PIECE=5; + + no_piece=high(byte); + + L_EDGE_MASK=[0,5,10,15,20,25,30]; + R_EDGE_MASK=[4,9,14,19,24,29]; + TOP_ROW = [0*N_COL..1*N_COL-1]; + SECOND_ROW = [1*N_COL..2*N_COL-1]; + THIRD_ROW = [2*N_COL..3*N_COL-1]; + FOURTH_ROW = [3*N_COL..4*N_COL-1]; + FIFTH_ROW = [4*N_COL..5*N_COL-1]; + SIXTH_ROW = [5*N_COL..6*N_COL-1]; + LAST_ROW = SIXTH_ROW; + ROW_0_MASK=[0..N_COL-1,10..N_COL+10-1,20..N_COL+20-1,30,31]; + ROW_1_MASK=[5..N_COL+5-1,15..N_COL+15-1,25..N_COL+25-1]; + BOARD_MASK=[0..29]; + + +type bitvec=set of 0..31; + dimensions=(dimx,dimy); + parity=(even,odd); + goodbad=(good,bad,always_bad); + piecenr=type 0..N_PIECE_TYPE-1; + orientation=type 0..N_ORIENT-1; + + piece_placement=record + vec:bitvec; + ipiece:piecenr; + row:byte; + end; + +type Soln=object + m_pieces:array[piecenr] of piece_placement; + m_npiece:byte; + m_cells:array[0..N_ROW-1,0..N_COL-1] of piecenr; + m_synched:boolean; + constructor init(fillval:byte); + procedure setCells; + function lessThan(var r:Soln):boolean; + procedure write(var f:text); + procedure fill(value:byte); + procedure spin(var spun:Soln); + + function isEmpty:boolean; + procedure popPiece;inline; + procedure pushPiece(Avec:bitvec;AiPiece:piecenr;Arow:byte); + end; + + instance=record + m_allowed:set of byte; + m_vec:bitvec; + m_offset:longint; + end; + + TPts=array[0..N_ELEM-1,dimensions] of shortint; + piece=object + m_instance:array[parity] of instance; + procedure set_ok_positions(isOdd:parity;w,h:longint); + end; + + OkPieces=record + nPieces:array[piecenr] of byte; + pieceVec:array[piecenr,orientation] of bitvec; + end; + + +type fixed=(OPEN, CLOSED); + islandinfo=record + has_bad:array[fixed,parity] of bitvec; + is_known:array[fixed,parity] of bitvec; + alwaysBad:array[parity] of bitvec; + end; + +const MAX_ISLAND_OFFSET=1024; + +type cacherec=record + krow,kpiecevec:word; + kboardvec:bitvec; + end; + +var s_basePiece:array[piecenr,orientation] of piece; + g_okPieces:array[0..N_ROW-1,0..N_COL-1] of OkPieces; + g_islandInfo:array[0..MAX_ISLAND_OFFSET-1] of islandinfo; + g_nIslandInfo:cardinal=0; + cache:array[0..1024*128-1] of cacherec; + + m_curSoln,m_minSoln,m_maxSoln:Soln; + m_nSoln:cardinal; + +const basevecs:array [0..9] of bitvec= ( + [0,1,2,3,8], + [0,1,3,6,7], + [0,1,2,7,12], + [0,1,2,5,10], + [0,2,5,6,10], + [0,1,2,6,7], + [0,1,5,10,15], + [0,1,2,5,7], + [0,1,2,7,8], + [0,1,2,3,7] + ); + + +constructor soln.init(fillval:byte); + +begin + fill(fillval); +end; + +procedure Soln.fill(value:byte); + +begin + m_synched:=false; + fillchar(m_cells,N_CELL,value); +end; + +function soln.isEmpty:boolean; + +begin + isempty:=m_nPiece=0; +end; + +procedure soln.pushPiece(Avec:bitvec;AiPiece:piecenr;Arow:byte); + +begin + with m_pieces[m_npiece] do + begin + vec:=Avec; + iPiece:=AiPiece; + row:=Arow; + end; + inc(m_npiece); +end; + +procedure soln.popPiece;inline; + +begin + dec(m_nPiece); + m_synched := false; +end; + +procedure soln.write(var f:text); + +var x,y:byte; + +begin + for y:=0 to N_ROW-1 do + begin + {indent every second line} + if y mod 2=1 then + system.write(f,' '); + for x:=0 to N_COL-1 do + if m_cells[y,x]=no_piece then + system.write(f,'. ') + else + system.write(f,char(byte('0')+m_cells[y,x]),' '); + writeln(f); + end; +end; + + +procedure Soln.setCells; + +var c,i,x,y,newcells:byte; + +begin + if m_synched then + exit; + for i:=1 to m_nPiece do + with m_pieces[i-1] do + begin + newcells:=0; + c:=0; + for y:=row to N_ROW do + begin + for x:=0 to N_COL-1 do + begin + if c in vec then + begin + m_cells[y,x]:=ipiece; + inc(NewCells); + end; + inc(c); + end; + if NewCells=N_ELEM then + break; + end; + end; + m_synched:=true; +end; + +function Soln.lessThan(var r:Soln):boolean; + +var x,y,lval,rval:byte; + +begin + if m_pieces[0].iPiece<>r.m_pieces[0].iPiece then + begin + lessthan:=m_pieces[0].iPiece < r.m_pieces[0].iPiece; + exit; + end; + + setCells(); + r.setCells(); + + for y:=0 to N_ROW-1 do + for x:=0 to N_COL-1 do + begin + lval:=m_cells[y,x]; + rval:=r.m_cells[y,x]; + + if lval <> rval then + begin + lessthan:=lvaltop) and ((top<0) xor (bot<=0)) then + dec(floor); +end; + +const s_firstOne:array[0..31] of byte=( + 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 +); + +function first_set_bit(v:bitvec):cardinal;inline; + +{$ifdef endian_little} +const l=0; + h=1; +{$else} +const l=1; + h=0; +{$endif} + +var d:double; + u:array[0..1] of bitvec absolute d; + +begin + first_set_bit:=0; + if v<>[] then + begin + u[l]:=v; + u[h]:=[30,25,24,21,20]; + d:=d-4503599627370496; + first_set_bit:=cardinal(u[h]) shr 20-$3ff; + end; +end; + +function count_ones(v:bitvec):cardinal;inline; + +begin + count_ones:=0; + while v<>[] do + begin + inc(count_ones); + cardinal(v):=cardinal(v) and (cardinal(v)-1); + end; +end; + +procedure setCoordList(vec:bitvec;var pts:Tpts); + +var iPt,n:longint; + x,y:byte; + +begin + iPt:=0; + n:=0; + for y:=0 to N_ROW-1 do + for x:=0 to N_COL-1 do + begin + if n in vec then + begin + pts[iPt,dimx]:=x; + pts[iPt,dimy]:=y; + inc(iPt); + end; + inc(n); + if n=32 then + exit; + end; +end; + +function toBitVector(const pts:Tpts):bitvec; + +var x,y,iPt:byte; + +begin + tobitvector:=[]; + for iPt:=low(pts) to high(pts) do + begin + x:=pts[iPt,dimx]; + y:=pts[iPt,dimy]; + include(tobitvector,y*N_COL+x); + end; +end; + +procedure shiftUpLines(var pts:Tpts;shift:longint); + +var iPt:byte; + +begin + {vertical shifts have a twist} + for iPt:=low(pts) to high(pts) do + begin + if pts[iPt,dimy] and shift and 1<>0 then + inc(pts[iPt,dimx]); + dec(pts[iPt,dimy],shift); + end; +end; + +function shiftToX0(var pts:Tpts;var Ainstance:instance;offsetRow:longint):shortint; + +var x,y,xmin,xmax,iPt,offset:shortint; + +begin + { .. determine shift} + xMin:=pts[0,dimx]; + xMax:=xMin; + for iPt:=low(pts)+1 to high(pts) do + begin + x:=pts[iPt,dimx]; + y:=pts[iPt,dimy]; + if x xMax then + xMax:=x; + end; + + offset:=N_ELEM; + for iPt:=low(pts) to high(pts) do + begin + dec(pts[iPt,dimx],xMin); + {check offset -- leftmost cell on top line} + if (pts[iPt,dimy]=offsetRow) and (pts[iPt,dimx]0' by hand...} + badregion:=cell_count<>((cell_count*$cccd) shr 18)*5; +end; + +function has_bad_islands_single(boardVec:bitvec;row:longint):boolean; + +var tofill,startregion,bmask:bitvec; + isodd:boolean; + +begin + tofill:=[0..31]-boardvec; + isOdd:=row and 1<>0; + if isOdd then + begin + dec(row); + toFill:=bitvec(cardinal(tofill) shl N_COL); {shift to even aligned} + toFill:= tofill + TOP_ROW; + end; + + startRegion := TOP_ROW; + bMask := BOARD_MASK; {all but the first two bits} + if row>=4 then + cardinal(bMask):=cardinal(bmask) shr ((row-4)*N_COL) + else if isOdd or (row = 0) then + startRegion := LAST_ROW; + + toFill:=tofill*bMask; + startRegion:=startregion*toFill; + + has_bad_islands_single:=true; + while toFill<>[] do + begin + if badRegion(toFill, startRegion) then + exit; + startRegion:=[first_set_bit(toFill)]; + end; + has_bad_islands_single:=false; +end; + + +procedure piece.set_ok_positions(isOdd:parity;w,h:longint); + +var x,y,xpos,pos:byte; + +begin + pos:=byte(isodd)*N_COL; + with m_instance[isOdd] do + begin + m_allowed:=[]; + y:=byte(isOdd); + while y0 then + inc(pos,m_offset); + for xPos:=0 to N_COL-1-m_offset do + begin + {check if the new position is on the board} + if (xPos= 6; + if flip then + for iPt:=0 to N_ELEM-1 do + pts[iPt,dimy]:=-pts[iPt,dimy]; + + {rotate as necessary} + while rot>0 do + begin + for iPt:=0 to N_ELEM-1 do + begin + x:=pts[iPt,dimx]; + y:=pts[iPt,dimy]; + pts[iPt,dimx]:=floor(2*x-3*y+1,4); + pts[iPt,dimy]:=floor(2*x+y+1,2); + end; + dec(rot); + end; + + {determine vertical shift} + yMin := pts[0,dimy]; + yMax := yMin; + for iPt:= 1 to N_ELEM-1 do + begin + y := pts[iPt,dimy]; + + if y < yMin then + yMin := y + else if y > yMax then + yMax := y; + end; + h:=yMax-yMin; + + shiftUpLines(pts, yMin); + w := shiftToX0(pts, target.m_instance[EVEN], 0); + target.set_ok_positions(EVEN, w, h); + cardinal(target.m_instance[EVEN].m_vec) := cardinal(target.m_instance[EVEN].m_vec) shr target.m_instance[EVEN].m_offset; + + {shift down one line} + shiftUpLines(pts, -1); + w := shiftToX0(pts, target.m_instance[ODD], 1); + {shift the bitmask back one line} + cardinal(target.m_instance[ODD].m_vec) :=cardinal(target.m_instance[ODD].m_vec) shr N_COL; + target.set_ok_positions(ODD, w, h); + cardinal(target.m_instance[ODD].m_vec):= cardinal(target.m_instance[ODD].m_vec) shr target.m_instance[ODD].m_offset; +end; + +function getPiece(iPiece,iOrient:cardinal;iParity:parity):instance;inline; + +begin + getpiece:=s_basePiece[iPiece][iOrient].m_instance[iParity]; +end; + +procedure gen_all_orientations; + +var ipiece:piecenr; + iorient:orientation; + irow,icol:byte; + refpiece:bitvec; + n,npiece:byte; + +begin + for iPiece:=low(ipiece) to high(ipiece) do + begin + refPiece:=BaseVecs[iPiece]; + for iOrient:=low(iorient) to high(iorient) do + begin + gen_orientation(refPiece, iOrient, s_basePiece[iPiece,iOrient]); + with s_basePiece[iPiece,iOrient] do + begin + if (iPiece=SKIP_PIECE) and (iOrient in [3..5,9..11]) then + begin + m_instance[odd].m_allowed := []; + m_instance[even].m_allowed := []; + end; + end; + end; + end; + + for iPiece:=low(ipiece) to high(ipiece) do + begin + for iOrient:=low(iorient) to high(iorient) do + begin + n:=0; + for iRow:=0 to N_ROW-1 do + begin + with getPiece(iPiece, iOrient, parity(iRow and 1)) do + for iCol:=0 to N_COL-1 do + begin + if n in m_allowed then + begin + nPiece:=g_okPieces[iRow,iCol].nPieces[iPiece]; + g_okPieces[iRow,iCol].pieceVec[iPiece,nPiece]:=bitvec(cardinal(m_vec) shl iCol); + inc(g_okPieces[iRow,iCol].nPieces[iPiece]); + end; + inc(n); + end; + end + end + end +end; + +procedure init_board; + +begin + m_cursoln.init(NO_PIECE); + m_minsoln.init(NO_PIECE); + m_maxsoln.init(NO_PIECE); + m_nsoln:=0; +end; + +const g_firstRegion:array[0..31] of bitvec=( + [], [0], [1], [0,1], + [2], [0], [1,2], [0,1,2], + [3], [0], [1], [0,1], + [2,3], [0], [1,2,3], [0,1,2,3], + [4], [0], [1], [0,1], + [2], [0], [1,2], [0,1,2], + [3,4], [0], [1], [1,2], + [2,3,4], [0], [1,2,3,4], [0,1,2,3,4] +); + +function calc_bad_islands(boardVec:bitvec;row:longint):goodbad; + +var tofill,boardmask,bottom,startregion:bitvec; + filled:boolean; + +begin + toFill:=[0..31]-boardVec; + {Compensate for odd rows.} + if row and 1<>0 then + begin + dec(row); + cardinal(toFill):=cardinal(tofill) shl N_COL; + end; + + boardMask := BOARD_MASK; {all but the first two bits} + if row>4 then + cardinal(boardMask):=cardinal(boardmask) shr ((row-4)*N_COL); + toFill:=tofill*boardMask; + + {a little pre-work to speed things up} + filled:=toFill*LAST_ROW=LAST_ROW; + bottom:=LAST_ROW; + while bottom*toFill=bottom do + begin + toFill:=tofill-bottom; + cardinal(bottom):=cardinal(bottom) shr N_COL; + end; + + if filled or (row<4) then + startRegion := bottom * toFill + else + begin + startRegion := g_firstRegion[cardinal(toFill*TOP_ROW)]; + if startRegion=[] then + begin + startRegion := bitvec(cardinal(toFill) shr N_COL)*TOP_ROW; + startRegion := g_firstRegion[cardinal(startRegion)]; + cardinal(startRegion) := cardinal(startregion) shl N_COL; + end; + startRegion:=startregion+bitvec(cardinal(startRegion) shl N_COL)*toFill; + end; + + while toFill<>[] do + begin + if badRegion(toFill, startRegion) then + begin + if toFill<>[] then + calc_bad_islands:=ALWAYS_BAD + else + calc_bad_islands:=BAD; + exit; + end; + startRegion := [first_set_bit(toFill)]; + end; + + calc_bad_islands:=GOOD; +end; + + +function has_bad_islands(boardvec:bitvec;row:longint):goodbad; + +var last_row:bitvec; + isodd:parity; + isclosed:fixed; + +begin + {skip over any filled rows} + while boardVec*TOP_ROW=TOP_ROW do + begin + cardinal(boardVec):=cardinal(boardvec) shr N_COL; + inc(row); + end; + + has_bad_islands:=bad; + with g_islandInfo[cardinal(boardvec*(TOP_ROW+SECOND_ROW))] do + begin + last_row:=bitvec(cardinal(boardvec) shr (2*N_COL))*TOP_ROW; + isOdd:=parity(row and 1); + + if not(cardinal(last_row) in alwaysBad[parity(row and 1)]) then + if boardVec*bitvec(cardinal(TOP_ROW) shl N_COL*3)=[] then + begin + isClosed:=fixed(row>6); {because we track 3 rows} + if not(cardinal(last_row) in is_known[isClosed,isOdd]) then + if boardVec<>[] then + begin + has_bad_islands:=calc_bad_islands(boardvec,row); + include(is_known[isClosed,isOdd],cardinal(last_row)); + if has_bad_islands<>good then + include(is_known[isClosed,isOdd],cardinal(last_row)); + end + else + has_bad_islands:=good + else + if not(cardinal(last_row) in has_bad[isClosed,isOdd]) then + has_bad_islands:=good; + end + else + has_bad_islands:=calc_bad_islands(boardvec,row); + end; +end; + +const g_flip:array[0..31] of bitvec=( + [], [4], [3], [3,4], + [2], [2,4], [2,3], [2,3,4], + [1], [1,4], [1,3], [1,3,4], + [1,2], [1,2,4], [1,2,3], [1,2,3,4], + [0], [0,4], [0,3], [0,3,4], + [0,2], [0,2,4], [0,2,3], [0,2,3,4], + [0,1], [0,1,4], [0,1,3], [0,1,3,4], + [0,1,2], [0,1,2,4], [0,1,2,3], [0,1,2,3,4] +); + +function flipTwoRows(bits:bitvec):bitvec;inline; + +var flipped:cardinal; + +begin + flipped:=cardinal(g_flip[cardinal(bits) shr N_COL]) shl N_COL; + fliptworows:=bitvec(flipped or cardinal(g_flip[cardinal(bits*TOP_ROW)])); +end; + +procedure mark_bad(var info:IslandInfo;n:byte;eo:parity;always:boolean);inline; + +begin + with info do + begin + include(has_bad[OPEN,eo],n); + include(has_bad[CLOSED,eo],n); + + if always then + include(alwaysBad[eo],n); + end; +end; + +procedure calc_always_bad; + +var i,iWord:cardinal; + boardvec:bitvec; + hasbad:goodbad; + always:boolean; + flipped:^islandinfo; + +begin + for iWord:=1 to MAX_ISLAND_OFFSET-1 do + begin + flipped := @g_islandInfo[cardinal(flipTwoRows(bitvec(iWord)))]; + for i:=0 to 31 do + begin + boardvec:=bitvec((i shl (2*N_COL)) or iWord); + if not(i in g_islandInfo[iWord].is_known[OPEN,EVEN]) then + begin + hasBad:=calc_bad_islands(boardvec,0); + if hasBad<>good then + begin + always:=hasBad=ALWAYS_BAD; + mark_bad(g_islandInfo[iWord], i, EVEN, always); + mark_bad(flipped^,cardinal(g_flip[i]), ODD, always); + end; + end; + end; + flipped^.is_known[OPEN,odd]:=[0..31]; + g_islandInfo[iWord].is_known[OPEN,even]:=[0..31]; + end +end; + +procedure record_solution(var s:Soln); + +var spun:soln; + +begin + s.setcells; + inc(m_nSoln,2); {add solution and its rotation} + + if m_minSoln.isEmpty then + begin + m_minSoln := s; + m_maxSoln := s; + exit; + end; + + if s.lessThan(m_minSoln) then + m_minSoln := s + else if m_maxSoln.lessThan(s) then + m_maxSoln := s; + + s.spin(spun); + if spun.lessThan(m_minSoln) then + m_minSoln := spun + else if m_maxSoln.lessThan(spun) then + m_maxSoln := spun; +end; + +function gen_all_solutions(boardVec,placedPieces:bitvec;row:byte):cardinal; + +var ipiece:piecenr; + iorient:byte; + piece:bitvec; + +begin + while boardVec*TOP_ROW=TOP_ROW do + begin + cardinal(boardVec):=cardinal(boardvec) shr N_COL; + inc(row); + end; + gen_all_solutions:=0; + with cache[((cardinal(boardvec)* + (cardinal(placedpieces) {shl 3} + 1) + xor row shl 5)) mod 131071] do + if (krow<>row) or (bitvec(cardinal(kpiecevec))<>placedpieces) or (kboardvec<>boardvec) then + begin + with g_okpieces[row,s_firstOne[cardinal([0..N_COL-1]-boardVec)]] do + for ipiece:=0 to N_PIECE_TYPE-1 do + if not(ipiece in placedpieces) then + for iorient:=1 to npieces[ipiece] do {start with 1, npieces[x] can be zero} + begin + piece:=pieceVec[iPiece,iOrient-1]; + {check if piece conflicts with other pieces or if we get a bad island.} + if (piece*boardVec=[]) and (has_bad_islands(boardVec+piece,row)=good) then + begin + m_curSoln.pushPiece(piece,iPiece,row); + {recurse or record solution} + if placedPieces+[ipiece]<>ALL_PIECE_MASK then + inc(gen_all_solutions,gen_all_solutions(boardVec+piece,placedPieces+[ipiece],row)) + else + begin + record_solution(m_curSoln); + inc(gen_all_solutions); + end; + m_curSoln.popPiece(); + end; + end; + if gen_all_solutions=0 then + begin + krow:=row; + kpiecevec:=word(cardinal(placedpieces)); + kboardvec:=boardvec; + end; + end; +end; + +begin + if paramcount > 2 then + halt(1); {spec says this is an error} + + textrec(output).flushfunc:=nil; + + gen_all_orientations; + calc_always_bad; + init_board; + filldword(cache,sizeof(cache) shr 2,$ffffffff); + gen_all_solutions([], [], 0); + + writeln(m_nSoln,' solutions found'); + writeln; + m_minSoln.write(output); + writeln; + m_maxSoln.write(output); + writeln; +end.