15 puzzle solver
You are encouraged to solve this task according to the task description, using any language you may know.
Your task is to write a program that finds a solution in the fewest moves possible single moves to a random Fifteen Puzzle Game.
For this task you will be using the following puzzle:
15 14 1 6 9 11 4 12 0 10 7 3 13 8 5 2
Solution:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 0
The output must show the moves' directions, like so: left, left, left, down, right... and so on.
There are two solutions, of fifty-two moves:
rrrulddluuuldrurdddrullulurrrddldluurddlulurruldrdrd
rrruldluuldrurdddluulurrrdlddruldluurddlulurruldrrdd
see: Pretty Print of Optimal Solution
Finding either one, or both is an acceptable result.
Those sequences describe the moves of the empty square. If instead naming the move directions of actual squares (using capital letters), the sequences are:
LLLDRUURDDDRULDLUUULDRRDRDLLLUURURDDLUURDRDLLDRULULU
LLLDRURDDRULDLUUURDDRDLLLURUULDRURDDLUURDRDLLDRULLUU
Naming the moves of the empty square encourages thought of a variation: consider repeated moves in the same direction as being one "shove" of a compound move. A run-length encoding of the first solution would be r3uld2lu3ldrurd3rul2ulur3d2ldlu2rd2lulur2uldrdrd which employs thirty-eight shoves. But u2r2d3ru2ld2ru3ld3l2u3r2d2l2dru3rd3l2u2r3dl3dru2r2d2 employs thirty-one shoves, though it expands to uurrdddruulddruuuldddlluuurrddlldruuurdddlluurrrdllldruurrdd which has sixty single-square moves.
- Extra credit.
Solve the following problem:
0 12 9 13 15 11 10 14 3 7 2 5 4 8 6 1
- Related Task
C++
Staying Functional (as possible in C++)
The Solver
<lang cpp> // Solve Random 15 Puzzles : Nigel Galloway - October 11th., 2017 const int Nr[]{3,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3}, Nc[]{3,0,1,2,3,0,1,2,3,0,1,2,3,0,1,2}; using N = std::tuple<int,int,unsigned long,std::string,int>; void fN(const N,const int); const N fI(const N n){
int g = (11-std::get<1>(n)-std::get<0>(n)*4)*4; unsigned long a = std::get<2>(n)&((unsigned long)15<<g); return N (std::get<0>(n)+1,std::get<1>(n),std::get<2>(n)-a+(a<<16),std::get<3>(n)+"d",(Nr[a>>g]<=std::get<0>(n))?std::get<4>(n):std::get<4>(n)+1);
} const N fG(const N n){
int g = (19-std::get<1>(n)-std::get<0>(n)*4)*4; unsigned long a = std::get<2>(n)&((unsigned long)15<<g); return N (std::get<0>(n)-1,std::get<1>(n),std::get<2>(n)-a+(a>>16),std::get<3>(n)+"u",(Nr[a>>g]>=std::get<0>(n))?std::get<4>(n):std::get<4>(n)+1);
} const N fE(const N n){
int g = (14-std::get<1>(n)-std::get<0>(n)*4)*4; unsigned long a = std::get<2>(n)&((unsigned long)15<<g); return N (std::get<0>(n),std::get<1>(n)+1,std::get<2>(n)-a+(a<<4),std::get<3>(n)+"r",(Nc[a>>g]<=std::get<1>(n))?std::get<4>(n):std::get<4>(n)+1);
} const N fL(const N n){
int g = (16-std::get<1>(n)-std::get<0>(n)*4)*4; unsigned long a = std::get<2>(n)&((unsigned long)15<<g); return N (std::get<0>(n),std::get<1>(n)-1,std::get<2>(n)-a+(a>>4),std::get<3>(n)+"l",(Nc[a>>g]>=std::get<1>(n))?std::get<4>(n):std::get<4>(n)+1);
} void fZ(const N n, const int g){
if (std::get<2>(n)==0x123456789abcdef0){
int g{};for (char a: std::get<3>(n)) ++g;
std::cout<<"Solution found with "<<g<<" moves: "<<std::get<3>(n)<<std::endl; exit(0);}
if (std::get<4>(n) <= g) fN(n,g);
} void fN(const N n, const int g){
const int i{std::get<0>(n)}, e{std::get<1>(n)}, l{std::get<3>(n).back()};
switch(i){case 0: switch(e){case 0: switch(l){case 'l': fZ(fI(n),g); return;
case 'u': fZ(fE(n),g); return;
default : fZ(fE(n),g); fZ(fI(n),g); return;}
case 3: switch(l){case 'r': fZ(fI(n),g); return;
case 'u': fZ(fL(n),g); return;
default : fZ(fL(n),g); fZ(fI(n),g); return;}
default: switch(l){case 'l': fZ(fI(n),g); fZ(fL(n),g); return;
case 'r': fZ(fI(n),g); fZ(fE(n),g); return;
case 'u': fZ(fE(n),g); fZ(fL(n),g); return;
default : fZ(fL(n),g); fZ(fI(n),g); fZ(fE(n),g); return;}}
case 3: switch(e){case 0: switch(l){case 'l': fZ(fG(n),g); return;
case 'd': fZ(fE(n),g); return;
default : fZ(fE(n),g); fZ(fG(n),g); return;}
case 3: switch(l){case 'r': fZ(fG(n),g); return;
case 'd': fZ(fL(n),g); return;
default : fZ(fL(n),g); fZ(fG(n),g); return;}
default: switch(l){case 'l': fZ(fG(n),g); fZ(fL(n),g); return;
case 'r': fZ(fG(n),g); fZ(fE(n),g); return;
case 'd': fZ(fE(n),g); fZ(fL(n),g); return;
default : fZ(fL(n),g); fZ(fG(n),g); fZ(fE(n),g); return;}}
default: switch(e){case 0: switch(l){case 'l': fZ(fI(n),g); fZ(fG(n),g); return;
case 'u': fZ(fE(n),g); fZ(fG(n),g); return;
case 'd': fZ(fE(n),g); fZ(fI(n),g); return;
default : fZ(fE(n),g); fZ(fI(n),g); fZ(fG(n),g); return;}
case 3: switch(l){case 'd': fZ(fI(n),g); fZ(fL(n),g); return;
case 'u': fZ(fL(n),g); fZ(fG(n),g); return;
case 'r': fZ(fI(n),g); fZ(fG(n),g); return;
default : fZ(fL(n),g); fZ(fI(n),g); fZ(fG(n),g); return;}
default: switch(l){case 'd': fZ(fI(n),g); fZ(fL(n),g); fZ(fE(n),g); return;
case 'l': fZ(fI(n),g); fZ(fL(n),g); fZ(fG(n),g); return;
case 'r': fZ(fI(n),g); fZ(fE(n),g); fZ(fG(n),g); return;
case 'u': fZ(fE(n),g); fZ(fL(n),g); fZ(fG(n),g); return;
default : fZ(fL(n),g); fZ(fI(n),g); fZ(fE(n),g); fZ(fG(n),g); return;}}}
} void Solve(N n){for(int g{};;++g) fN(n,g);} </lang>
The Task
<lang cpp> int main (){
N start(2,0,0xfe169b4c0a73d852,"",0); Solve(start);
} </lang>
- Output:
Solution found with 52 moves: rrrulddluuuldrurdddrullulurrrddldluurddlulurruldrdrd real 0m2.897s user 0m2.887s sys 0m0.008s
Time to get Imperative
see for an analysis of 20 randomly generated 15 puzzles solved with this solver.
The Solver
<lang cpp> // Solve Random 15 Puzzles : Nigel Galloway - October 18th., 2017 class fifteenSolver{
const int Nr[16]{3,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3}, Nc[16]{3,0,1,2,3,0,1,2,3,0,1,2,3,0,1,2}, i{1}, g{8}, e{2}, l{4};
int n{},_n{}, N0[85]{},N3[85]{},N4[85]{};
unsigned long N2[85]{};
const bool fY(){
if (N2[n]==0x123456789abcdef0) return true;
if (N4[n]<=_n) return fN();
return false;
}
const bool fZ(const int w){
if ((w&i)>0){fI(); if (fY()) return true;--n;}
if ((w&g)>0){fG(); if (fY()) return true;--n;}
if ((w&e)>0){fE(); if (fY()) return true;--n;}
if ((w&l)>0){fL(); if (fY()) return true;--n;}
return false;
}
const bool fN(){
switch(N0[n]){case 0: switch(N3[n]){case 'l': return fZ(i);
case 'u': return fZ(e);
default : return fZ(i+e);}
case 3: switch(N3[n]){case 'r': return fZ(i);
case 'u': return fZ(l);
default : return fZ(i+l);}
case 1: case 2: switch(N3[n]){case 'l': return fZ(i+l);
case 'r': return fZ(i+e);
case 'u': return fZ(e+l);
default : return fZ(l+e+i);}
case 12: switch(N3[n]){case 'l': return fZ(g);
case 'd': return fZ(e);
default : return fZ(e+g);}
case 15: switch(N3[n]){case 'r': return fZ(g);
case 'd': return fZ(l);
default : return fZ(g+l);}
case 13: case 14: switch(N3[n]){case 'l': return fZ(g+l);
case 'r': return fZ(e+g);
case 'd': return fZ(e+l);
default : return fZ(g+e+l);}
case 4: case 8: switch(N3[n]){case 'l': return fZ(i+g);
case 'u': return fZ(g+e);
case 'd': return fZ(i+e);
default : return fZ(i+g+e);}
case 7: case 11: switch(N3[n]){case 'd': return fZ(i+l);
case 'u': return fZ(g+l);
case 'r': return fZ(i+g);
default : return fZ(i+g+l);}
default: switch(N3[n]){case 'd': return fZ(i+e+l);
case 'l': return fZ(i+g+l);
case 'r': return fZ(i+g+e);
case 'u': return fZ(g+e+l);
default : return fZ(i+g+e+l);}}
}
void fI(){
const int g = (11-N0[n])*4;
const unsigned long a = N2[n]&((unsigned long)15<<g);
N0[n+1]=N0[n]+4; N2[n+1]=N2[n]-a+(a<<16); N3[n+1]='d'; N4[n+1]=N4[n]+(Nr[a>>g]<=N0[n++]/4?0:1);
}
void fG(){
const int g = (19-N0[n])*4;
const unsigned long a = N2[n]&((unsigned long)15<<g);
N0[n+1]=N0[n]-4; N2[n+1]=N2[n]-a+(a>>16); N3[n+1]='u'; N4[n+1]=N4[n]+(Nr[a>>g]>=N0[n++]/4?0:1);
}
void fE(){
const int g = (14-N0[n])*4;
const unsigned long a = N2[n]&((unsigned long)15<<g);
N0[n+1]=N0[n]+1; N2[n+1]=N2[n]-a+(a<<4); N3[n+1]='r'; N4[n+1]=N4[n]+(Nc[a>>g]<=N0[n++]%4?0:1);
}
void fL(){
const int g = (16-N0[n])*4;
const unsigned long a = N2[n]&((unsigned long)15<<g);
N0[n+1]=N0[n]-1; N2[n+1]=N2[n]-a+(a>>4); N3[n+1]='l'; N4[n+1]=N4[n]+(Nc[a>>g]>=N0[n++]%4?0:1);
}
public:
fifteenSolver(int n, unsigned long g){N0[0]=n; N2[0]=g; N4[0]=0;}
void Solve(){
if (fN()) {std::cout<<"Solution found in "<<n<<" moves: "; for (int g{1};g<=n;++g) std::cout<<(char)N3[g]; std::cout<<std::endl;}
else {n=0; ++_n; Solve();}
}
}; </lang>
The Task
<lang cpp> int main (){
fifteenSolver start(8,0xfe169b4c0a73d852); start.Solve();
} </lang>
- Output:
Solution found in 52 moves: rrrulddluuuldrurdddrullulurrrddldluurddlulurruldrdrd real 0m0.795s user 0m0.794s sys 0m0.000s
Extra Credit
I have updated the 20 random examples, which showed n the number of moves to include _n. As seen when _n is less than 10 the puzzle is solved quickly. This suggests a multi-threading strategy. I have 8 cores available. Modifying solve so that it starts a thread for _n=0 to _n=9, 1 for _n=10, 1 for _n=11, 1 for _n=12, and 1 for _n=13 tests that the fan is still working and turns the computer into a hair-dryer. It also finds the following solution to the extra credit task:
Solution found in 80 moves: dddrurdruuulllddrulddrrruuullddruulldddrrurulldrruulldlddrurullddrrruullulddrdrr
in 29m19.973s.
It also solves the 5th. example which requires 29.3s single threaded in 7s.
Fortran
The Plan
There is a straightforward method for dealing with problems of this sort, the Red Tide. Imagine a maze and pouring red-dyed water into the "entry" - eventually, red water issues forth from the exit, or, back pressure will indicate that there is no such path. In other words, from the starting position find all possible positions that can be reached in one step, then from those positions, all possible positions that can be reached in one step from them, and so on. Eventually, either the stopping position will be reached, or, there will be no more new (still dry) positions to inspect. What is needed is some way of recording whether a position has been marked red or not, and an arrangement for identifying positions that are on the leading edge of the tide as it spreads. Keeping as well some sort of information identifying the path followed by each droplet, so that when a droplet spreads to the end position, its path from the source can be listed.
One could imagine an array FROM whose value for a given position identifies the position from which a step was taken to reach it. The value could be a number identifying that position or be a (sixteen element) list of the placement of the tiles. An index for FROM would span the values zero to fifteen, and there would be sixteen dimensions...
The Code
The source code started off as a mainline only, but then as facilities were added and service routines became helpful. This prompted the use of F90's MODULE facility so that the PARAMETER statement could be used to describe the shape of the board with this available to each routine without the need for passing the values as parameters or messing with COMMON storage, or repeating the PARAMETER statement in each routine. Otherwise, literal constants such as 4 would appear in various places. These appearances could now be documented by using the appropriate name such as NR and NC rather than just 4 and similar. However, inside FORMAT statements the use of <NR - 1> (and not <NC - 1>) rather than 3 will succeed only if the compiler accepts this usage, and not all do. More complex calculations involving the board size have not been attempted. The PARAMETER facility is useful only for simple calculations. Considerations such as a 4x4 board having 16 squares is easy, but the consequences of this count fitting into a four-bit binary field are not, thus the equivalences involving BOARD, BORED and BOAR are not general for different board shapes, nor are the column headings adjustable. Similarly, subroutine UNPACK does not attempt to use a loop but employs explicit code.
This approach is followed in the calculation of the hash code, by writing out the product rather than using the compilers built-in PRODUCT and a startling difference results:
59: H = MOD(ABS(PRODUCT(BRD)),APRIME) 004016E3 mov esi,1 004016E8 mov ecx,1 004016ED cmp ecx,2 004016F0 jg MAIN$SLIDESOLVE+490h (0040171e) 004016F2 cmp ecx,1 004016F5 jl MAIN$SLIDESOLVE+46Eh (004016fc) 004016F7 cmp ecx,2 004016FA jle MAIN$SLIDESOLVE+477h (00401705) 004016FC xor eax,eax 004016FE mov dword ptr [ebp-54h],eax 00401701 dec eax 00401702 bound eax,qword ptr [ebp-54h] 00401705 imul edx,ecx,4 00401708 mov edx,dword ptr H (00473714)[edx] 0040170E imul edx,esi 00401711 mov esi,edx 00401713 mov eax,ecx 00401715 add eax,1 0040171A mov ecx,eax 0040171C jmp MAIN$SLIDESOLVE+45Fh (004016ed) 0040171E mov eax,esi 00401720 cmp eax,0 00401725 jge MAIN$SLIDESOLVE+49Bh (00401729) 00401727 neg eax 00401729 mov edx,10549h 0040172E mov dword ptr [ebp-54h],edx 00401731 cdq 00401732 idiv eax,dword ptr [ebp-54h] 00401735 mov eax,edx 00401737 mov dword ptr [H (00473714)],eax 60: write (6,*) H,bored
Whereas by writing out the product,
59: H = MOD(ABS(BRD(1)*BRD(2)),APRIME) 004016E3 mov eax,dword ptr [BRD (00473718)] 004016E9 imul eax,dword ptr [BRD+4 (0047371c)] 004016F0 cmp eax,0 004016F5 jge MAIN$SLIDESOLVE+46Bh (004016f9) 004016F7 neg eax 004016F9 mov esi,10549h 004016FE cdq 004016FF idiv eax,esi 00401701 mov eax,edx 00401703 mov dword ptr [H (00473714)],eax 60: write (6,*) H,bored
Granted a flexible pre-processor scheme (as in pl/i, say) one could imagine a menu of tricks being selected from according to the board shape specified, but without such a facility, the constants are merely named rather than literal.
Source
<lang Fortran> SUBROUTINE PROUST(T) !Remembrance of time passed.
DOUBLE PRECISION T !The time, in seconds. Positive only, please.
DOUBLE PRECISION S !A copy I can mess with.
TYPE TIMEWARP !Now prepare a whole lot of trickery for expressing the wait time.
INTEGER LIMIT !The upper limit for the usage.
INTEGER STEP !Conversion to the next unit.
CHARACTER*4 NAME !A suitable abbreviated name for the accepted unit.
END TYPE TIMEWARP !Enough of this.
INTEGER CLOCKCRACK !How many different units might I play with?
PARAMETER (CLOCKCRACK = 5) !This should so.
TYPE(TIMEWARP) TIME(CLOCKCRACK) !One set, please.
PARAMETER (TIME = (/ !The mention of times lost has multiple registers.
1 TIMEWARP(99, 60,"secs"), !Beware 99.5+ rounding up to 100.
2 TIMEWARP(99, 60,"mins"), !Likewise with minutes.
3 TIMEWARP(66, 24,"hrs!"), !More than a few days might as well be in days.
4 TIMEWARP(99,365,"days"), !Too many days, and we will speak of years.
5 TIMEWARP(99,100,"yrs!")/)) !And the last gasp converts to centuries.
INTEGER CC !A stepper for these selections.
CHARACTER*4 U !The selected unit.
INTEGER MSG !The mouthpiece.
COMMON/IODEV/ MSG !Used in common.
S = T !A working copy.
DO CC = 1,CLOCKCRACK !Now re-assess DT, with a view to announcing a small number.
IF (S.LE.TIME(CC).LIMIT) THEN !Too big a number?
U = TIME(CC).NAME !No, this unit will suffice.
GO TO 10 !Make off to use it.
END IF !But if the number is too big,
S = S/TIME(CC).STEP !Escalate to the next larger unit.
END DO !And see if that will suffice.
U = "Cys!!" !In case there are too many years, this is the last gasp.
10 WRITE (MSG,11) S,U !Say it.
11 FORMAT (F7.1,A4,$) !But don't finish the line.
END SUBROUTINE PROUST !A sigh.
CHARACTER*15 FUNCTION HMS(T) !Report the time of day.
Careful! Finite precision and binary/decimal/sexagesimal conversion could cause 2:30:00am. to appear as 2:29:60am.
DOUBLE PRECISION S,T !Seconds (completed) into the day.
INTEGER H,M !More traditional units are to be extracted.
INTEGER SECONDSINDAY !A canonical day.
PARAMETER (SECONDSINDAY = 24*60*60) !Of nominal seconds.
CHARACTER*15 TEXT !A scratchpad.
H = T !Truncate into an integer.
S = T - (H - 1)/SECONDSINDAY*SECONDSINDAY !Thus allow for midnight = hour 24.
IF (S.EQ.SECONDSINDAY/2) THEN !This might happen.
TEXT = "High Noon!" !Though the chances are thin.
ELSE IF (S.EQ.SECONDSINDAY) THEN !This is synonymous with the start of the next day.
TEXT = "Midnight!" !So this presumably won't happen.
ELSE !But more likely are miscellaneous values.
H = S/3600 !Convert seconds into whole hours completed.
S = S - H*3600 !The remaining time.
M = S/60 !Seconds into minutes completed.
S = S - M*60 !Remove them.
IF (S .GE. 59.9995D0) THEN !Via format F6.3, will this round up to 60?
S = 0 !Yes. Curse recurring binary sequences for decimal.
M = M + 1 !So, up the minute count.
IF (M.GE.60) THEN !Is there an overflow here too?
M = 0 !Yes.
H = H + 1 !So might appear 24:00:00.000 though it not be Midnight!
END IF !So much for twiddling the minutes.
END IF !And twiddling the hours.
IF (H.LT.12) THEN !A plague on the machine mentality.
WRITE (TEXT,1) H,M,S,"am." !Ante-meridian.
1 FORMAT (I2,":",I2,":",F6.3,A3) !Thus.
ELSE !For the post-meridian, H >= 12.
IF (H.GT.12) H = H - 12 !Adjust to civil usage. NB! 12 appears.
WRITE (TEXT,1) H,M,S,"pm." !Thus. Post-meridian.
END IF !So much for those fiddles.
IF (TEXT(4:4).EQ." ") TEXT(4:4) = "0" !Now help hint that the
IF (TEXT(7:7).EQ." ") TEXT(7:7) = "0" ! character string is one entity.
END IF !So much for preparation.
HMS = TEXT !The result.
END FUNCTION HMS !Possible compiler confusion if HMS is invoked in a WRITE statement.
DOUBLE PRECISION FUNCTION NOWWAS(WOT) !Ascertain the local time for interval assessment.
Compute with whole day numbers, to avoid day rollover annoyances. Can't use single precision and expect much discrimination within a day. C I'd prefer a TIMESTAMP(Local) and a TIMESTAMP(GMT) system function. C Quite likely, the system separates its data to deliver the parameters, which I then re-glue.
INTEGER WOT !What sort of time do I want?
REAL*8 TIME !A real good time.
INTEGER MARK(8) !The computer's clock time will appear here, but fragmented.
IF (WOT.LE.0) THEN !Just the CPU time for this.
CALL CPU_TIME(TIME) !Apparently in seconds since starting.
ELSE !But normally, I want a time-of-day now.
CALL DATE_AND_TIME(VALUES = MARK) !Unpack info that I will repack.
c WRITE (6,1) MARK c 1 FORMAT ("The computer clock system reports:", c 1 /"Year",I5,", Month",I3,", Day",I3, c 2 /" Minutes from GMT",I5, c 3 /" Hour",I3,", Minute",I3,",Seconds",I3,".",I3)
TIME = (MARK(5)*60 + MARK(6))*60 + MARK(7) + MARK(8)/1000D0 !By the millisecond, to seconds.
IF (WOT.GT.1) TIME = TIME - MARK(4)*60 !Shift back to GMT, which may cross a day boundary.
c TIME = DAYNUM(MARK(1),MARK(2),MARK(3)) + TIME/SECONDSINDAY !The fraction of a day is always less than 1 as MARK(5) is declared < 24.
TIME = MARK(3)*24*60*60 + TIME !Not bothering with DAYNUM, and converting to use seconds rather than days as the unit.
END IF !A simple number, but, multiple trickeries. The GMT shift includes daylight saving's shift...
NOWWAS = TIME !Thus is the finger of time found.
END FUNCTION NOWWAS !But the Hand of Time has already moved on.
MODULE SLIDESOLVE !Collect the details for messing with the game board.
INTEGER NR,NC,N !Give names to some sizes.
PARAMETER (NR = 4, NC = 4, N = NR*NC) !The shape of the board.
INTEGER*1 BOARD(N),TARGET(N),ZERO(N) !Some scratchpads.
INTEGER BORED(4) !A re-interpretation of the storage containing the BOARD.
CHARACTER*(N) BOAR !Another, since the INDEX function only accepts these.
EQUIVALENCE (BORED,BOARD,BOAR) !All together now!
CHARACTER*1 DIGIT(0:35) !This will help to translate numbers to characters.
PARAMETER (DIGIT = (/"0","1","2","3","4","5","6","7","8","9",
1 "A","B","C","D","E","F","G","H","I","J", !I don't anticipate going beyond 15.
2 "K","L","M","N","O","P","Q","R","S","T", !But, for completeness...
3 "U","V","W","X","Y","Z"/)) !Add a few more.
CONTAINS
SUBROUTINE SHOW(NR,NC,BOARD) !The layout won't work for NC > 99...
INTEGER NR,NC !Number of rows and columns.
INTEGER*1 BOARD(NC,NR) !The board is stored transposed, in Furrytran!
INTEGER R,C !Steppers.
INTEGER MSG !Keep the compiler quiet.
COMMON/IODEV/ MSG !I talk to the trees...
WRITE (MSG,1) (C,C = 1,NC) !Prepare a heading.
1 FORMAT ("Row|",9("__",I1,:),90("_",I2,:)) !This should suffice.
DO R = 1,NR !Chug down the rows, for each showing a succession of columns.
WRITE (MSG,2) R,BOARD(1:NC,R) !Thus, successive elements of storage. Storage style is BOARD(column,row).
2 FORMAT (I3,"|",99I3) !Could use parameters, but enough.
END DO !Show columns across and rows down, despite the storage order.
END SUBROUTINE SHOW !Remember to transpose the array an odd number of times.
SUBROUTINE UNCRAM(IT,BOARD) !Recover the board layout..
INTEGER IT(2) !Two 32-bit integers hold 16 four-bit fields in a peculiar order.
INTEGER*1 BOARD(*) !This is just a simple, orderly sequence of integers.
INTEGER I,HIT !Assistants.
DO I = 0,8,8 !Unpack into the work BOARD.
HIT = IT(I/8 + 1) !Grab eight positions, in four bits each..
BOARD(I + 5) = IAND(HIT,15) !The first is position 5.
HIT = ISHFT(HIT,-4); BOARD(I + 1) = IAND(HIT,15) !Hex 48372615
HIT = ISHFT(HIT,-4); BOARD(I + 6) = IAND(HIT,15) !and C0BFAE9D
HIT = ISHFT(HIT,-4); BOARD(I + 2) = IAND(HIT,15) !For BOARD(1) = 1, BOARD(2) = 2,...
HIT = ISHFT(HIT,-4); BOARD(I + 7) = IAND(HIT,15) !This computer is (sigh) little-endian.
HIT = ISHFT(HIT,-4); BOARD(I + 3) = IAND(HIT,15) !Rather than mess with more loops,
HIT = ISHFT(HIT,-4); BOARD(I + 8) = IAND(HIT,15) !Explicit code is less of a brain strain.
HIT = ISHFT(HIT,-4); BOARD(I + 4) = IAND(HIT,15) !And it should run swiftly, too...
END DO !Only two of them.
END SUBROUTINE UNCRAM !A different-sized board would be a problem too.
INTEGER*8 FUNCTION ZDIST(BOARD) !Encode the board's positions against the ZERO sequence.
INTEGER*1 BOARD(N) !The values of the squares.
LOGICAL*1 AVAIL(N) !The numbers will be used one-by-one to produce ZC.
INTEGER BASE !This is not a constant, such as ten.
INTEGER M,IT !Assistants.
AVAIL = .TRUE. !All numbers are available.
BASE = N !The first square has all choices.
ZDIST = 0 !Start the encodement of choices.
DO M = 1,N !Step through the board's squares.
IT = BOARD(M) !Grab the square's number. It is the index into ZERO.
IF (IT.EQ.0) IT = N !But in ZERO, the zero is at the end, damnit.
AVAIL(IT) = .FALSE. !This number is now used.
ZDIST = ZDIST*BASE + COUNT(AVAIL(1:IT - 1)) !The number of available values to skip to reach it.
BASE = BASE - 1 !Option count for the next time around.
END DO !On to the next square.
END FUNCTION ZDIST !ZDIST(ZERO) = 0.
SUBROUTINE REPORT(R,WHICH,MOVE,BRD) !Since this is invoked in two places.
INTEGER R !The record number of the position.
CHARACTER*(*) WHICH !In which stash.
CHARACTER*1 MOVE !The move code.
INTEGER BRD(2) !The crammed board position.
INTEGER*1 BOARD(N) !Uncrammed for nicer presentation.
INTEGER*8 ZC !Encodes the position in a mixed base.
INTEGER ZM,ZS !Alternate forms of distance.
DOUBLE PRECISION ZE !This is Euclidean.
INTEGER MSG !Being polite about usage,
COMMON/IODEV/MSG !Rather than mysterious constants.
CALL UNCRAM(BRD,BOARD) !Isolate the details.
ZM = MAXVAL(ABS(BOARD - ZERO)) !A norm. |(x,y)| = r gives a square shape.
ZS = SUM(ABS(BOARD - ZERO)) !A norm. |(x,y)| = r gives a diamond shape.
ZE = SQRT(DFLOAT(SUM((BOARD - ZERO)**2))) !A norm. |(x,y)| = r gives a circle.
ZC = ZDIST(BOARD) !Encodement against ZERO.
WRITE (MSG,1) R,WHICH,MOVE,DIGIT(BOARD),ZM,ZS,ZE,ZC !After all that,
1 FORMAT (I11,A6,A5,1X,"|",<NR - 1>(<NC>A1,"/"),<NC>A1,"|", !Show the move and the board
1 2I8,F12.3,I18) !Plus four assorted distances.
END SUBROUTINE REPORT !Just one line is produced.
SUBROUTINE PURPLE HAZE(BNAME) !Spreads a red and a blue tide.
CHARACTER*(*) BNAME !Base name for the work files.
CHARACTER*(N) BRAND !Name part based on the board sequence.
CHARACTER*(LEN(BNAME) + 1 + N + 4) FNAME !The full name.
Collect the details for messing with the game board.
CHARACTER*4 TIDE(2) !Two tides will spread forth.
PARAMETER (TIDE = (/" Red","Blue"/)) !With these names.
INTEGER LZ,LOCZ(2),LOCI(2),ZR,ZC !Location via row and column.
EQUIVALENCE(LOCZ(1),ZR),(LOCZ(2),ZC) !Sometimes separate, sometimes together.
INTEGER WAY(4),HENCE,W,M,D,WAYS(2,4) !Direction codes.
PARAMETER (WAY = (/ +1, -NC, -1, +NC/)) !Directions for the zero square, in one dimension.
PARAMETER (WAYS = (/0,+1, -1,0, 0,-1, +1,0/)) !The same, but in (row,column) style.
CHARACTER*1 WNAMEZ(0:4),WNAMEF(0:4) !Names for the directions.
PARAMETER (WNAMEZ = (/" ","R","U","L","D"/)) !The zero square's WAYS.
PARAMETER (WNAMEF = (/" ","L","D","R","U"/)) !The moved square's ways are opposite.
Create two hashed stashes. A stash file and its index file, twice over.
INTEGER APRIME !Determines the size of the index.
PARAMETER (APRIME = 199 999 991) !Prime 11078917. Prime 6666666 = 116 743 349. Perhaps 1999999973?
INTEGER HCOUNT(2),NINDEX(2) !Counts the entries in the stashes and their indices.
INTEGER P,HIT !Fingers to entries in the stash.
INTEGER SLOSH,HNEXT !Advances from one surge to the next.
INTEGER IST(2),LST(2),SURGE(2) !Define the perimeter of a surge.
INTEGER HEAD,LOOK !For chasing along a linked-list of records.
TYPE AREC !Stores the board position, and helpful stuff.
INTEGER NEXT !Links to the next entry that has the same hash value.
INTEGER PREV !The entry from which this position was reached.
INTEGER MOVE !By moving the zero in this WAY.
INTEGER BRD(2) !Squeezed representation of the board position.
END TYPE AREC !Greater compaction (especially of MOVE) would require extra crunching.
INTEGER LREC !Record length, in INTEGER-size units. I do some counting.
PARAMETER (LREC = 5) !For the OPEN statement.
TYPE(AREC) ASTASH,APROBE !I need two scratchpads.
INTEGER NCHECK !Number of new positions considered.
INTEGER NLOOK(2),PROBES(2),NP(2),MAXP(2)!Statistics for the primary and secondary searches resulting.
LOGICAL SURGED(2) !A SLOSH might not result in a SURGE.
Catch the red/blue meetings, if any.
INTEGER MANY,LONG !They may be many, and, long.
PARAMETER (MANY = 666,LONG = 66) !This should do.
INTEGER NMET,MET(2,MANY) !Identify the meeting positions, in their own stash.
INTEGER NTRAIL,TRAIL(LONG) !Needed to follow the moves.
INTEGER NS,LS(MANY) !Count the shove sequences.
CHARACTER*128 SHOVE(MANY) !Record them.
Conglomeration of support stuff.
LOGICAL EXIST !For testing the presence of a disc file.
INTEGER I,IT !Assistants.
DOUBLE PRECISION T1,T2,E1,E2,NOWWAS !Time details.
CHARACTER*15 HMS !A clock.
INTEGER MSG,KBD,WRK(2),NDX(2) !I/O unit numbers.
COMMON/IODEV/ MSG,KBD,WRK,NDX !I talk to the trees...
NS = 0 !No shove sequences have been found.
Concoct some disc files for storage areas, reserving the first record of each as a header.
10 BOARD = ZERO !The red tide spreads from "zero".
DO W = 1,2 !Two work files are required.
WRITE(MSG,11) TIDE(W) !Which one this time?
11 FORMAT (/,"Tide ",A) !Might as well supply a name.
DO I = 1,N !Produce a text sequence for the board layout.
BRAND(I:I) = DIGIT(BOARD(I)) !One by one...
END DO !BRAND = DIGIT(BOARD)
FNAME = BNAME//"."//BRAND//".dat" !It contains binary stuff, so what else but data?
INQUIRE (FILE = FNAME, EXIST = EXIST) !Perhaps it is lying about.
20 IF (EXIST) THEN !Well?
WRITE (MSG,*) "Restarting from file ",FNAME !One hopes its content is good.
OPEN (WRK(W),FILE = FNAME,STATUS = "OLD",ACCESS = "DIRECT", !Random access is intended.
1 FORM = "UNFORMATTED",BUFFERED = "YES",RECL = LREC) !Using record numbers as the key.
FNAME = BNAME//"."//BRAND//".ndx" !Now go for the accomplice.
INQUIRE (FILE = FNAME, EXIST = EXIST) !That contains the index.
IF (.NOT.EXIST) THEN !Well?
WRITE (MSG,*) " ... except, no file ",FNAME !Oh dear.
CLOSE(WRK(W)) !So, no index for the work file. Abandon it.
GO TO 20 !And thus jump into the ELSE clause below.
END IF !Seeing as an explicit GO TO would be regarded as improper...
READ (WRK(W),REC = 1) HCOUNT(W),SURGE(W),IST(W),LST(W)!Get the header information.
WRITE (MSG,22) HCOUNT(W),SURGE(W),IST(W),LST(W) !Reveal.
22 FORMAT (" Stashed ",I0,". At surge ",I0, !Perhaps it will be corrupt.
1 " with the boundary stashed in elements ",I0," to ",I0) !If so, this might help the reader.
OPEN (NDX(W),FILE = FNAME,STATUS = "OLD",ACCESS="DIRECT", !Now for the accomplice.
1 FORM = "UNFORMATTED",BUFFERED = "YES",RECL = 1) !One INTEGER per record.
READ(NDX(W), REC = 1) NINDEX(W) !This count is maintained, to avoid a mass scan.
WRITE (MSG,23) NINDEX(W),APRIME !Exhibit the count.
23 FORMAT (" Its index uses ",I0," of ",I0," entries.") !Simple enough.
ELSE !But, if there is no stash, create a new one.
WRITE (MSG,*) "Preparing a stash in file ",FNAME !Start from scratch.
OPEN (WRK(W),FILE = FNAME,STATUS="REPLACE",ACCESS="DIRECT", !I intend non-sequential access...
1 FORM = "UNFORMATTED",BUFFERED = "YES",RECL = LREC) !And, not text.
HCOUNT(W) = 1 !Just one position is known, the final position.
SURGE(W) = 0 !It has not been clambered away from.
IST(W) = 1 !The first to inspect at the current level.
LST(W) = 1 !The last.
WRITE (WRK(W),REC = 1) HCOUNT(W),SURGE(W),IST(W),LST(W),0 !The header.
FNAME = BNAME//"."//BRAND//".ndx" !Now for the associated index file..
WRITE (MSG,*) "... with an index in file ",FNAME !Announce before attempting access.
OPEN (NDX(W),FILE = FNAME,STATUS = "REPLACE",ACCESS= !Lest there be a mishap.
1 "DIRECT",FORM = "UNFORMATTED",BUFFERED = "YES",RECL = 1) !Yep. Just one value per record.
WRITE (MSG,*) APRIME," zero values for an empty index." !This may cause a pause.
NINDEX(W) = 1 !The index will start off holding one used entry.
WRITE (NDX(W),REC = 1) NINDEX(W) !Save this count in the header record.
WRITE (NDX(W),REC = 1 + APRIME) 0 !Zero values will also appear in the gap!
ASTASH.NEXT = 0 !The first index emtry can never collide with another in an empty index.
ASTASH.PREV = 0 !And it is created sufficient unto itself.
ASTASH.MOVE = 0 !Thus, it is not a descendant, but immaculate.
ASTASH.BRD(1) = BORED(1)*16 + BORED(2) !Only four bits of the eight supplied are used.
ASTASH.BRD(2) = BORED(3)*16 + BORED(4) !So interleave them, pairwise.
SLOSH = ASTASH.BRD(1)*ASTASH.BRD(2) !Mash the bits together.
HIT = ABS(MOD(SLOSH,APRIME)) + 2 !Make a hash. Add one since MOD starts with zero.
WRITE (NDX(W),REC = HIT) HCOUNT(W) !Adding another one to dodge the header as well.
WRITE (MSG,24) BOARD,BORED,ASTASH.BRD, !Reveal the stages.
1 SLOSH,SLOSH,SLOSH,APRIME,HIT !Of the mostly in-place reinterpretations.
24 FORMAT (<N>Z2," is the board layout in INTEGER*1",/, !Across the columns and down the rows.
1 4Z8," is the board layout in INTEGER*4",/, !Reinterpret as four integers.
2 2(8X,Z8)," ..interleaved into two INTEGER*4",/, !Action: Interleaved into two.
3 Z32," multiplied together in INTEGER*4",/, !Action: Their product.
4 I32," as a decimal integer.",/, !Abandoning hexadecimal.
5 "ABS(MOD(",I0,",",I0,")) + 2 = ",I0, !The final step.
6 " is the record number for the first index entry.") !The result.
WRITE (WRK(W),REC = HCOUNT(W) + 1) ASTASH !Record one is reserved as a header...
END IF !Either way, a workfile should be ready now.
IF (W.EQ.1) BOARD = TARGET !Thus go for the other work file.
END DO !Only two iterations, but a lot of blather.
SLOSH = MINVAL(SURGE,DIM = 1) !Find the laggard.
Cast forth a heading for the progress table to follow..
WRITE (MSG,99)
99 FORMAT (/,7X,"|",3X,"Tidewrack Boundary Positions |",
1 6X,"Positions",5X,"|",7X,"Primary Probes",9X,"Index Use",
2 4X,"|",5X,"Secondary Probes",3X,"|"," Memory of Time Passed",/,
3 "Surge",2X,"|",6X,"First",7X,"Last",6X,"Count|",
4 4X,"Checked Deja vu%|",7X,"Made Max.L Avg.L| Used%",
5 5X,"Load%|",7X,"Made Max.L Avg.L|",6X,"CPU",8X,"Clock")
Chase along the boundaries of the red and the blue tides, each taking turns as primary and secondary interests.
100 SLOSH = SLOSH + 1 !Another advance begins.
WW:DO W = 1,2 !The advance is made in two waves, each with its own statistics.
M = 3 - W !Finger the other one.
NMET = 0 !No meetings have happened yet.
IF (SURGE(W).GE.SLOSH) CYCLE WW !Prefer to proceed with matched surges.
WRITE (MSG,101) SLOSH,TIDE(W),IST(W),LST(W),LST(W)-IST(W)+1 !The boundary to be searched.
101 FORMAT (I2,1X,A4,"|",3I11,"|",$) !This line will be continued.
NCHECK = 0 !No new positions have been prepared.
NLOOK = 0 !So the stashes have not been searched for any of them.
PROBES = 0 !And no probes have been made in any such searches.
MAXP = 0 !So the maximum length of all probe chains is zero so far.
HNEXT = LST(W) + 1 !This will be where the first new position will be stashed.
T1 = NOWWAS(0) !Note the accumulated CPU time at the start of the boundary ride..
E1 = NOWWAS(2) !Time of day, in seconds. GMT style (thus not shifted by daylight saving)
PP:DO P = IST(W),LST(W) !These are on the edge of the tide. Spreading proceeds.
READ (WRK(W),REC = P + 1) ASTASH !Obtain a position, remembering to dodge the header record.
HENCE = ASTASH.MOVE !The move (from ASTASH.PREV) that reached this position.
IF (HENCE.NE.0) HENCE = MOD(HENCE + 1,4) + 1 !The reverse of that direction. Only once zero. Sigh.
CALL UNCRAM(ASTASH.BRD,BOARD) !Unpack into the work BOARD.
LZ = INDEX(BOAR,CHAR(0)) !Find the BOARD square with zero.
ZR = (LZ - 1)/NC + 1 !Convert to row and column in LOCZ to facilitate bound checking.
ZC = MOD(LZ - 1,NC) + 1 !Two divisions, sigh. Add a special /\ syntax? (ZR,ZC) = (LZ - 1)/\NC + 1
Consider all possible moves from position P, If a new position is unknown, add it to the stash.
DD:DO D = 1,4 !Step through the possible directions in which the zero square might move.
IF (D.EQ.HENCE) CYCLE DD !Don't try going back whence this came.
LOCI = LOCZ + WAYS(1:2,D) !Finger the destination of the zero square, (row,column) style.
IF (ANY(LOCI.LE.0)) CYCLE DD !No wrapping left/right or top/bottom.
IF (ANY(LOCI.GT.(/NR,NC/))) CYCLE DD !No .OR. to avoid the possibility of non-shortcut full evaluation.
NCHECK = NCHECK + 1 !So, here is another position to inspect.
NP = 0 !No probes of stashes W or M for it have been made.
IT = WAY(D) + LZ !Finger the square that is to move to the adjacent zero.
BOARD(LZ) = BOARD(IT) !Move that square's content to the square holding the zero.
BOARD(IT) = 0 !It having departed.
ASTASH.BRD(1) = BORED(1)*16 + BORED(2) !Pack the position list
ASTASH.BRD(2) = BORED(3)*16 + BORED(4) !Without fussing over adjacency,
HIT = ABS(MOD(ASTASH.BRD(1)*ASTASH.BRD(2),APRIME)) + 2 !Crunch the hash index.
READ (NDX(W),REC = HIT) HEAD !Refer to the index, which fingers the first place to look.
LOOK = HEAD !This may be the start of a linked-list.
IF (LOOK.EQ.0) NINDEX(W) = NINDEX(W) + 1 !Or, a new index entry will be made.
IF (LOOK.NE.0) NLOOK(1) = NLOOK(1) + 1 !Otherwise, we're looking at a linked-list, hopefully short.
DO WHILE (LOOK.NE.0) !Is there a stash entry to look at?
NP(1) = NP(1) + 1 !Yes. Count a probe of the W stash.
READ (WRK(W),REC = LOOK + 1) APROBE !Do it. (Dodging the header record)
IF (ALL(ASTASH.BRD.EQ.APROBE.BRD)) GO TO 109 !Already seen? Ignore all such as previously dealt with.
LOOK = APROBE.NEXT !Perhaps there follows another entry having the same index.
END DO !And eventually, if there was no matching entry,
HCOUNT(W) = HCOUNT(W) + 1 !A new entry is to be added to stash W, linked from its index.
IF (HCOUNT(W).LE.0) STOP "HCOUNT overflows!" !Presuming the usual two's complement style.
WRITE (NDX(W),REC = HIT) HCOUNT(W) !The index now fingers the new entry in ASTASH.
ASTASH.NEXT = HEAD !Its follower is whatever the index had fingered before.
ASTASH.PREV = P !This is the position that led to it.
ASTASH.MOVE = D !Via this move.
WRITE (WRK(W),REC = HCOUNT(W) + 1) ASTASH !Place the new entry, dodging the header.
Check the other stash for this new position. Perhaps there, a meeting will be found!
READ (NDX(M),REC = HIT) LOOK !The other stash uses the same hash function but has its own index.
IF (LOOK.NE.0) NLOOK(2) = NLOOK(2) + 1 !Perhaps stash M has something to look at.
DO WHILE(LOOK.NE.0) !Somewhere along a linked-list.
NP(2) = NP(2) + 1 !A thorough look may involve multiple probes.
READ(WRK(M),REC = LOOK + 1) APROBE !Make one.
IF (ALL(ASTASH.BRD.EQ.APROBE.BRD)) THEN!A match?
IF (NMET.LT.MANY) THEN !Yes! Hopefully, not too many already.
NMET = NMET + 1 !Count another.
MET(W,NMET) = HCOUNT(W) !Save a finger to the new entry.
MET(M,NMET) = LOOK !And to its matching counterparty.
ELSE !But if too numerous for my list,
WRITE (MSG,108) TIDE(W),HCOUNT(W),TIDE(M),LOOK !Announce each.
108 FORMAT ("Can't save ",A,1X,I0," matching ",A,1X,I0)!Also wrecking my tabular layout.
END IF !So much for recording a match.
GO TO 109 !Look no further for the new position; it is found..
END IF !So much for a possible match.
LOOK = APROBE.NEXT !Chase along the linked-list.
END DO !Thus checking all those hashing to the same index.
Completed the probe.
109 MAXP = MAX(MAXP,NP) !Track the maximum number of probes in any search..
PROBES = PROBES + NP !As well as their count.
BOARD(IT) = BOARD(LZ) !Finally, undo the move.
BOARD(LZ) = 0 !To be ready for the next direction.
END DO DD !Consider another direction.
END DO PP !Advance P to the next spreading possibility.
Completed one perimeter sequence. Cast forth some statistics.
110 T2 = NOWWAS(0) !A boundary patrol has been completed.
E2 = NOWWAS(2) !And time has passed.
HIT = HCOUNT(W) - HNEXT + 1 !The number of new positions to work from in the next layer.
WRITE (MSG,111) NCHECK,100.0*(NCHECK - HIT)/NCHECK, !Tested, and %already seen
1 NLOOK(1),MAXP(1),FLOAT(PROBES(1))/MAX(NLOOK(1),1), !Search statistics.
2 100.0*NINDEX(W)/APRIME,100.0*HCOUNT(W)/APRIME, !Index occupancy: used entries, and load.
3 NLOOK(2),MAXP(2),FLOAT(PROBES(2))/MAX(NLOOK(2),1) !Other stash's search statistics.
111 FORMAT (I11,F9.2,"|",I11,I6,F7.3,"|",F8.3,F10.3,"|", !Attempt to produce regular columns.
1 I11,I6,F7.3,"|"$) !To be continued...
T1 = T2 - T1 !Thus, how much CPU time was used perusing the perimeter.
E1 = E2 - E1 !Over the elapsed time.
CALL PROUST(T1) !Muse over the elapsed CPU time, in seconds.
CALL PROUST(E1) !And likewise the elapsed clock time.
E2 = NOWWAS(1) !Civil clock, possibly adjusted for daylight saving.
IF (E1.LE.0) THEN !The offered timing may be too coarse.
WRITE (MSG,112) HMS(E2) !So, just finish the line.
112 FORMAT (8X,A) !With a time of day.
ELSE !But if some (positive) clock time was measured as elapsing,
WRITE (MSG,113) T1/E1*100,HMS(E2) !Offer a ratio as well.
113 FORMAT (F6.2,"%",1X,A) !Percentages are usual.
END IF !Enough annotation.
Could there be new positions to check? HCOUNT will have been increased if so.
SURGED(W) = HCOUNT(W).GE.HNEXT !The boundary has been extended to new positions.
IF (SURGED(W)) THEN !But, are there any new positions?
IST(W) = HNEXT !Yes. The first new position would have been placed here.
LST(W) = HCOUNT(W) !This is where the last position was placed.
SURGE(W) = SLOSH !The new surge is ready.
WRITE (WRK(W),REC = 1) HCOUNT(W),SURGE(W),IST(W),LST(W) !Update the headers correspondingly..
WRITE (NDX(W), REC = 1) NINDEX(W) !Otherwise, a rescan would be needed on a restart.
ELSE IF (SURGE(W) + 1 .EQ. SLOSH) THEN !No new positions. First encounter?
LOOK = LST(W) - IST(W) + 1 !Yes. How many dead ends are there?
WRITE (MSG,114) LOOK !Announce.
114 FORMAT (/,"The boundary has not surged to new positions!",/
1 "The now-static boundary has ",I0)
LOOK = LOOK/666 + 1 !If there are many, don't pour forth every one.
IF (LOOK.GT.1) WRITE (MSG,115) LOOK!Some restraint.
115 FORMAT (6X,"... Listing step: ",I0)!Rather than rolling forth a horde.
WRITE (MSG,121) !Re-use the heading for the REPORT.
DO P = IST(W),LST(W),LOOK !Step through the dead ends, possibly sampling every one.
READ (WRK(W),REC = P + 1) ASTASH !Grab a position.
CALL REPORT(P,TIDE(W),WNAMEF(ASTASH.MOVE),ASTASH.BRD) !Describe it.
END DO !On to the next dead end.
END IF !Perhaps the universe has been filled.
Could the clouds have touched? If so, two trails have met.
120 ML:DO P = 1,NMET !Step through the meeting list.
IF (NS.LT.MANY) NS = NS + 1!Note another shove sequence.
LS(NS) = 0 !Details to be determined.
WRITE (MSG,121) !Announce, via a heading.
121 FORMAT (/,5X,"Record Stash Move |Board layout by row|", !Various details
1 2X,"Max|d| Sum|d| Euclidean Encoded vs Zero") !Will be attached.
NTRAIL = 1 !Every trail starts with its first step.
TRAIL(1) = MET(2,P) !This is the blue trail's position that met the red tide..
122 READ(WRK(2),REC = TRAIL(NTRAIL) + 1) ASTASH !Obtain details
IF (ASTASH.PREV.NE.0) THEN !Had this step arrived from somewhere?
IF (NTRAIL.GE.LONG) STOP "The trail is too long!" !Yes.
NTRAIL = NTRAIL + 1 !Count another step.
TRAIL(NTRAIL) = ASTASH.PREV !Finger the preceding step.
GO TO 122 !And investigate it in turn.
END IF !Thus follow the blue trail back to its origin.
130 DO LOOK = NTRAIL,1,-1 !The end of the blue trail is the position in TARGET, the start position.
READ(WRK(2),REC = TRAIL(LOOK) + 1) ASTASH !Grab a position, dodging the header.
CALL REPORT(TRAIL(LOOK),"Blue",WNAMEF(ASTASH.MOVE), !Backwards*backwards = forwards.
1 ASTASH.BRD) !The board layout is always straightforward...
IF (LOOK.NE.NTRAIL) THEN !The start position has no move leading to it.
IF (LS(NS).LT.LEN(SHOVE(1))) LS(NS) = LS(NS) + 1 !But count all subsequent ssociated moves.
SHOVE(NS)(LS(NS):LS(NS)) = WNAMEF(ASTASH.MOVE) !Place it.
END IF !So much for that move.
END DO !On to the next move away from the start position.
140 HEAD = 0 !Syncopation. Prevent the first position of the red trail from being listed.
LOOK = MET(1,P) !It is the same position as the first in the TRAIL, but in the primary stash.
DO WHILE(LOOK.NE.0) !The red chain runs back to its starting position, which is the "solution" state..
READ(WRK(1),REC = LOOK + 1) ASTASH !Which is in the direction I want to list.
IF (HEAD.NE.0) THEN !Except that the moves are one step behind for this list.
CALL REPORT(LOOK,"Red",WNAMEZ(HEAD),ASTASH.BRD) !As this sequence is not being reversed.
IF (LS(NS).LT.LEN(SHOVE(1))) LS(NS) = LS(NS) + 1 !This lists the moves in forwards order.
SHOVE(NS)(LS(NS):LS(NS)) = WNAMEZ(HEAD) !But the directions are reversed....
END IF !This test avoids listing the "Red" position that is the same as the last "Blue" position.
HEAD = ASTASH.MOVE !This is the move that led to this position.
LOOK = ASTASH.PREV !From the next position, which will be listed next.
END DO !Thus, the listed position was led to by the previous position's move.
150 DO I = 1,NS - 1 !Perhaps the move sequence has been found already.
IF (SHOVE(I)(1:LS(I)).EQ.SHOVE(NS)(1:LS(NS))) THEN !So, compare agains previous shoves.
WRITE (MSG,151) I !It has been seen.
151 FORMAT (6X,"... same as for sequence ",I0) !Humm.
NS = NS - 1 !Eject the arriviste.
GO TO 159 !And carry on.
END IF !This shouldn't happen...
END DO !On to the next comparison.
WRITE (MSG,152) LS(NS),SHOVE(NS)(1:LS(NS)) !Show the moves along a line.
152 FORMAT (I4," moves: ",A) !Surely plural? One-steps wouldn't be tried?
159 END DO ML !Perhaps another pair of snakes have met.
END DO WW !Advance W to the other one. M will be swapped correspondingly.
Could there be an end to it all?
IF (.NOT.ANY(SURGED)) STOP "No progress!" !Oh dear.
IF (NMET.LE.0) GO TO 100 !Keep right on to the end of the road...
END SUBROUTINE PURPLE HAZE !That was fun!
END MODULE SLIDESOLVE
PROGRAM POKE
USE SLIDESOLVE
CHARACTER*(19) FNAME !A base name for some files.
INTEGER I,R,C !Some steppers.
INTEGER MSG,KBD,WRK(2),NDX(2) !I/O unit numbers.
COMMON/IODEV/ MSG,KBD,WRK,NDX !I talk to the trees..
KBD = 5 !Standard input. (Keyboard)
MSG = 6 !Standard output.(Display screen)
WRK = (/10,12/) !I need two work files,
NDX = WRK + 1 !Each with its associated index.
WRITE (FNAME,1) NR,NC !Now prepare the file name.
1 FORMAT ("SlideSolveR",I1,"C",I1,".txt") !Allowing for variation, somewhat.
WRITE (MSG,2) NR,NC,FNAME !Announce.
2 FORMAT ("To play 'slide-square' with ",I0," rows and ",
1 I0," columns.",/,"An initial layout will be read from file ",
2 A,/,"The objective is to attain the nice orderly layout"
3 " as follows:",/)
FORALL(I = 1:N - 1) ZERO(I) = I !Regard the final or "solution" state as ZERO.
ZERO(N) = 0 !The zero sqiuare is at the end, damnit!
CALL SHOW(NR,NC,ZERO) !Show the squares in their "solved" arrangement: the "Red" stash.
OPEN(WRK(1),FILE=FNAME,STATUS="OLD",ACTION="READ") !For formatted input.
DO R = 1,NR !Chug down the rows, reading successive columns across a row..
READ (WRK(1),*) (TARGET((R - 1)*NC + C), C = 1,NC) !Into successive storage locations.
END DO !Furrytran's storage order is (column,row) for that, alas.
CLOSE (WRK(1)) !A small input, but much effort follows.
WRITE (MSG,3) !Now show the supplied layout.
3 FORMAT (/,"The starting position:") !The target, working backwards.
CALL SHOW(NR,NC,TARGET) !This will be the starting point for the "Blue" stash.
IF (ALL(TARGET.EQ.BOARD)) STOP "Huh? They're the same!" !Surely not.
WRITE (MSG,4)
4 FORMAT (/'The plan is to spread a red tide from the "solved" ',
1 "layout and a blue tide from the specified starting position.",/
2 "The hope is that these floods will meet at some position,",
3 " and the blue moves plus the red moves in reverse order,",/
4 "will be the shortest sequence from the given starting",
5 " position to the solution.")
CALL PURPLE HAZE(FNAME(1:14))
999 write(msg,*) "type a number to exit..."
read (kbd,*,err=999) i
END</lang>
The Results
To play 'slide-square' with 4 rows and 4 columns.
An initial layout will be read from file SlideSolveR4C4.txt
The objective is to attain the nice orderly layout as follows:
Row|__1__2__3__4
1| 1 2 3 4
2| 5 6 7 8
3| 9 10 11 12
4| 13 14 15 0
The starting position:
Row|__1__2__3__4
1| 15 14 1 6
2| 9 11 4 12
3| 0 10 7 3
4| 13 8 5 2
The plan is to spread a red tide from the "solved" layout and a blue tide from the specified starting position.
The hope is that these floods will meet at some position, and the blue moves plus the red moves in reverse order,
will be the shortest sequence from the given starting position to the solution.
Tide Red
Preparing a stash in file SlideSolveR4C4.123456789ABCDEF0.dat
... with an index in file SlideSolveR4C4.123456789ABCDEF0.ndx
199999991 zero values for an empty index.
1 2 3 4 5 6 7 8 9 A B C D E F 0 is the board layout in INTEGER*1
4030201 8070605 C0B0A09 F0E0D is the board layout in INTEGER*4
48372615 C0BFAE9D ..interleaved into two INTEGER*4
EF5FA0E1 multiplied together in INTEGER*4
-278945567 as a decimal integer.
ABS(MOD(-278945567,199999991)) + 2 = 78945578 is the record number for the first index entry.
Tide Blue
Preparing a stash in file SlideSolveR4C4.FE169B4C0A73D852.dat
... with an index in file SlideSolveR4C4.FE169B4C0A73D852.ndx
199999991 zero values for an empty index.
F E 1 6 9 B 4 C 0 A 7 3 D 8 5 2 is the board layout in INTEGER*1
6010E0F C040B09 3070A00 205080D is the board layout in INTEGER*4
6C14EBF9 3275A80D ..interleaved into two INTEGER*4
B2B863A5 multiplied together in INTEGER*4
-1296538715 as a decimal integer.
ABS(MOD(-1296538715,199999991)) + 2 = 96538771 is the record number for the first index entry.
| Tidewrack Boundary Positions | Positions | Primary Probes Index Use | Secondary Probes | Memory of Time Passed
Surge | First Last Count| Checked Deja vu%| Made Max.L Avg.L| Used% Load%| Made Max.L Avg.L| CPU Clock
1 Red| 1 1 1| 2 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.5secs 2.94% 1:07:03.093am.
1 Blue| 1 1 1| 3 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.5secs 3.22% 1:07:03.578am.
2 Red| 2 3 2| 4 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.0secs 0.00% 1:07:03.593am.
2 Blue| 2 4 3| 6 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.1secs 0.5secs 11.75% 1:07:04.125am.
3 Red| 4 7 4| 10 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.1secs 0.7secs 11.63% 1:07:04.812am.
3 Blue| 5 10 6| 14 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.0secs 1:07:04.812am.
4 Red| 8 17 10| 24 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.0secs 0.00% 1:07:04.875am.
4 Blue| 11 24 14| 32 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.1secs 0.00% 1:07:04.953am.
5 Red| 18 41 24| 54 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.0secs 0.00% 1:07:05.015am.
5 Blue| 25 56 32| 66 0.00| 0 0 0.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.0secs 50.40% 1:07:05.046am.
6 Red| 42 95 54| 108 0.93| 1 1 1.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.0secs 33.24% 1:07:05.093am.
6 Blue| 57 122 66| 136 1.47| 2 1 1.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.1secs 0.00% 1:07:05.171am.
7 Red| 96 202 107| 215 1.40| 3 1 1.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.1secs 0.00% 1:07:05.265am.
7 Blue| 123 256 134| 285 1.75| 5 1 1.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.1secs 0.00% 1:07:05.375am.
8 Red| 203 414 212| 456 2.19| 10 1 1.000| 0.000 0.000| 0 0 0.000| 0.0secs 0.2secs 8.36% 1:07:05.578am.
8 Blue| 257 536 280| 601 2.66| 16 1 1.000| 0.001 0.001| 0 0 0.000| 0.0secs 0.2secs 20.03% 1:07:05.812am.
9 Red| 415 860 446| 974 2.87| 28 1 1.000| 0.001 0.001| 0 0 0.000| 0.2secs 0.5secs 37.50% 1:07:06.312am.
9 Blue| 537 1121 585| 1254 3.19| 41 1 1.000| 0.001 0.001| 0 0 0.000| 0.2secs 0.5secs 34.38% 1:07:06.812am.
10 Red| 861 1806 946| 2032 4.13| 88 1 1.000| 0.002 0.002| 0 0 0.000| 0.3secs 0.9secs 37.28% 1:07:07.734am.
10 Blue| 1122 2335 1214| 2578 4.50| 117 1 1.000| 0.002 0.002| 0 0 0.000| 0.3secs 1.1secs 25.00% 1:07:08.859am.
11 Red| 1807 3754 1948| 4124 4.51| 189 1 1.000| 0.004 0.004| 0 0 0.000| 0.5secs 1.8secs 29.66% 1:07:10.703am.
11 Blue| 2336 4797 2462| 5188 4.66| 249 1 1.000| 0.005 0.005| 0 0 0.000| 0.6secs 2.2secs 27.54% 1:07:12.859am.
12 Red| 3755 7692 3938| 8244 5.29| 440 1 1.000| 0.008 0.008| 0 0 0.000| 1.0secs 3.6secs 28.51% 1:07:16.421am.
12 Blue| 4798 9743 4946| 10442 5.56| 588 1 1.000| 0.010 0.010| 1 1 1.000| 1.6secs 4.2secs 38.20% 1:07:20.593am.
13 Red| 7693 15500 7808| 16470 5.62| 943 1 1.000| 0.016 0.016| 0 0 0.000| 2.2secs 6.5secs 33.65% 1:07:27.093am.
13 Blue| 9744 19604 9861| 20858 6.03| 1285 2 1.001| 0.020 0.020| 4 1 1.000| 2.8secs 7.5secs 37.00% 1:07:34.625am.
14 Red| 15501 31044 15544| 32950 6.46| 2175 2 1.000| 0.031 0.031| 5 1 1.000| 3.8secs 11.2secs 34.12% 1:07:45.843am.
14 Blue| 19605 39204 19600| 41448 6.66| 2813 2 1.001| 0.039 0.039| 14 1 1.000| 4.6secs 12.7secs 36.19% 1:07:58.578am.
15 Red| 31045 61865 30821| 65311 6.84| 4611 2 1.001| 0.061 0.061| 23 1 1.000| 6.8secs 17.2secs 39.62% 1:08:15.734am.
15 Blue| 39205 77892 38688| 81703 6.87| 5803 2 1.000| 0.077 0.077| 47 1 1.000| 7.2secs 18.2secs 39.64% 1:08:33.906am.
16 Red| 61866 122707 60842| 128412 7.33| 9742 2 1.002| 0.121 0.121| 77 2 1.013| 11.9secs 23.2secs 51.21% 1:08:57.093am.
16 Blue| 77893 153978 76086| 160446 7.49| 12421 2 1.001| 0.151 0.151| 172 1 1.000| 13.6secs 23.2secs 58.57% 1:09:20.250am.
17 Red| 122708 241707 119000| 250818 7.56| 20063 3 1.002| 0.236 0.237| 303 1 1.000| 20.5secs 30.5secs 67.33% 1:09:50.765am.
17 Blue| 153979 302413 148435| 312766 7.89| 26220 2 1.002| 0.294 0.295| 678 2 1.001| 24.3secs 32.3secs 75.17% 1:10:23.109am.
18 Red| 241708 473551 231844| 487982 8.33| 43582 3 1.003| 0.458 0.460| 1229 2 1.002| 38.0secs 46.2secs 82.36% 1:11:09.265am.
18 Blue| 302414 590511 288098| 606919 8.56| 56018 3 1.003| 0.570 0.573| 2440 2 1.004| 47.5secs 59.4secs 80.02% 1:12:08.687am.
19 Red| 473552 920893 447342| 942552 8.79| 93152 3 1.005| 0.883 0.890| 4672 2 1.005| 73.1secs 91.3secs 80.07% 1:13:40.046am.
19 Blue| 590512 1145481 554970| 1168265 9.04| 120435 3 1.006| 1.093 1.104| 8999 3 1.009| 90.6secs 1.9mins 81.12% 1:15:31.765am.
20 Red| 920894 1780637 859744| 1809752 9.52| 202081 3 1.007| 1.687 1.709| 17194 2 1.008| 2.4mins 3.0mins 79.31% 1:18:30.265am.
20 Blue| 1145482 2208109 1062628| 2235235 9.77| 262047 3 1.008| 2.080 2.112| 33025 3 1.014| 3.0mins 3.7mins 79.82% 1:22:14.375am.
21 Red| 1780638 3418020 1637383| 3444691 10.06| 451483 4 1.014| 3.183 3.258| 62538 3 1.015| 4.5mins 5.7mins 79.80% 1:27:56.468am.
21 Blue| 2208110 4224923 2016814| 4238343 10.33| 588823 4 1.017| 3.905 4.013| 118609 5 1.024| 5.7mins 7.1mins 80.08% 1:35:03.140am.
22 Red| 3418021 6516290 3098270| 6506982 10.83| 1022051 4 1.023| 5.926 6.159| 219923 4 1.025| 8.7mins 10.7mins 81.12% 1:45:44.328am.
22 Blue| 4224924 8025605 3800682| 7979315 11.11| 1353159 5 1.029| 7.218 7.559| 414055 4 1.039| 10.9mins 13.8mins 79.04% 1:59:31.875am.
23 Red| 6516291 12318701 5802411| 12178635 11.45| 2470087 6 1.048| 10.780 11.551| 765853 5 1.046| 17.3mins 24.1mins 71.78% 2:23:35.828am.
23 Blue| 8025606 15118814 7093209| 14877107 11.76| 3307729 5 1.058| 13.003 14.123| 1401940 6 1.071| 22.4mins 35.3mins 63.46% 2:58:53.375am.
24 Red| 12318702 23102481 10783780| 22603192 12.29| 6014769 6 1.083| 19.074 21.464| 2526552 6 1.084| 36.7mins 65.6mins 55.95% 4:04:29.375am.
24 Blue| 15118815 28246178 13127364| 27507742 12.56| 8148893 7 1.105| 22.682 26.150| 4539588 7 1.124| 49.4mins 96.5mins 51.22% 5:40:59.265am.
25 Red| 23102482 42928799 19826318| 41532426 12.98| 15508438 9 1.166| 32.086 39.535| 8144188 7 1.151| 84.5mins 3.0hrs! 47.06% 8:40:25.296am.
25 Blue| 28246179 52299632 24053454| 50352435 13.30| 21007872 9 1.207| 37.354 47.979| 13961187 8 1.232| 2.0hrs! 4.4hrs! 44.40% 1:07:12.546pm.
26 Red| 42928800 79070945 36142146| 75611538 13.85| 38688179 10 1.300| 50.548 72.103| 24060624 9 1.278| 3.5hrs! 8.3hrs! 42.77% 9:23:03.250pm.
26 Blue| 52299633 95957208 43657576| 91305518 14.15| 51817830 14 1.379| 57.098 87.170| 39429635 10 1.424| 5.3hrs! 12.5hrs! 42.37% 9:53:57.890am.
Record Stash Move |Board layout by row| Max|d| Sum|d| Euclidean Encoded vs Zero
1 Blue |FE16/9B4C/0A73/D852| 14 86 27.055 19442940853367
2 Blue L |FE16/9B4C/A073/D852| 14 88 27.423 19442940844007
5 Blue L |FE16/9B4C/A703/D852| 14 88 27.677 19442940842087
11 Blue L |FE16/9B4C/A730/D852| 14 88 27.785 19442940841679
25 Blue D |FE16/9B40/A73C/D852| 14 80 26.000 19442940922295
58 Blue R |FE16/9B04/A73C/D852| 14 80 25.846 19442943220535
126 Blue U |FE16/9B34/A70C/D852| 14 80 26.306 19442940271895
265 Blue R |FE16/9B34/A07C/D852| 14 80 26.038 19442940274415
554 Blue D |FE16/9034/AB7C/D852| 14 72 24.290 19442951159375
1156 Blue D |F016/9E34/AB7C/D852| 14 64 21.863 19530129450575
2409 Blue R |0F16/9E34/AB7C/D852| 13 62 21.166 20837803818575
4949 Blue U |9F16/0E34/AB7C/D852| 13 70 22.804 11597104535375
10052 Blue L |9F16/E034/AB7C/D852| 13 72 23.409 11597064618575
20229 Blue D |9016/EF34/AB7C/D852| 10 64 20.688 11684242909775
40459 Blue L |9106/EF34/AB7C/D852| 10 64 20.736 10544698103375
80368 Blue U |9136/EF04/AB7C/D852| 10 64 21.307 10469454209615
158888 Blue U |9136/EF74/AB0C/D852| 11 64 22.583 10469452026935
312029 Blue U |9136/EF74/AB5C/D802| 15 64 23.452 10469452026423
609335 Blue R |9136/EF74/AB5C/D082| 14 64 23.108 10469452026425
1182001 Blue D |9136/EF74/A05C/DB82| 10 62 21.119 10469452028615
2278389 Blue D |9136/E074/AF5C/DB82| 9 54 18.055 10469455657415
4359103 Blue R |9136/0E74/AF5C/DB82| 8 52 17.263 10469531862215
8279825 Blue D |0136/9E74/AF5C/DB82| 8 44 15.033 19623012937415
15596324 Blue L |1036/9E74/AF5C/DB82| 8 44 15.100 1228393494215
29135380 Blue L |1306/9E74/AF5C/DB82| 8 46 15.297 169799958215
53940860 Blue L |1360/9E74/AF5C/DB82| 8 48 15.684 111840764615
98956855 Blue U |1364/9E70/AF5C/DB82| 8 48 16.673 106528120775
47181586 Red R |1364/9E07/AF5C/DB82| 8 48 16.248 106530419015
25400927 Red U |1364/9E57/AF0C/DB82| 11 48 17.436 106527470375
13548279 Red U |1364/9E57/AF8C/DB02| 15 48 19.183 106527469863
7168799 Red L |1364/9E57/AF8C/DB20| 13 44 17.550 106527469862
3761169 Red D |1364/9E57/AF80/DB2C| 13 68 24.413 106527469916
1959965 Red R |1364/9E57/AF08/DB2C| 13 68 24.083 106527470324
1013648 Red U |1364/9E57/AF28/DB0C| 15 68 24.413 106527469693
521247 Red R |1364/9E57/AF28/D0BC| 14 68 23.958 106527469696
266034 Red D |1364/9E57/A028/DFBC| 12 60 21.307 106527470416
135063 Red D |1364/9057/AE28/DFBC| 12 52 18.493 106534727296
68120 Red L |1364/9507/AE28/DFBC| 12 52 18.762 106504971136
34188 Red U |1364/9527/AE08/DFBC| 12 52 19.183 106501659736
17049 Red U |1364/9527/AEB8/DF0C| 15 52 21.354 106501659249
8443 Red R |1364/9527/AEB8/D0FC| 14 50 20.640 106501659251
4119 Red D |1364/9527/A0B8/DEFC| 12 42 17.720 106501660689
1986 Red R |1364/9527/0AB8/DEFC| 12 40 17.146 106501687329
950 Red D |1364/0527/9AB8/DEFC| 12 32 14.900 106781074689
458 Red L |1364/5027/9AB8/DEFC| 12 32 15.232 106414565889
222 Red L |1364/5207/9AB8/DEFC| 12 32 15.362 106381543809
104 Red D |1304/5267/9AB8/DEFC| 12 26 13.711 168648485889
46 Red R |1034/5267/9AB8/DEFC| 12 24 13.491 1227242021889
20 Red U |1234/5067/9AB8/DEFC| 12 24 14.071 36293889
9 Red L |1234/5607/9AB8/DEFC| 12 24 14.491 3271809
4 Red L |1234/5670/9AB8/DEFC| 12 24 14.967 328449
2 Red U |1234/5678/9AB0/DEFC| 12 24 16.971 105
1 Red U |1234/5678/9ABC/DEF0| 0 0 0.000 0
52 moves: LLLDRURDDRULDLUUURDDRDLLLURUULDRURDDLUURDRDLLDRULLUU
Record Stash Move |Board layout by row| Max|d| Sum|d| Euclidean Encoded vs Zero
1 Blue |FE16/9B4C/0A73/D852| 14 86 27.055 19442940853367
2 Blue L |FE16/9B4C/A073/D852| 14 88 27.423 19442940844007
5 Blue L |FE16/9B4C/A703/D852| 14 88 27.677 19442940842087
11 Blue L |FE16/9B4C/A730/D852| 14 88 27.785 19442940841679
25 Blue D |FE16/9B40/A73C/D852| 14 80 26.000 19442940922295
58 Blue R |FE16/9B04/A73C/D852| 14 80 25.846 19442943220535
126 Blue U |FE16/9B34/A70C/D852| 14 80 26.306 19442940271895
266 Blue U |FE16/9B34/A75C/D802| 15 80 27.055 19442940271383
558 Blue R |FE16/9B34/A75C/D082| 14 80 26.758 19442940271385
1163 Blue D |FE16/9B34/A05C/D782| 14 80 25.690 19442940274293
2420 Blue D |FE16/9034/AB5C/D782| 14 72 23.917 19442951159253
4967 Blue D |F016/9E34/AB5C/D782| 14 64 21.448 19530129450453
10090 Blue R |0F16/9E34/AB5C/D782| 13 62 20.736 20837803818453
20306 Blue U |9F16/0E34/AB5C/D782| 13 70 22.405 11597104535253
40605 Blue L |9F16/E034/AB5C/D782| 13 72 23.022 11597064618453
80644 Blue D |9016/EF34/AB5C/D782| 9 64 20.248 11684242909653
159412 Blue L |9106/EF34/AB5C/D782| 9 64 20.298 10544698103253
313039 Blue U |9136/EF04/AB5C/D782| 9 64 20.881 10469454209493
611272 Blue U |9136/EF54/AB0C/D782| 11 64 21.817 10469451664053
1185720 Blue U |9136/EF54/AB8C/D702| 15 64 23.238 10469451663663
2285440 Blue L |9136/EF54/AB8C/D720| 13 60 21.909 10469451663662
4372401 Blue D |9136/EF54/AB80/D72C| 13 84 27.713 10469451663716
8304687 Blue R |9136/EF54/AB08/D72C| 13 84 27.423 10469451664028
15642421 Blue R |9136/EF54/A0B8/D72C| 13 82 27.019 10469451665948
29220003 Blue D |9136/E054/AFB8/D72C| 13 74 24.698 10469455294748
54094941 Blue R |9136/0E54/AFB8/D72C| 13 72 24.125 10469531499548
99233939 Blue D |0136/9E54/AFB8/D72C| 13 64 22.583 19623012574748
53847416 Red L |1036/9E54/AFB8/D72C| 13 64 22.627 1228393131548
29052034 Red L |1306/9E54/AFB8/D72C| 13 66 22.760 169799595548
15525093 Red L |1360/9E54/AFB8/D72C| 13 68 23.022 111840401948
8231956 Red U |1364/9E50/AFB8/D72C| 13 68 23.707 106527758108
4326107 Red U |1364/9E58/AFB0/D72C| 13 68 25.020 106527510356
2258614 Red R |1364/9E58/AF0B/D72C| 13 68 24.576 106527510668
1169712 Red U |1364/9E58/AF2B/D70C| 15 68 24.900 106527510037
602597 Red R |1364/9E58/AF2B/D07C| 14 68 24.617 106527510040
308014 Red D |1364/9E58/A02B/DF7C| 12 60 22.045 106527510760
156652 Red D |1364/9058/AE2B/DF7C| 12 52 19.339 106534767640
79080 Red L |1364/9508/AE2B/DF7C| 12 52 19.596 106505011480
39747 Red U |1364/9528/AE0B/DF7C| 12 52 20.000 106501700080
19843 Red U |1364/9528/AE7B/DF0C| 15 52 21.354 106501699449
9866 Red R |1364/9528/AE7B/D0FC| 14 50 20.640 106501699451
4832 Red D |1364/9528/A07B/DEFC| 12 42 17.720 106501700889
2335 Red R |1364/9528/0A7B/DEFC| 12 40 17.146 106501727529
1114 Red D |1364/0528/9A7B/DEFC| 12 32 14.900 106781114889
534 Red L |1364/5028/9A7B/DEFC| 12 32 15.232 106414606089
259 Red L |1364/5208/9A7B/DEFC| 12 32 15.362 106381584009
124 Red D |1304/5268/9A7B/DEFC| 12 26 13.711 168648526089
56 Red R |1034/5268/9A7B/DEFC| 12 24 13.491 1227242062089
24 Red U |1234/5068/9A7B/DEFC| 12 24 14.071 36334089
10 Red L |1234/5608/9A7B/DEFC| 12 24 14.491 3312009
5 Red U |1234/5678/9A0B/DEFC| 12 24 16.310 609
2 Red L |1234/5678/9AB0/DEFC| 12 24 16.971 105
1 Red U |1234/5678/9ABC/DEF0| 0 0 0.000 0
52 moves: LLLDRUURDDDRULDLUUULDRRDRDLLLUURURDDLUURDRDLLDRULULU
F#
<lang fsharp> // A Naive 15 puzzle solver using no memory. Nigel Galloway: October 6th., 2017 let Nr = [|3;0;0;0;0;1;1;1;1;2;2;2;2;3;3;3|] let Nc = [|3;0;1;2;3;0;1;2;3;0;1;2;3;0;1;2|] let rec Solve n =
let rec fN (i,g,e,l,_) = seq {
let fI = let n = (11-g-i*4)*4
let a = (e&&&(15UL<<<n))
(i+1,g,e-a+(a<<<16),'d'::l,Nr.[(int (a>>>n))] <= i)
let fG = let n = (19-g-i*4)*4
let a = (e&&&(15UL<<<n))
(i-1,g,e-a+(a>>>16),'u'::l,Nr.[(int (a>>>n))] >= i)
let fE = let n = (14-g-i*4)*4
let a = (e&&&(15UL<<<n))
(i,g+1,e-a+(a<<<4), 'r'::l,Nc.[(int (a>>>n))] <= g)
let fL = let n = (16-g-i*4)*4
let a = (e&&&(15UL<<<n))
(i,g-1,e-a+(a>>>4), 'l'::l,Nc.[(int (a>>>n))] >= g)
let fZ (n,i,g,e,l) = seq{yield (n,i,g,e,l); if l then yield! fN (n,i,g,e,l)}
match (i,g,l) with
|(0,0,'l'::_) -> yield! fZ fI
|(0,0,'u'::_) -> yield! fZ fE
|(0,0,_) -> yield! fZ fI; yield! fZ fE
|(0,3,'r'::_) -> yield! fZ fI
|(0,3,'u'::_) -> yield! fZ fL
|(0,3,_) -> yield! fZ fI; yield! fZ fL
|(3,0,'l'::_) -> yield! fZ fG
|(3,0,'d'::_) -> yield! fZ fE
|(3,0,_) -> yield! fZ fE; yield! fZ fG
|(3,3,'r'::_) -> yield! fZ fG
|(3,3,'d'::_) -> yield! fZ fL
|(3,3,_) -> yield! fZ fG; yield! fZ fL
|(0,_,'l'::_) -> yield! fZ fI; yield! fZ fL
|(0,_,'r'::_) -> yield! fZ fI; yield! fZ fE
|(0,_,'u'::_) -> yield! fZ fE; yield! fZ fL
|(0,_,_) -> yield! fZ fI; yield! fZ fE; yield! fZ fL
|(_,0,'l'::_) -> yield! fZ fI; yield! fZ fG
|(_,0,'u'::_) -> yield! fZ fE; yield! fZ fG
|(_,0,'d'::_) -> yield! fZ fI; yield! fZ fE
|(_,0,_) -> yield! fZ fI; yield! fZ fE; yield! fZ fG
|(3,_,'l'::_) -> yield! fZ fG; yield! fZ fL
|(3,_,'r'::_) -> yield! fZ fE; yield! fZ fG
|(3,_,'d'::_) -> yield! fZ fE; yield! fZ fL
|(3,_,_) -> yield! fZ fE; yield! fZ fG; yield! fZ fL
|(_,3,'d'::_) -> yield! fZ fI; yield! fZ fL
|(_,3,'u'::_) -> yield! fZ fL; yield! fZ fG
|(_,3,'r'::_) -> yield! fZ fI; yield! fZ fG
|(_,3,_) -> yield! fZ fI; yield! fZ fL; yield! fZ fG
|(_,_,'d'::_) -> yield! fZ fI; yield! fZ fE; yield! fZ fL
|(_,_,'l'::_) -> yield! fZ fI; yield! fZ fG; yield! fZ fL
|(_,_,'r'::_) -> yield! fZ fI; yield! fZ fE; yield! fZ fG
|(_,_,'u'::_) -> yield! fZ fE; yield! fZ fG; yield! fZ fL
|_ -> yield! fZ fI; yield! fZ fE; yield! fZ fG; yield! fZ fL
}
let n = Seq.collect fN n
match (Seq.tryFind(fun(_,_,n,_,_)->n=0x123456789abcdef0UL)) n with
|Some(_,_,_,n,_) -> printf "Solution found with %d moves: " (List.length n); List.iter (string >> printf "%s") (List.rev n); printfn ""
|_ -> Solve (Seq.filter(fun (_,_,_,_,n)->not n) n)
Solve [(2,0,0xfe169b4c0a73d852UL,[],false)] </lang>
- Output:
Solution found with 52 moves: rrrulddluuuldrurdddrullulurrrddldluurddlulurruldrdrd
Phix
<lang Phix>-- -- demo\rosetta\Solve15puzzle.exw -- constant STM = 0 -- single-tile metrics. constant MTM = 0 -- multi-tile metrics. if STM and MTM then ?9/0 end if -- both prohibited -- 0 0 -- fastest, but non-optimal -- 1 0 -- optimal in STM -- 0 1 -- optimal in MTM (slowest by far)
--Note: The fast method uses an inadmissible heuristic - see "not STM" in iddfs(). -- It explores mtm-style using the higher stm heuristic and may therefore -- fail badly in some cases.
constant SIZE = 4
constant goal = { 1, 2, 3, 4,
5, 6, 7, 8,
9,10,11,12,
13,14,15, 0}
-- -- multi-tile-metric walking distance heuristic lookup (mmwd). -- ========================================================== -- Uses patterns of counts of tiles in/from row/col, eg the solved state -- (ie goal above) could be represented by the following: -- {{4,0,0,0}, -- {0,4,0,0}, -- {0,0,4,0}, -- {0,0,0,3}} -- ie row/col 1 contains 4 tiles from col/row 1, etc. In this case -- both are identical, but you can count row/col or col/row, and then -- add them together. There are up to 24964 possible patterns. The -- blank space is not counted. Note that a vertical move cannot change -- a vertical pattern, ditto horizontal, and basic symmetry means that -- row/col and col/row patterns will match (at least, that is, if they -- are calculated sympathetically), halving the setup cost. -- The data is just the number of moves made before this pattern was -- first encountered, in a breadth-first search, backwards from the -- goal state, until all patterns have been enumerated. -- (The same ideas/vars are now also used for stm metrics when MTM=0) -- sequence wdkey -- one such 4x4 pattern constant mmwd = new_dict() -- lookup table, data is walking distance.
--
-- We use two to-do lists: todo is the current list, and everything
-- of walkingdistance+1 ends up on tdnx. Once todo is exhausted, we
-- swap the dictionary-ids, so tdnx automatically becomes empty.
-- Key is an mmwd pattern as above, and data is {distance,space_idx}.
--
integer todo = new_dict()
integer tdnx = new_dict()
--
enum UP = 1, DOWN = -1
procedure explore(integer space_idx, walking_distance, direction) -- -- Given a space index, explore all the possible moves in direction, -- setting the distance and extending the tdnx table. -- integer tile_idx = space_idx+direction
for group=1 to SIZE do
if wdkey[tile_idx][group] then
-- ie: check row tile_idx for tiles belonging to rows 1..4
-- Swap one of those tiles with the space
wdkey[tile_idx][group] -= 1
wdkey[space_idx][group] += 1
if getd_index(wdkey,mmwd)=0 then
-- save the walking distance value
setd(wdkey,walking_distance+1,mmwd)
-- and add to the todo next list:
if getd_index(wdkey,tdnx)!=0 then ?9/0 end if
setd(wdkey,{walking_distance+1,tile_idx},tdnx)
end if
if MTM then
if tile_idx>1 and tile_idx<SIZE then
-- mtm: same direction means same distance:
explore(tile_idx, walking_distance, direction)
end if
end if
-- Revert the swap so we can look at the next candidate.
wdkey[tile_idx][group] += 1
wdkey[space_idx][group] -= 1
end if
end for
end procedure
procedure generate_mmwd() -- Perform a breadth-first search begining with the solved puzzle state -- and exploring from there until no more new patterns emerge. integer walking_distance = 0, space = 4
wdkey = {{4,0,0,0}, -- \
{0,4,0,0}, -- } 4 tiles in correct row positions
{0,0,4,0}, -- /
{0,0,0,3}} -- 3 tiles in correct row position
setd(wdkey,walking_distance,mmwd)
while 1 do
if space<4 then explore(space, walking_distance, UP) end if
if space>1 then explore(space, walking_distance, DOWN) end if
if dict_size(todo)=0 then
if dict_size(tdnx)=0 then exit end if
{todo,tdnx} = {tdnx,todo}
end if
wdkey = getd_partial_key(0,todo)
{walking_distance,space} = getd(wdkey,todo)
deld(wdkey,todo)
end while
end procedure
function walking_distance(sequence puzzle) sequence rkey = repeat(repeat(0,SIZE),SIZE),
ckey = repeat(repeat(0,SIZE),SIZE)
integer k = 1
for i=1 to SIZE do -- rows
for j=1 to SIZE do -- columns
integer tile = puzzle[k]
if tile!=0 then
integer row = floor((tile-1)/4)+1,
col = mod(tile-1,4)+1
rkey[i][row] += 1
ckey[j][col] += 1
end if
k += 1
end for
end for
if getd_index(rkey,mmwd)=0
or getd_index(ckey,mmwd)=0 then
?9/0 -- sanity check
end if
integer rwd = getd(rkey,mmwd),
cwd = getd(ckey,mmwd)
return rwd+cwd
end function
sequence puzzle string res = "" atom t0 = time(),
t1 = time()+1
atom tries = 0
constant ok = {{0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1}, -- left
{0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1}, -- up
{1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0}, -- down
{1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0}} -- right
function iddfs(integer step, lim, space, prevmv)
if time()>t1 then
printf(1,"working... (depth=%d, tries=%d, time=%3ds)\r",{lim,tries,time()-t0})
t1 = time()+1
end if
tries += 1
integer d = iff(step==lim?0:walking_distance(puzzle))
if d=0 then
return (puzzle==goal)
elsif step+d<=lim then
for mv=1 to 4 do -- l/u/d/r
if prevmv!=(5-mv) -- not l after r or vice versa, ditto u/d
and ok[mv][space] then
integer nspace = space+{-1,-4,+4,+1}[mv]
integer tile = puzzle[nspace]
if puzzle[space]!=0 then ?9/0 end if -- sanity check
puzzle[space] = tile
puzzle[nspace] = 0
if iddfs(step+iff(MTM or not STM?(prevmv!=mv):1),lim,nspace,mv) then
res &= "ludr"[mv]
return true
end if
puzzle[nspace] = tile
puzzle[space] = 0
end if
end for
end if
return false
end function
function pack(string s) integer n = length(s), n0 = n
for i=1 to 4 do
integer ch = "lrud"[i], k
while 1 do
k = match(repeat(ch,3),s)
if k=0 then exit end if
s[k+1..k+2] = "3"
n -= 2
end while
while 1 do
k = match(repeat(ch,2),s)
if k=0 then exit end if
s[k+1] = '2'
n -= 1
end while
end for
return {n,iff(MTM?sprintf("%d",n):sprintf("%d(%d)",{n,n0})),s}
end function
procedure apply_moves(string moves, integer space) integer move, ch, nspace
puzzle[space] = 0
for i=1 to length(moves) do
ch = moves[i]
if ch>'3' then
move = find(ch,"ulrd")
end if
-- (hint: "r" -> the 'r' does 1
-- "r2" -> the 'r' does 1, the '2' does 1
-- "r3" -> the 'r' does 1, the '3' does 2!)
for j=1 to 1+(ch='3') do
nspace = space+{-4,-1,+1,4}[move]
puzzle[space] = puzzle[nspace]
space = nspace
puzzle[nspace] = 0
end for
end for
end procedure
function solvable(sequence board) integer n = length(board) sequence positions = repeat(0,n)
-- prepare the mapping from each tile to its position
board[find(0,board)] = n
for i=1 to n do
positions[board[i]] = i
end for
-- check whether this is an even or odd state
integer row = floor((positions[16]-1)/4),
col = (positions[16]-1)-row*4
bool even_state = (positions[16]==16) or (mod(row,2)==mod(col,2))
-- count the even cycles
integer even_count = 0
sequence visited = repeat(false,16)
for i=1 to n do
if not visited[i] then
-- a new cycle starts at i. Count its length..
integer cycle_length = 0,
next_tile = i
while not visited[next_tile] do
cycle_length +=1
visited[next_tile] = true
next_tile = positions[next_tile]
end while
even_count += (mod(cycle_length,2)==0)
end if
end for
return even_state == (mod(even_count,2)==0)
end function
procedure main()
puzzle = {15,14, 1, 6,
9,11, 4,12,
0,10, 7, 3,
13, 8, 5, 2}
if not solvable(puzzle) then
?puzzle
printf(1,"puzzle is not solveable\n")
else
generate_mmwd()
sequence original = puzzle
integer space = find(0,puzzle)
for lim=walking_distance(puzzle) to iff(MTM?43:80) do
if iddfs(0, lim, space, '-') then exit end if
end for
{integer n, string ns, string ans} = pack(reverse(res))
printf(1,"\n\noriginal:")
?original
atom t = time()-t0
printf(1,"\n%soptimal solution of %s moves found in %s: %s\n\nresult: ",
{iff(MTM?"mtm-":iff(STM?"stm-":"non-")),ns,elapsed(t),ans})
puzzle = original
apply_moves(ans,space)
?puzzle
end if
end procedure main()</lang>
- Output:
original:{15,14,1,6,9,11,4,12,0,10,7,3,13,8,5,2}
non-optimal solution of 35(60) moves found in 2.42s: u2r2d3ru2ld2ru3ld3l2u3r2d2l2dru2ldru2rd3lulur3dl2ur2d2
stm-optimal solution of 38(52) moves found in 1 minute and 54s: r3uldlu2ldrurd3lu2lur3dld2ruldlu2rd2lulur2uldr2d2
mtm-optimal solution of 31(60) moves found in 2 hours, 38 minutes and 28s: u2r2d3ru2ld2ru3ld3l2u3r2d2l2dru3rd3l2u2r3dl3dru2r2d2