Latest comments for language 'Prolog' on doukaku.org

pooq's comment on LL Golf Hole 8 - 横向きのピラミッドを作る

LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)

?- \4.
*
**
***
****
***
**
*

\N:-1-N.
N-N:- +N.
L-N:- +L,M is L+1,M-N,+L.
+N:-writef('%r\n',[*,N]).

[ Prolog ] [ download code ] ]

yohei's comment on LL Golf Hole 8 - 横向きのピラミッドを作る

LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)

SWI-Prologで

1	p(N):-L is-N,between(L,N,X),K is N-abs(X),writef('%r\n',[*,K]),X=N.

[ Prolog ] [ download code ] ]

pooq's comment on 九九の表示

九九の表示 (Nested Flatten)

writef と format の書式指定は全然違うんだなあ。

1 2	d(1). d(2). d(3). d(4). d(5). d(6). d(7). d(8). d(9). :-d(A),d(B),C is AB,\+writef('%d %d =%3r',[A,B,C]).

[ Prolog ] [ download code ] ]

pooq's comment on Hello, world!その２

Hello, world!その２ (Nested Flatten)

1	writef([72,101,108,108,111,44,32,119,111,114,108,100,33]).

[ Prolog ] [ download code ] ]

yohei's comment on LL Golf Hole 5 - 最上位の桁を数え上げる

LL Golf Hole 5 - 最上位の桁を数え上げる (Nested Flatten)

SWI-Prologで。

count(N) :- writeln(0), sub_atom(N,1,_,_,Y), between(1,9,X), 
    atom_concat(X,Y,XY), writeln(XY), atom_number(XY,N), !.

:- count(300).

[ Prolog ] [ download code ] ]

yohei's comment on LL Golf Hole 4 - 文章から単語の索引を作る

LL Golf Hole 4 - 文章から単語の索引を作る (Nested Flatten)

SWI-Prologで。大文字は小文字に変換しました。次のようにして、参照できます。
?- index('future', N).
N = 58 ;
N = 579.

:- use_module(library('http/http_open')).

assert_word(_, '') :- !.
assert_word(In, W) :- downcase_atom(W, WL), line_count(In, N), assert(index(WL, N)).

make_index(In, W) :- at_end_of_stream(In), assert_word(In, W), !.
make_index(In, W) :- peek_char(In, C), (char_type(C, csym) -> atom_concat(W, C, W1);
     assert_word(In, W), W1 = ''), get_char(In, _), make_index(In, W1).

:- http_open('http://www.gnu.org/licenses/gpl.txt', In, []), make_index(In, ''), close(In).

[ Prolog ] [ download code ] ]

yohei's comment on データの整列

データの整列 (Nested Flatten)

辞書順の方は，組み込みで．距離の方は，距離-(X,Y)　のペアを作ってソート．

distance((X,Y), D) :- D is X * X + Y * Y.

distance_sort(L, S) :-
    map_list_to_pairs(distance, L, P),
    keysort(P, SP), pairs_values(SP, S).
    
:-  L = [(1,2), (3,4), (1,3), (2,4), (1,8)],
    msort(L, S1), writeln(S1),
    distance_sort(L, S2), writeln(S2).

[ Prolog ] [ download code ] ]

yohei's comment on 総当たり戦の日程作成

総当たり戦の日程作成 (Nested Flatten)

日にちだけの入れ替えを除いて，全通り出力．並びが逆になってるので見づらいですが．
4 teams
[[2-3, 1-4], [2-4, 1-3], [3-4, 1-2]]
6 teams
[[4-5, 2-3, 1-6], [3-6, 2-4, 1-5], [3-5, 2-6, 1-4], [4-6, 2-5, 1-3], [5-6, 3-4, 1-2]]
[[4-5, 2-3, 1-6], [3-4, 2-6, 1-5], [3-6, 2-5, 1-4], [5-6, 2-4, 1-3], [4-6, 3-5, 1-2]]
[[3-5, 2-4, 1-6], [4-6, 2-3, 1-5], [3-6, 2-5, 1-4], [4-5, 2-6, 1-3], [5-6, 3-4, 1-2]]
[[3-4, 2-5, 1-6], [4-6, 2-3, 1-5], [3-5, 2-6, 1-4], [5-6, 2-4, 1-3], [4-5, 3-6, 1-2]]
[[3-5, 2-4, 1-6], [3-4, 2-6, 1-5], [5-6, 2-3, 1-4], [4-6, 2-5, 1-3], [4-5, 3-6, 1-2]]
[[3-4, 2-5, 1-6], [3-6, 2-4, 1-5], [5-6, 2-3, 1-4], [4-5, 2-6, 1-3], [4-6, 3-5, 1-2]]

match([_], []).
match([X|Xs], Ys) :-
    group_pairs_by_key(Y, [X-Xs]), append(Y, Y1, Ys), match(Xs, Y1).

game([], G, G).
game([X1-X2|Xs], Ys, G) :-
    append(Y1, [Y|Y2], Ys), \+ memberchk(Y, Y2),
    \+ memberchk(X1-_, Y), \+ memberchk(_-X1, Y),
    \+ memberchk(X2-_, Y), \+ memberchk(_-X2, Y),
    append(Y1, [[X1-X2|Y]|Y2], Z), game(Xs, Z, G).

round_robin(N, G) :- N mod 2 =:= 0,
    numlist(1, N, X), match(X, Y), N1 is N - 1,
    length(G0, N1), maplist(ord_empty, G0), game(Y, G0, G).

:-  writeln('4 teams'), forall(round_robin(4, G), writeln(G)),
    writeln('6 teams'), forall(round_robin(6, G), writeln(G)).

[ Prolog ] [ download code ] ]

yohei's comment on 情報オリンピック2006年度国内本選問題4

情報オリンピック2006年度国内本選問題4 (Nested Flatten)

トポロジカルソートを使用しました．

:- use_module(library(ugraphs)).

read_number(In, Num) :-
    read_line_to_codes(In, Codes), number_codes(Num, Codes).

read_number2(In, X-Y) :- read_line_to_codes(In, C),
    append(C1, [0' |C2], C), number_codes(X, C1), number_codes(Y, C2).

read_match(N, Match) :- current_input(In),
    read_number(In, N), read_number(In, M),
    length(Match, M), maplist(read_number2(In), Match).

write_rank(Rank, Extra) :-
    maplist(writeln, Rank), writeln(Extra).

single_solution([_], _).
single_solution([X1,X2|Xs], Match) :-
    memberchk(X1-X2, Match), single_solution([X2|Xs], Match).

rank(N, Match, Rank) :- 
    numlist(1, N, L), vertices_edges_to_ugraph(L, Match, G), top_sort(G, Rank).

:-  setup_and_call_cleanup(see('input.txt'), read_match(N, Match), seen), 
    rank(N, Match, Rank), (single_solution(Rank, Match) -> Extra = 0; Extra = 1),
    setup_and_call_cleanup(tell('output.txt'), write_rank(Rank, Extra), told).

[ Prolog ] [ download code ] ]

yohei's comment on 文字変換表に基く文字列の変換

文字変換表に基く文字列の変換 (Nested Flatten)

% 基本版
tr(_, _, [], []).
tr(A, B, [X|Xs], [Y|Ys]) :-
    (nth0(N, A, X) -> nth0(N, B, Y); Y = X), tr(A, B, Xs, Ys).

% 拡張版
tr2(A, B, X, Y) :- expand(A, A1), expand(B, B1), tr(A1, B1, X, Y).

expand([], []).
expand([X1,0'-,X2|Xs], Ys) :- !,
    numlist(X1, X2, L), append(L, L1, Ys), expand(Xs, L1).
expand([X|Xs], [X|Ys]) :- expand(Xs, Ys).

:- tr("qwertyuiop", "QWERTYUIOP", "typewriter", X1),
   string_to_list(S1, X1), writeln(S1),
   tr2("a-z", "A-Z", "typewriter", X2),
   string_to_list(S2, X2), writeln(S2).

[ Prolog ] [ download code ] ]

yohei's comment on ライフゲーム

ライフゲーム (Nested Flatten)

SWI-Prologで．間引きは実装してません．

in_range(X, L) :- Max is L - 1, between(0, Max, X).

surround((LX,LY), (X,Y), (X1,Y1), B) :-
    member((DX, DY), [(-1,-1),(0,-1),(1,-1),(-1,0),(1,0),(-1,1),(0,1),(1,1)]),
    X1 is (LX + X + DX) mod LX, Y1 is (LY + Y + DY) mod LY, member((X1,Y1), B).

live((LX,LY), (X,Y), B) :-
    in_range(X, LX), in_range(Y, LY),
    findall(T, surround((LX,LY), (X,Y), T, B), S),
    length(S, N), (member((X,Y), B) -> (N = 2; N = 3); (N = 3)).

print_board((LX, LY), B) :- 
    forall(in_range(Y, LY), (forall(in_range(X, LX),
        (member((X,Y), B) -> write('■'); write('□'))
    ), writeln(''))), writeln('').

lifegame(L, B) :-
    print_board(L, B), sleep(1),
    findall(X, live(L, X, B), B1), lifegame(L, B1).

init_board((LX,LY), (X,Y)) :- in_range(X, LX), in_range(Y, LY), random(10) < 3.

:- L= (10,10), findall(X, init_board(L, X), B), lifegame(L, B).

[ Prolog ] [ download code ] ]

katsu's comment on 除算・余剰を使わずに閏年

除算・余剰を使わずに閏年 (Nested Flatten)

まあ、かけ算でも出来るわけでして。
＃なんか揚げ足取りばっかしているように思われ
＃ちゃうだろうなぁ。マイナス評価でもしょうがないか。


$ pl -qs 124.pl
?- uru(1900).

No
?- uru(2000).

Yes
?- uru(2008).

Yes
?- uru(2100).

No
?-

uru(X):- divideby400(X).
uru(X):- divideby4(X), not(divideby100(X)).

divideby(X, Y, Z) :- 0 =:= X - integer(X * Y) * Z.
divideby4(X) :- divideby(X, 0.25, 4).
divideby100(X) :- divideby(X, 0.01, 100).
divideby400(X) :- divideby(X, 0.0025, 400).

[ Prolog ] [ download code ] ]

yohei's comment on 除算・余剰を使わずに閏年

除算・余剰を使わずに閏年 (Nested Flatten)

1
2
3

leap(N) :- N < 0, N1 is N + 400, !, leap(N1).
leap(N) :- N >= 400, N1 is N - 400, !, leap(N1).
leap(N) :- N /\ 0b11 =:= 0b00, N \= 100, N \= 200, N \= 300.

[ Prolog ] [ download code ] ]

yohei's comment on ポーカーの役判定

ポーカーの役判定 (Nested Flatten)

permutationとパターンマッチで簡単に．効率は犠牲に．．．

pokerHand([X,X,X,X,X], R, 'Royal flush') :-
    permutation(R, ['T','J','Q','K','A']).

pokerHand([X,X,X,X,X], R, 'Straight flush') :-
    sub_atom('A23456789TJQK', _, 5, _, A),
    atom_chars(A, P), permutation(R, P).

pokerHand([X,X,X,X,X], _, 'Flush').

pokerHand(_, R, 'Straight') :-
    sub_atom('A23456789TJQKA', _, 5, _, A),
    atom_chars(A, P), permutation(R, P).

pokerHand(_, R, 'Four of a kind' ) :- permutation(R, [X,X,X,X,_]).
pokerHand(_, R, 'Full house'     ) :- permutation(R, [X,X,X,Y,Y]).
pokerHand(_, R, 'Three of a kind') :- permutation(R, [X,X,X,_,_]).
pokerHand(_, R, 'Two pair'       ) :- permutation(R, [X,X,Y,Y,_]).
pokerHand(_, R, 'One pair'       ) :- permutation(R, [X,X,_,_,_]).
pokerHand(_, _, 'No pair'        ).

poker(Card) :-
    atom_chars(Card, [S1,R1,S2,R2,S3,R3,S4,R4,S5,R5]),
    pokerHand([S1,S2,S3,S4,S5], [R1,R2,R3,R4,R5], H), !,
    writeln(H).

[ Prolog ] [ download code ] ]

katsu's comment on ポーカーの役判定

ポーカーの役判定 (Nested Flatten)

面倒なので、大文字ではなくて、小文字でカードを記述しています。スマートに出来るかと思ったけど、結局力業でした。

実行結果：
$ pl -qs 121.pl
sqsjsaskst->Royal flush
d9d7d6d5d8->Straight flush
c2d2s2h3h2->four of a kind
c2d3s2h3h2->Full house
s9s4s8stsj->Flush
c4h7d5s6h3->Straight
s6h6c5dqc6->Three of a kind
s6hqc5dqc6->Two pair
s6h4c5dqc6->One pair
sjsqsksac2->No Pair
?-

straight([(_,A)|As]):-seq(A,As).

seq(_,[]).
seq(P,[(_,N)|Ns]):-succ(P,N),seq(N,Ns).

flush([(A,_)|As]):-flush0(A,As).
flush0(_,[]).
flush0(A,[(A,_)|As]):-flush0(A,As).

count([],[]).
count([(_,N)|Ns],R):-count(Ns,Rs),countw(N,Rs,R).

countw(N,[],[(N,1)]).
countw(N,[(N,C0)|R],[(N,C)|R]):-succ(C0,C).
countw(N,[P|R0],[P|R]):-countw(N,R0,R).

sortcard(C,Cs):-predsort(cmp,C,Cs).
cmp(>,(_,N1),(_,N2)):-N1>N2,!.
cmp(<,_,_):-!.

p([(S,1),(S,10),(S,11),(S,12),(S,13)],'Royal flush'):-!.
p(C, 'Straight flush'):-straight(C),flush(C),!.
p(C, 'Flush'):-flush(C),!.
p(C, 'Straight'):-straight(C),!.
p(C, R) :- count(C,C1), maplist(arg(2),C1,C2),msort(C2,C3),n(C3, R).
p(_, 'No Pair').

n([2,3],'Full house'):-!.
n([1,4],'four of a kind'):-!.
n([1,1,3],'Three of a kind'):-!.
n([1,2,2],'Two pair'):-!.
n([1,1,1,2],'One pair'):-!.

tcard1([],[]).
tcard1([S,Na|Cs],[(S,N)|Cs1]):-nth1(N,[a,'2','3','4','5','6','7','8','9',t,j,q,k],Na),tcard1(Cs,Cs1).

poker(C,R):-atom_chars(C,Cs),tcard1(Cs,R0),sortcard(R0,R1),p(R1,R),!.

test(C):-poker(C,R),write(C->R),nl.

:-maplist(test,[sqsjsaskst,
                d9d7d6d5d8,
                c2d2s2h3h2,
                c2d3s2h3h2,
                s9s4s8stsj,
                c4h7d5s6h3,
                s6h6c5dqc6,
                s6hqc5dqc6,
                s6h4c5dqc6,
                sjsqsksac2]).

[ Prolog ] [ download code ] ]

katsu's comment on コラッツ・角谷の問題

コラッツ・角谷の問題 (Nested Flatten)

あけましておめでとうございます。
ぜんぜんprologらしくないのですみません。
cのループは、計算途中をassertaするために、あえて末尾再帰させていません。

結果：
 $ time pl -qs 120.pl
837799, 524

real    0m6.870s
user    0m6.308s
sys     0m0.551s

:-dynamic(ca/2).

even(N):- 1 =:= N /\ 1.

c(1,0):-!.
c(N,R):-ca(N,R),!.
c(N,R) :-!, (even(N)->N1 is N * 3 + 1; N1 is N / 2),
            c(N1,R0),
            succ(R0,R),
            asserta(ca(N,R)).

max_c(M,M,MaxI,MaxF,(MaxI,MaxF)).
max_c(I,M,MaxI,MaxF,R):-!,
        c(I,F),
        succ(I,I1),
        (MaxF < F -> max_c(I1,M,I,F,R)
                   ; max_c(I1,M,MaxI,MaxF,R)).

max_c(M,R):-max_c(1,M,0,0,R).

:-N is integer(2^20) + 1, max_c(N,R), write(R), nl, halt.

[ Prolog ] [ download code ] ]

katsu's comment on 魔方分割数

魔方分割数 (Nested Flatten)

普通にfindallすると、スタックオーバーフローするので、数だけ数えるようにしています。

副作用を使っているのは、数を数える部分だけで、本質的なところではないので、許して下さい。

あんまり早くなくて残念。

実行時間
N=4の場合、
 $ time pl -qs 108-1.pl
392

real    0m0.049s
user    0m0.043s
sys     0m0.006s

N=5の場合
 $ time pl -qs 108-1.pl
3245664

real    13m27.466s
user    13m19.891s
sys     0m0.909s

maho(N,R):-SS is integer(N ^ 2),
           S is integer((SS + 1) * SS / 2 / N),
           seq(SS,Lx),
           reverse(Lx,Lxx),
           C=c(0),
           (gen(N,S,Lxx,_,_),
            countup(C),
            fail
           ;C=c(R)).

countup(C):-arg(1,C,N0),succ(N0,N1),nb_setarg(1,C,N1).

gen_list(1,V,[1],[V]).
gen_list(X,V,[0|L],[0|T]):-
        succ(X1,X),
        gen_list(X1,V,L,T).

gen(N,_,[V],L,T):-!,
        gen_list(N,V,L,T).
gen(N,S,[I|Is],L,T):-
        gen(N,S,Is,Ls,T0),
        addH(N,S,Ls,T0,I,L,T).

addH(_,_,[],_,_,_):-fail.
addH(N,S,[L|Ls],[T|Ts],I,[L1|Ls],[T1|Ts]):-
        Ls\=[0|_],
        L1 is L + 1,
        T1 is T + I,
        (L1=N,S=T1;T1<S,L1<N).
addH(N,S,[L|Ls],[T|Ts],I,[L|Lss],[T|Tss]):-
        addH(N,S,Ls,Ts,I,Lss,Tss).

seq(0,[]).
seq(N,[N|L]):-
        succ(N1,N),
        seq(N1,L).

:-maho(5,C),write(C),nl,halt.

[ Prolog ] [ download code ] ]

yohei's comment on ２進数の記述

２進数の記述 (Nested Flatten)

SWI-prologでは，ISO準拠の0bを付けた書き方と Edinburgh Prologの2～36の基数を指定した書き方があります．

1
2
3

?- X is 0b01101001, Y is 2'01101001.
X = 105,
Y = 105

[ Prolog ] [ download code ] ]

yohei's comment on あみだくじ

あみだくじ (Nested Flatten)

switch(['|'], [A], [A]).
switch(['|','-','|'|S], [A,' ',B|L], [B,' ',C|L1]) :-
    switch(['|'|S], [A|L], [C|L1]).
switch(['|',' ','|'|S], [A,' ',B|L], [A,' ',C|L1]) :-
    switch(['|'|S], [B|L], [C|L1]).

amida_sub(Hs, []) :- atom_chars(H, Hs), writeln(H).
amida_sub(Hs, [X|L]) :- writeln(X), atom_chars(X, Xs),
    switch(Xs, Hs, H1), amida_sub(H1, L).

amida(A) :- concat_atom([H|L], '\n', A), writeln(H),
    atom_chars(H, Hs), amida_sub(Hs, L).

:- amida('A B C D E
| | |-| |
|-| | |-|
| |-| |-|
|-| |-| |
|-| | | |').

[ Prolog ] [ download code ] ]

yohei's comment on 小町算

小町算 (Nested Flatten)

101件確認しました．

komati([X], N, X) :- term_to_atom(T, X), N =:= T.
komati([X1,X2|Xs], N, S) :- member(Op, [+,-,*,/,'']),
    concat_atom([X1,Op,X2], X3), komati([X3|Xs], N, S).

:- forall(komati([1,2,3,4,5,6,7,8,9], 100, S), writeln(S)).

[ Prolog ] [ download code ] ]