fixedpoint.jp - 箱入り娘を連れ出すには




箱入り娘を連れ出すには

先日「箱入り娘」というパズルを教えてもらいました。(いくつかバリエーションがあるようですが)よく知られているパターンでもそらでは解けそうになかったので、swi-prolog で解いてみました。

hakoiri.pl
:- module(hakoiri,[play/4,history/4,search/0]).

box(4,5).

block(daughter,2,2).
block(father,1,2).
block(mother,1,2).
block(grandfather,1,2).
block(grandmother,1,2).
block(brother,2,1).
block(wasai,1,1).
block(kado,1,1).
block(sado,1,1).
block(shodo,1,1).

initial(daughter,1,0).
initial(father,0,0).
initial(mother,3,0).
initial(grandfather,0,2).
initial(grandmother,3,2).
initial(brother,1,2).
initial(wasai,0,4).
initial(kado,1,3).
initial(sado,2,3).
initial(shodo,3,4).

goal(daughter,1,3).

%%% an alternative problem

%% block(oh,2,2).
%% block(hisha,1,2).
%% block(kaku,1,2).
%% block(kin,2,1).
%% block(gin,2,1).
%% block(keima1,1,1).
%% block(keima2,1,1).
%% block(yari1,1,1).
%% block(yari2,1,1).
%% block(fu1,1,1).
%% block(fu2,1,1).

%% initial(hisha,0,0).
%% initial(oh,1,0).
%% initial(kaku,3,0).
%% initial(yari1,0,2).
%% initial(keima1,1,2).
%% initial(keima2,2,2).
%% initial(yari2,3,2).
%% initial(kin,0,3).
%% initial(gin,2,3).
%% initial(fu1,0,4).
%% initial(fu2,3,4).

%% goal(oh,1,3).

initial_positions(Positions) :- setof([Block,X,Y],initial(Block,X,Y),Positions).

spaces(Positions,Spaces) :- setof([X,Y],space(X,Y,Positions),Spaces).

space(X,Y,Positions) :-
    box(Width,Height),
    XMax is Width-1,
    YMax is Height-1,
    between(0,XMax,X),
    between(0,YMax,Y),
    \+ covered(X,Y,Positions).

covered(_,_,[]) :- !,fail.
covered(X,Y,[[Block,X0,Y0]|_]) :-
    block(Block,W,H),
    X1 is X0+W-1,
    Y1 is Y0+H-1,
    between(X0,X1,X),
    between(Y0,Y1,Y).
covered(X,Y,[_|Rest]) :- covered(X,Y,Rest).

layout([Block,X,Y],[X,Y,W,H]) :- block(Block,W,H).

layouts(Positions,Sorted) :- maplist(layout,Positions,Layouts),sort(Layouts,Sorted).

move(Block,X0,Y0,Spaces0,X1,Y0,Spaces1) :- % left
    0<X0,
    block(Block,W,H),
    X1 is X0-1,
    Y1 is Y0+H-1,
    setof([X1,Y],between(Y0,Y1,Y),S0),
    subset(S0,Spaces0),
    X2 is X0+W-1,
    setof([X2,Y],between(Y0,Y1,Y),S1),
    subtract(Spaces0,S0,R),
    union(R,S1,Spaces1).
move(Block,X0,Y0,Spaces0,X1,Y0,Spaces1) :- % right
    block(Block,W,H),
    X2 is X0+W,box(Width,_),X2<Width,
    Y1 is Y0+H-1,
    setof([X2,Y],between(Y0,Y1,Y),S0),
    subset(S0,Spaces0),
    X1 is X0+1,
    setof([X0,Y],between(Y0,Y1,Y),S1),
    subtract(Spaces0,S0,R),
    union(R,S1,Spaces1).
move(Block,X0,Y0,Spaces0,X0,Y1,Spaces1) :- % up
    0<Y0,
    block(Block,W,H),
    X1 is X0+W-1,
    Y1 is Y0-1,
    setof([X,Y1],between(X0,X1,X),S0),
    subset(S0,Spaces0),
    Y2 is Y0+H-1,
    setof([X,Y2],between(X0,X1,X),S1),
    subtract(Spaces0,S0,R),
    union(R,S1,Spaces1).
move(Block,X0,Y0,Spaces0,X0,Y1,Spaces1) :- % down
    block(Block,W,H),
    X1 is X0+W-1,
    Y2 is Y0+H,box(_,Height),Y2<Height,
    setof([X,Y2],between(X0,X1,X),S0),
    subset(S0,Spaces0),
    Y1 is Y0+1,
    setof([X,Y0],between(X0,X1,X),S1),
    subtract(Spaces0,S0,R),
    union(R,S1,Spaces1).

:- dynamic history/4, layouts/1, counter/1.

play(Positions,Spaces,Path,N) :-
    repeat,
    retract(history(Position0,Spaces0,Path0,N0)),
    select([Block,X0,Y0],Position0,Rest),
    move(Block,X0,Y0,Spaces0,X,Y,Spaces),
    Positions = [[Block,X,Y]|Rest],
    layouts(Positions,Layouts),
    \+ layouts(Layouts),
    assertz(layouts(Layouts)),
    Path = [Position0|Path0],
    N is N0+1,
    assertz(history(Positions,Spaces,Path,N)).

setup :-
    initial_positions(InitialPositions),
    spaces(InitialPositions,InitialSpaces),
    layouts(InitialPositions,InitialLayout),
    assert(history(InitialPositions,InitialSpaces,[],0)),
    assert(layouts(InitialLayout)),
    assert(counter(0)).

search :-
    setup,
    goal(Block,X,Y),
    play(Positions,_,Path,N),
    counter(Num),
    ( N>Num ->
      retractall(counter(_)),
      assert(counter(N)),
      writef('%t\n',[N])
    ; true
    ),
    nth0(0,Positions,[Block,X,Y]),
    % output
    write('moves: \n'),
    maplist(nth0(0),Path,P),
    reverse(P,[_|Moves]),
    forall(nth1(Nm,Moves,[Bm,Xm,Ym]),writef(' %t: (%t, %t) %t\n',[Nm,Xm,Ym,Bm])),
    writef(' %t: (%t, %t) %t\n',[N,X,Y,Block]),
    write('final positions:\n'),
    forall(member([Bp,Xp,Yp],Positions),writef(' (%t, %t) %t\n',[Xp,Yp,Bp])).

実行例: 手元のノートパソコンで30分近くかかりました。

$ swipl -s hakoiri.pl
% hakoiri.pl compiled into hakoiri 0.00 sec, 12,996 bytes
Welcome to SWI-Prolog (Multi-threaded, 32 bits, Version 5.6.58)
Copyright (c) 1990-2008 University of Amsterdam.
SWI-Prolog comes with ABSOLUTELY NO WARRANTY. This is free software,
and you are welcome to redistribute it under certain conditions.
Please visit http://www.swi-prolog.org for details.

For help, use ?- help(Topic). or ?- apropos(Word).

?- search.
1
2
3
(snip)
115
116
moves: 
 1: (2, 4) shodo
 2: (3, 3) grandmother
 3: (2, 2) brother
 4: (1, 2) kado
 5: (1, 4) wasai
 6: (0, 3) grandfather
 7: (0, 2) kado
 8: (1, 2) brother
 9: (3, 2) grandmother
 10: (3, 4) shodo
 11: (2, 4) wasai
 12: (1, 3) grandfather
 13: (0, 3) kado
 14: (0, 4) kado
 15: (0, 2) brother
 16: (2, 2) sado
 17: (2, 3) wasai
 18: (2, 4) shodo
 19: (3, 3) grandmother
 20: (3, 2) sado
 21: (1, 2) brother
 22: (0, 1) father
 23: (0, 2) father
 24: (0, 0) daughter
 25: (2, 0) mother
 26: (3, 1) sado
 27: (3, 0) sado
 28: (3, 2) grandmother
 29: (3, 1) grandmother
 30: (3, 4) shodo
 31: (3, 3) wasai
 32: (2, 3) grandfather
 33: (1, 4) kado
 34: (1, 3) kado
 35: (0, 3) father
 36: (0, 2) brother
 37: (2, 2) grandfather
 38: (2, 4) shodo
 39: (1, 4) shodo
 40: (2, 3) grandfather
 41: (2, 1) mother
 42: (2, 0) sado
 43: (3, 0) grandmother
 44: (3, 2) wasai
 45: (3, 3) grandfather
 46: (2, 2) mother
 47: (2, 3) mother
 48: (2, 2) wasai
 49: (2, 1) wasai
 50: (1, 2) brother
 51: (2, 2) brother
 52: (0, 2) father
 53: (0, 4) shodo
 54: (1, 4) kado
 55: (1, 2) father
 56: (0, 3) shodo
 57: (0, 4) kado
 58: (1, 3) father
 59: (1, 2) brother
 60: (0, 2) brother
 61: (2, 2) mother
 62: (3, 1) grandmother
 63: (3, 0) sado
 64: (2, 0) wasai
 65: (2, 1) mother
 66: (2, 3) father
 67: (1, 4) kado
 68: (0, 4) shodo
 69: (0, 3) brother
 70: (0, 1) daughter
 71: (1, 0) wasai
 72: (0, 0) wasai
 73: (2, 0) sado
 74: (1, 0) sado
 75: (2, 0) mother
 76: (2, 2) father
 77: (2, 4) kado
 78: (1, 4) shodo
 79: (3, 0) grandmother
 80: (3, 2) grandfather
 81: (3, 4) kado
 82: (2, 4) shodo
 83: (0, 4) brother
 84: (0, 2) daughter
 85: (1, 1) sado
 86: (0, 1) sado
 87: (1, 0) mother
 88: (2, 1) father
 89: (2, 0) father
 90: (1, 2) daughter
 91: (0, 2) sado
 92: (0, 3) sado
 93: (0, 1) wasai
 94: (0, 2) wasai
 95: (0, 0) mother
 96: (1, 0) father
 97: (2, 0) grandmother
 98: (3, 1) grandfather
 99: (3, 0) grandfather
 100: (2, 2) daughter
 101: (1, 2) wasai
 102: (0, 2) sado
 103: (0, 3) brother
 104: (1, 4) shodo
 105: (0, 4) shodo
 106: (2, 4) kado
 107: (1, 4) kado
 108: (2, 3) daughter
 109: (2, 2) wasai
 110: (3, 2) wasai
 111: (1, 2) sado
 112: (2, 2) sado
 113: (0, 2) brother
 114: (1, 3) kado
 115: (0, 3) kado
 116: (1, 3) daughter
final positions:
 (1, 3) daughter
 (0, 3) kado
 (0, 2) brother
 (2, 2) sado
 (3, 2) wasai
 (0, 4) shodo
 (3, 0) grandfather
 (2, 0) grandmother
 (1, 0) father
 (0, 0) mother
?- 

この結果から、最短116手でこのよく知られているパターンは解けるということが分かります。ただし、いずれかのブロックを1マス分動かすことを1手と数えています。上の Wikipedia のページには81手で解けると書かれていますが、おそらく同じブロックを1マス分もしくは2マス分続けて動かすことを1手と数えていると推測しています(その数え方では上の解は94手となる)。

注意として、play/4 は非決定的に複数の解を探すことができますが、枝刈りの影響で一部の解しか返しません。

その枝刈りのための仕組みは layouts/1 のみで、history/4 によるメモ化を行っていることを除けば、上のコードはほぼ最適化なしで実現できました。こういった種類の問題は Prolog の得意とするところといえます。


© 2006-2010 Takeshi Abe