#!/usr/local/bin/prologcgi

:-s_charset(_,utf8).
:- kanji_mode(_,off).

:-s_mode(_,on).

top_call:-
    (get_param(resolve,Res)->true,Checked=' checked ';Res='',Checked=''),      %% 全解のチェックボックス
    (get_param(compile,COMP)->true;COMP=''),    %% コンパイルチェックボックス
    otameshi_get_param(A,B,FN),                 %% その他呼び出し引数を得る
    local_time([Nen,Getu,Youbi,Niti,Ji,Fun,Sec|MiS]),youbi(Youbi,You),
    atom_appends([Nen,年,Getu,月,Niti,日,You,Ji,時,Fun,分,Sec,秒],Nengetu),
    s_randomize(Fun,Sec),s_random(16,Rand0),to_hex(Rand0,Rand),
    html_call([
    "Content-Type: text/html; charset=utf-8

     <html lang='ja'><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'> 
     <title>おためしAZ-Prolog</title>
     <script language='JavaScript'>
     <!--
          function subWin1(){window.open('puttxt.exe?otameshi.cgi','source');}
     //-->
     </script>
     </head>
     <body BGCOLOR='#",Rand,"DE22' TEXT='#000000' ><center><H1>おためしAZ-Prologインタプリタ／コンパイラ</H1> 		
     <table>
       <tr><td>プログラム入力欄、質問入力欄に入力またはSelectし【Go】押下でAZ-Prologの実行をお試し頂けます</td></tr>
       <tr><td>[全解]チェックボックスはトップレベルで強制的にバックトラックを発生し全解を表示します</td></tr>
       <tr><td>[Compile]チェックボックスは入力プログラムをバイトコードコンパイル後に実行します</td></tr>
       <tr><td><H3>サーバー負荷・安全のためプログラム容量、稼動可能時間、組込述語を制限しています</H3></td></tr>
     </table>
     <table border=0><tr>
	<td Align='left' Width=100><INPUT TYPE=button VALUE='ソース表示' OnClick='javascript:subWin1();'></td>
	<td Align='left' Width=100><INPUT TYPE='button' VALUE='戻る' onClick='history.back()' > </td>
	<td Align='left' Width=300> ",Nengetu,"</td>",
	call(disp_counter(otameshi,'   Counter:')),
     "</tr></table><br>

     <table border='2'> 
     <tr><td>領域サイズ</td><td><pre>",
            call(statistics),"</pre>割り当て稼動秒：最大５秒</td></tr>
     <form action='otameshi.cgi' method='POST'>
        <tr><td>プログラム</td><td><textarea cols='90' rows='10' name = 'pg' >",
            call(otameshi_puts(A)), "</textarea></td></tr>
        <tr><td>質問</td><td>| ?- <textarea cols='65' rows='1' name ='query'>",
            call(otameshi_puts(B)), "</textarea><input type='submit' value='Go'>
             <select name='program'>
               <option selected value='input' >【入力質問Call】",
               call(all_options),
             "</select><br>
             　全解<input type='checkbox' name='resolve' ",Checked,"value=';'>
             　Compile <input type='checkbox' name='compile' value='compile'>
      </form>
      <form enctype='multipart/Form-data' action='otameshi.cgi' method='POST'>
                <font color='Blue'><b>User Program: </b></font>",FN,"　<input type='file' name='user_file' size=30 >
                <input type='submit' value='UpLoad'>
      </form>
            </td></tr>
        </td></tr><tr><td>解</td> 
     <td><pre>",
            call(otameshi_go(COMP,Res,A,B)),
    "</pre></H2></td></tr></table></center></body></html>" ]).


%%%%%% カウンタ処理 %%%%%%%%%%

disp_counter(ID,Name):-
	get_counterR(ID,Count),
	html_call(["<td><font face='fantasy'>",Name,"</td><td bgcolor='Silver' align='center' width='100'> ",Count," </font></td>"]).

%% ?-get_counterR(ProgramID,Number).
get_counterR(ID,CC):- 
	s_version(_,'Win32',_,_),
	get_counter(ID,CC),!.

get_counterR(ID,CC):- 
	fileerrors(_,fail),
	atom_appends(['tmp/',ID,'.cnt'],F),
	(see(F) ->read(C),seen; C = 0),
	CC is C+1,tell(F),!,write(CC),write('.'),nl,told.
get_counterR(ID,0). 

%% ?-get_counter(odbctest,X).   X=N
get_counter(ID,X):- exec_direct(counter(update),[ID]),select_each([X],counter(select),[ID]),!,odbc_close.
get_counter(ID,X):- odbc_close,exec_direct(counter(insert),[ID]),!,get_counter(ID,X).
get_counter(ID,X):- odbc_close,exec_direct(counter(create),[]),!,get_counter(ID,X).

youbi(0,' 日曜日 '):-!.
youbi(1,' 月曜日 '):-!.
youbi(2,' 火曜日 '):-!.
youbi(3,' 水曜日 '):-!.
youbi(4,' 木曜日 '):-!.
youbi(5,' 金曜日 '):-!.
youbi(6,' 土曜日 '):-!.

to_hex(X,X):- X<10,!.
to_hex(X,[Y]):- Y is "A"+X-10.

%%%%%%%%%%%%%%%% 
sql_connect_data(counter(_),           "test","test","test").    

sql_statement(counter(create),[],      ["create table count_tbl ( countid char(10) primary key,countno integer)"]).
sql_statement(counter(insert),[],      ["insert into count_tbl (countid,countno) values('",_,"',0)"]).
sql_statement(counter(select),[long],  ["select countno from count_tbl where countid='",_,"'"]).
sql_statement(counter(update),[],      ["update count_tbl set countno=countno+1 where countid='",_,"'"]).


%%%%%% パラメータ処理 %%%%%%%%%%
otameshi_get_param(FileContents,'',FileName):- get_param(user_file,{FileName,X,FileContents}),!.
otameshi_get_param(A,B,''):- ( get_param(program,C);C=trans ),!,otameshi_get_param2(C,A,B).

otameshi_get_param2(input,A,B):-get_param(pg,A),get_param(query,B),!.
otameshi_get_param2(S,A,B):-  select_query(S,_,B,A),!.

%%%%%%%%%%%%%%%%
otameshi_go(_,_,_,''):-!.
otameshi_go(COMP,Res,PG,Query):-
    (atom(PG) -> atom(PG,L);length(PG,L)),e_create(L*3+100),     % Program 文字数X2＋αのエディタバッファを確保
    tell(edit),otameshi_puts(PG),told,e_markend,e_jump(0),       % Program をエディタバッファに書き込む
    otameshi_errorset_cut('プログラム',e_reconsult),             % エディタバッファからDCGコンサルト
    otameshi_check_query(Query,Query0),                          % クエリの末のピリオッドチェック
    otameshi_errorset_cut('問い合わせ',term_atom(Term,Query0)),  % 問い合わせを項に変換
    compile_source(COMP),                                        % コンパイルチェック処理
    set_exit_timer(5000),                                        % 無限ループ等にそなえ5秒でプロセスを自滅させる
    rm_builtins,                                                 % system に悪影響を与える可能性のある処理をさせないための措置
    Start is cputime,
      call_v(Res,Term),                                          % 問い合わせが成功すれば結果とＹｅｓを表示
    Time is cputime-Start,
    write_listnl(['<br><br>(',Time,' Seconds)']).
otameshi_go(_,_,_,_).

%%%%%%% 入力エリアのチェックとエラー時のエラー部分表示処理 %%%%%
otameshi_errorset_cut(_,X):-  errorset(X,succ),!.

otameshi_errorset_cut(M,_):- 
	write_listnl(['<H3><font color=red>',M,にエラーがあります,'</font></H3>']),fail.

otameshi_errorset_cut(プログラム,_):- 
	errormode(_,0),e_jump(0),e_markend,see(edit),
	repeat,e_pos(X),errorsetcut(read(T),S),(S==succ->T==end_of_file;e_pos(Y)),!,
	e_jump(Y),e_mark,e_jump(X),copy0,seen,fail.

errorsetcut(X,S):-errorset(X,S),!.

%%%% 入力質問のチェック %%%% 
otameshi_check_query(X,Y):- rexpl(X,"(.+)\.[ \t]*$",_,_,_,[X0]),!,name(Y,X0).   % 文末の"."を削除
otameshi_check_query(X,X).                                                      % "."が無い場合はまあ、いいか。

%%%% 文字列の表示 %%%%
otameshi_puts([]):- !.
otameshi_puts([C|T]):- !,put(C),otameshi_puts(T).
otameshi_puts(A):- write(A).

%%%% サーバーに悪影響の可能性のある組み込み述語の削除 %%%%
%%%% たとえばつぎのような質問をされるとＤｉｓｋがパンクしてしまう
%%%% ?- tell(temp),repeat,write(error),fail.

rm_builtins:-
    rm_builtin(s_new,0),rm_builtin(tell,1),rm_builtin(tella,1),
    rm_builtin(log,0),rm_builtin(log,1),rm_builtin(tell,2),
    rm_builtin(tella,2),rm_builtin(system,1),rm_builtin(sh,0),
    rm_builtin(d_open,1),rm_builtin(d_create,2),rm_builtin(save,1),
    rm_builtin(rename,2),rm_builtin(system,2),rm_builtin(s_child,5),
    rm_builtin(winCallApi,7).

%%%%　変数の対応充足値出力つきＣａｌｌ%%%%%%%
call_v(Res,X):-
	s_freevar(X,[],Y),      % 入力質問から変数名つき変数を取り出す
	   call(X),                  % 質問を呼び出す
	write_each(Res,Y),           % Ｔｒｕｅの場合、変数名＝結果値 を表示
	(Res = ';' ->Y=[];true),     % 全解チェック（；）で変数があるならバックトラック
	write(yes).                  % yes を表示

call_v(_,_):-  write(no).        % ＦＡＩＬの場合、no を表示

write_each(T,[]):-!,nl.
write_each(T,[B,A|L]):-
	(L=[] ->D=T;D=','),            % 最後の変数で無い場合は値の後ろに ","をつける
	to_atom(B,B),                  % 変数のままのときは変数名を表示
	write_listnl([A,'	= ',B,D]), 
	write_each(T,L).

%% [1,2,3|<LOOP>] の<LOOP>などがタグと扱われて表示されないので、エディタバッファを利用
%% して文字列とし、一文字ずつ出力する。
%% と、しようと思ったが、tell/1　を削除してしまっていたので使えない。

write_through_edit(B):-
	e_new,tell(edit),write(B),told,e_mark(M),MM is M-1,
	e_jump(0),see(edit),repeat(S),get0(X),put(X),S==MM,!,seen.

%%%%%% プログラムをユニークな名前のファイルに吐き出し、コンパイルして読み込む
compile_source(''):- !.
compile_source(_):- 
	s_pid(PID),
	atom_appends(['tmp_',PID,'.pl'],TMP0),
	atom_append('tmp/',TMP0,TMP),
	atom_appends(['tmp/tmp_',PID,'.b'],TMPB),
	tell(TMP),listing,write(':- publicall.'),nl,told,
	atom_append('cd tmp && azpc -p /byte /no_module /NOM ',TMP0,XX),
	errorset(system(XX),_),!,b_load(TMPB),
	rename(TMP,[]),rename(TMPB,[]),

	write('【コンパイル（バイトコード）による実行】<br>'),nl.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% 入力クエリから変数のみ取り出し、重複を省いた変数名とのペアリストを作る
%% s_freevar(入力項,ＩＮキュー,ＯＵＴキュー)
%%
%% ?-s_freevar((b([A|X]),S=[a,1,A]),[],Qout).
%%
%% Qout= [A_2,'A',X_4,'X',S_6,'S']

s_freevar(X,    Que,Que ):- atomic(X),!.                                 % アトムは変数ではない
s_freevar(X,    Qin,Qout):- var(X),!,check_que(X,Qin,Qout).              % 変数のキューチェック/エントリ
s_freevar([X|L],Qin,Qout):- !,s_freevar(X,Qin,Qw),s_freevar(L,Qw,Qout).  % リストはCar,Cdrに分けて処理
s_freevar(TM,   Qin,Qout):- TM =..[_|L],s_freevar(L,Qin,Qout).           % その他の項の処理

check_que(X,[],     [X,N]):- !,to_atom(X,N).       % キューが空なら変数名と変数のペアを追加
check_que(X,[V|Q],  [V|Q]):- X==V,!.               % すでにキューに入っている
check_que(X,[V,N|Q],[V,N|R]):- check_que(X,Q,R).   % のこりのキューのチェック

%% 変数はヒープにあるとき、VarName_セルアドレス値 となるので "_セルアドレス値"を削除しアトム化

to_atom(V,A):- var(V),!,
	term_atom(a(V),At), rexpl(At,"a\((.+)_[0-9]+\)$",_,_,_,[AL]),!,
	(AL=[]->A=At;name(A,AL)).
to_atom(_,_).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Select Option の出力 %%%%

all_options:- bagof([X,Y],(A,B)^select_query(X,Y,A,B),L),!, write_all_options(L).

write_all_options([]):-!.
write_all_options([[X,Y]|L]):-
	write_listnl(['<option value="',X,'" > ',Y]),
	write_all_options(L).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%Ｐｒｏｌｏｇ例題の簡易入力%%%%%%%
%% select_query(オプションValue,オプション表示値,デフォルト質問,プログラム).

select_query(clear,'【領域クリア】','','').

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
select_query(fatal,定言三段論法,
'死ぬ(ソクラテス).',
"%  ?- 死ぬ(X).

人間(ソクラテス).
人間(アリストテレス).
死ぬ(X) :- 人間(X). ").

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
select_query(append,リストの結合,
'my_append([1,2,3],[4,5,6],X).',
"% リストの結合
% ?-my_append(X,Y,[1,2,3,4,5,6]).

my_append([],L,L).
my_append([A|L],B,[A|LB]):-my_append(L,B,LB). ").

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
select_query(nrev,'Nrevベンチマーク',
'do_nrev.',
"% Nreverse ベンチマークテスト
% ３０要素のリストの反転を１万回実行し１秒間の推論スピードを計算する
% ?-do_nrev.   

% １MLips(1Mega Logical Inference Per Second) は１秒間に１００万回の推論能力を示します
% ここではインタプリタとバイトコードでのベンチマークが計測できます
% バイトコードコンパイルには【compile】 のチェックボックスをチェックしてください

% インタプリタ：バイトコード：フルコンパイルの速度性能比は概ね、１：４：１０　です 

%do_nrev:- write(done),nl.
do_nrev:- do_nrev(1000).

do_nrev(N):-
      N >= 1,                                 % Ｎ（繰り返し数）が１以上
      data(L),                                % 30要素のリスト
      X is cputime,                           % スタートのＣＰＵ時間（秒）
         repeat(X1),nrev(L,_),N is X1+1,!,    % Nrev をＮ回繰り返す
      Y is cputime,                           % 処理後のＣＰＵ時間（秒）
         repeat(X2),N is X2+1,!,              % 繰り返えし制御のみをＮ回おこなう
      Z is cputime,                           % 処理後のＣＰＵ時間（秒）
      Full is Y-X,                            % NrevをＮ回おこなった時間+繰り返しの制御時間
      Null is Z-Y,                            % Nrevを除く制御にかかった時間
      True is Full-Null,                      % N回のNrevの実時間
      True \== 0.0,                           % 実時間が計測できない場合はＮを増やす必要有り
      Lips is (496*N)/True,                   % １秒あたりの推論回数
      MLips is Lips/1000000,                  % １秒あたりの推論回数(Mega換算）
      write_listnl([MLips,' MLips']).

data([ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,
      11,12,13,14,15,16,17,18,19,20,
      21,22,23,24,25,26,27,28,29,30]).

% 30要素のリスト反転 は４９６論理推論。 Ｎ要素の推論数は次の計算となる
%｛Ｎ＋（Ｎ−１）＋（Ｎ−２）＋（Ｎ−３）．．．＋１｝＋（Ｎ＋１）
% ------------ s_append/3 の呼び出し ---------------    nrev/2の呼び出し

:- mode nrev(+,-).
nrev([],[]).
nrev([A|X],Y):- nrev(X,P),s_append(P,[A],Y).

:- mode s_append(+,+,-).
s_append([],L,L).
s_append([A|B],C,[A|BC]):- s_append(B,C,BC).
").

%%%%%%%%%%%%%%%%%%%%%%%%%%%
select_query(queens,'Nクイーン',
'put([1,2,3,4,5,6,7,8],[],X).',
"/*
  ?-put([1,2,3,4,5,6,7,8],[],X).   % 8クイーン1解ずつ結果をリストで表示
  ?-put([1,2,3,4,5,6,7,8],[],[]).  % 8クイーン全解（結果表示なし）
*/
%% put(要素リスト,既置リスト,答え).
put([],L,L):-!.        % 初期リストが空なら、既置リストが結果リストである
put(S,L,Ans):-
  select(S,A,B),       % 初期リストから要素を一つ取り出す。取り出した残りリストがＢ
  safe(A,A,L),         % これが今までに置いたものと衝突しないか調べる
  put(B,[A|L],Ans).    % 取り出した要素を既置リストに加え残りリストを更に置く

%%  Generate
%% リストから要素を一つ選ぶ。それを省いたリストを得る  < 非決定性
select([A|B],A,B).                % 先頭は要素である。
select([A|B],S,[A|L]):-           % 先頭以外からの要素も要素である
  select(B,S,L).

%%   Test
%% 安全に置けるかテストする
safe(_,_,[]):-!.        % テスト対象が空なら真（True）
safe(A,B,[C|D]):-       % テスト対象の最初の既置位置(C)が
  AA is A-1,AA \==C,    % 新要素の左下が既置位置と衝突しない
  BB is B+1,BB \==C,    % 新要素の右下が既置位置と衝突しない
  safe(AA,BB,D).        % 残りの既置位置が衝突しない
").

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
select_query(cabocha,かぼちゃ（係り受け解析）,
'go("昨日、わたしは北アルプスの槍ヶ岳に行ってきました").',
"%%
 %%　かぼちゃ（係り受け解析）
 %%
go(A):-
	(atom(A) ->name(A,STATEMENT);A=STATEMENT),!,
	cabocha_new(CABO, []), 
		write('<pre>'),nl,
			cabocha_sparse_tostr(CABO, STATEMENT, RESULT),
				puts(RESULT),
		write('%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'),nl,
			cabocha_sparse_totree(CABO, STATEMENT, TREE),
			cabocha_tree_size(TREE, SIZE),
			cabocha_tree_get_chunk_list(TREE, CHUNK_LIST),
				write(size=SIZE),nl,nl,
				write_chunk_list(CHUNK_LIST),
		write('</pre>'),nl,
	cabocha_destroy(CABO).

go(_).

%%%%%%%%%%%%%
puts([]):- !,nl.
puts([C|T]):- puta([C]), puts(T).

puta(""<""):-write('&lt;'),!.
puta("">""):-write('&gt;'),!.
puta([X]):- put(X),!.

%%%%%%%%%%%%%
write_chunk_list([]):- !.
write_chunk_list([[A,B,C,D,E|F]|T]):- 
	write([A,B,C,D,E]),nl,write(F),nl,nl,
	write_chunk_list(T).
").
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
select_query(trans,英日翻訳,
'trans("time flies like an arrow",S,X).',
"/*
 **** 翻訳プログラム例題 ****
 */
 
trans(Bun,IMI,J):-
    bagof(A,L^(rexpl(Bun,'[^ ^\.]+',L),name(A,L)),E),  % 文字列をアトム並びへ変換
    s(IMI,E,[]),                                       % 英語の構文解析
    js(IMI,J,[]).                                      % 同一構文を持つ日本語生成 

%%%%%%%%%%%%%%%%%%%%%%%%
%% 英語構文規則、辞書 %%

% 通常文
    s([s,Np,Vp]) --> np(Np),vp(Vp).
% 命令文
    s([s,Vp])    --> vp(Vp).

% 名詞句
    np([np,Noun])     --> n(Noun).
    np([np,N,Np])     --> n(N),np(Np).
    np([np,Det,Noun]) --> det(Det),n(Noun).

% 動詞句
    vp([vp,Vi,PP]) --> vi(Vi),pp(PP).
    vp([vp,Vi])    --> vi(Vi).

    vp([vp,Vt,Np])    --> vt(Vt),np(Np).
    vp([vp,Vt,Np,PP]) --> vt(Vt),np(Np),pp(PP).

% 前置詞句
    pp([pp,P,Np]) --> p(P),np(Np).

% 終端節
    n([n,time])  --> [time].
    n([n,'I'])   --> ['I'].
    n([n,you])   --> [you].
    n([n,arrow]) --> [arrow].
    n([n,flies]) --> [flies].
    n([n,like])  --> [like].

    det([det,a]) --> [an].
    p([p,like])  --> [like].

  % 動詞
    vi([vi,flies]) --> [flies].
    vi([vi,like])  --> [like].
    vt([vt,time])  --> [time].
    vt([vt,like])  --> [like].

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% 日本語構文規則、辞書                      %%
%%  <<注意>>                                 %%
%%  英語の文法規則、単語を意味表現としている %%

% 通常文
    js([s,Np,Vp]) --> jnp(Np),[は],jvp(Vp).
% 命令文
    js([s,Vp])    --> jvp(Vp).

% 名詞句
    jnp([np,N,Np])     -->jn(N),[の],jnp(Np).
    jnp([np,Det,Noun]) -->jdet(Det),jn(Noun).
    jnp([np,Noun])     -->jn(Noun).

% 動詞句
    jvp([vp,Vi])       -->jvi(Vi).
    jvp([vp,Vi,PP])    -->jpp(PP),jvi(Vi).

    jvp([vp,Vt,Np])    --> jnp(Np),[を],jvt(Vt).
    jvp([vp,Vt,Np,PP]) --> jnp(Np),[を],jpp(PP),jvt(Vt).

% 前置詞句
    jpp([pp,P,Np]) --> jnp(Np),jp(P).

% 終端節
    jn([n,time])  --> [時].
    jn([n,'I'])   --> [私].
    jn([n,you])   --> [あなた].
    jn([n,arrow]) --> [矢].
    jn([n,flies]) --> [蝿].
    jn([n,flies]) --> [てんぷら].
    jn([n,like])  --> [好み].

    jdet([det,a])   -->[ひとつの].
    jp([p,like])    -->[のように].

  % 動詞
    jvi([vi,flies]) -->[飛ぶ].
    jvi([vi,flies]) -->[揚がる].
    jvi([vi,like])  -->[好む].
    jvt([vt,time])  -->[計る].
    jvt([vt,like])  -->[好む].
    jvt([vt,flies]) -->[揚げる].
").

select_query(sudoku,'数独パズル',
'go(1).',
"
% SUDOKU SOLVER   2013.11.24  T.Inaba(SOFNEC.CO.LTD)
% | ?- go(PatterNo).    % PatternNo 1-4 : 9x9     5 : 25x25
 
sudoku_pattern(1,
	[[9,_,_,  _,_,8,  _,_,3],
	 [_,8,_,  1,_,_,  5,_,_],
	 [_,_,_,  _,_,7,  _,1,_],
 
	 [_,4,_,  _,1,_,  _,_,9],
	 [_,_,7,  _,_,_,  4,_,_],
	 [3,_,_,  _,6,_,  _,5,_],

	 [_,3,_,  8,_,_,  _,_,_],
	 [_,_,6,  _,_,3,  _,2,_],
	 [2,_,_,  9,_,_,  _,_,7]]).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% http://gigazine.net/news/20100822_hardest_sudoku/

sudoku_pattern(2,
	[[_,_,5,  3,_,_,  _,_,_],
	 [8,_,_,  _,_,_,  _,2,_],
	 [_,7,_,  _,1,_,  5,_,_],
 
	 [4,_,_,  _,_,5,  3,_,_],
	 [_,1,_,  _,7,_,  _,_,6],
	 [_,_,3,  2,_,_,  _,8,_],

	 [_,6,_,  5,_,_,  _,_,9],
	 [_,_,4,  _,_,_,  _,3,_],
	 [_,_,_,  _,_,9,  7,_,_]]).

sudoku_pattern(3,
	[[1,2,3,  4,5,6,  7,8,9],
	 [4,5,6,  7,8,9,  1,2,3],
	 [7,8,9,  1,2,3,  4,5,6],
 
	 [2,_,_,  _,_,_,  _,_,_],
	 [_,_,_,  _,_,_,  _,_,_],
	 [_,_,_,  _,_,_,  _,_,_],

	 [_,_,_,  _,_,_,  _,_,_],
	 [_,_,_,  _,_,_,  _,_,_],
	 [_,_,_,  _,_,_,  _,_,_]]).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% http://rocketnews24.com/2012/07/03/22654/

sudoku_pattern(4,
	[[8,_,_,  _,_,_,  _,_,_],
	 [_,_,3,  6,_,_,  _,_,_],
	 [_,7,_,  _,9,_,  2,_,_],
 
	 [_,5,_,  _,_,7,  _,_,_],
	 [_,_,_,  _,4,5,  7,_,_],
	 [_,_,_,  1,_,_,  _,3,_],

	 [_,_,1,  _,_,_,  _,6,8],
	 [_,_,8,  5,_,_,  _,1,_],
	 [_,9,_,  _,_,_,  4,_,_]]).

 %%%%%%%%%%%%%%%%%%%%%%%
 %%%% Pattern 25x25 %%%%

sudoku_pattern(5,
 [[ 2, _, _, _, 6,24, 9,16,20, 3, _, 4,23, _,11,13, _,10,17, _, _,14, _,19, 5],
  [16, 1,22, _, 5,23,19, _, _, _,12, 2, _, _,25,11, _, _, _, 9, _, _,18,21, 6],
  [ _,24, _, _, _, 4, _, 8, _, _,16,19,18, 5, 3, _, _,12, _, 6, _, _, 9, 1,25],
  [11, _,23, _, _,10, _, 1, _,25, 6,17,20, _,13, 4, _, 2,22, _, _, _, _,16,24],
  [ 8, _,13,21, 3, _, 6,18, _,17, _, 9,22, _,14, 1, _, 5, _,25, 7, _, _, _, _],
  [24, _, _, _,15, 7, _, 3,16,20, _, _,21,10, 2, _, 1, _,11, 8,25, _, _, 4, _],
  [25, _, _,23, _,21, _, _, _,19,24, _, 3, 6, _,17, _, _,18,16, 9, 2, _, _, _],
  [ _,21,19, _,10, _, 4, _,15, _, 5,18,25,23,12, _, _,13, _,20,11, _, _,14, _],
  [22,13,20,17, _, 6, _, _,25, _,19,11,14, _, 4, _, 2,21, _,23, _, 8,15, _, _],
  [ _, _, 6, _, _,17,14,13,22, 9, _, _, _,16, _, _, _,25, _, _,24,19, 3,23, _],
  [10, _, 2, 9,11, 8,17, _, _,16, _, _, 7, _, _,22, _, _,13, _, _,25,20,18,15],
  [13, _, _, _,22, _, _,21, _, 1, _, _, _, _,15, _, _, _, _, 5, 2,12, _, _,19],
  [ 1, _,15, 8,14,22,25,23, 7,11, _, 6, 2, _,10, _,20, _,21, _, _,24, 5, _, _],
  [ _,20, _,25, _, 5, _,15,19, 2, _,16,11, _,24, 6, _,18, 8,17,23, 9, _,22, _],
  [21, 6,18,19, _,20,12, _,14, _, _, _,17, _,22, _, _, _, _, 2,16, 7,11, _, 1],
  [ _, _, _, _,17,25, 2,20, _,10, _, _, _, 4, 1, _,12,24, _,15,22, 5, _, _, _],
  [ 5, 2,24, _,25, _, 8,19, _, 7, _,10,12, _, 6, 3, _, 4, _,13, _, _, _, _, _],
  [ 4, 3, _, 6,20, _,15,22, _,21, _,25, 5, 8, _,16, _, _, _,11, _, _,23,12,18],
  [ _,23, 9,10,19, _, _, _, 3, 4, _, _, _,22, _, _, 5, 8, 6, 1, _,13,16, _,11],
  [ _,18, _, _, _, 1, _,11, _,14,13, 7,19, _,20, 2,17,23,10,22, 8, _,24, _, _],
  [ 9, _, _, 1, _, _,20,25, _, 5, _, _, _, 2,16,12, _, _, _, _, 4,15, _,11, 8],
  [ _, _,25, 7, _,15,16, _,17,13,14, _,10,20, _, _, _, 9, 5, _, 1, _,21, 3, 2],
  [23, _, _, 2,12, _, _, _, _, 6, 7, 8, _,19, _,18,21,16,24, _,17, _, _,13, 9],
  [20, 4,14, _,21, _, _, _, _, _,22,15, 6,25, _, _,13, _, _, _, _,16, _, _, 7],
  [ _, 8,16, 3, _, 9,24, _, _,12, _,21, 1,17,23, _, _, _, 2, _, 6,22,14, _,10]]).

 %%%%%%%%%%%%%%%%%%%%%
 %%%% Pattern 4x4 %%%%
sudoku_pattern(6,
	[[_,1,  _,_],
	 [_,_,  2,_],
 
	 [3,_,  _,_],
	 [_,_,  _,4]]).

:- dlib_require(clp).

go:- go(1),go(2),go(3),go(4),go(5).

go(No):- 
  sudoku_pattern(No,Horizontal),!,
  get_vars(Horizontal,Vertical,Box,Write0,Length,VL),
  add_color(Write0,Write), 
  write('<table><tr><td>'),
  mapcar(writeo,['No.',No,' Problem ',Length,x,Length,' '|Write],[]),
    statistics(runtime,[Begin,_]),
	mapcar(in,           Horizontal, [1..Length]),
	mapcar(alldifferent, Horizontal, []),
	mapcar(alldifferent, Vertical,   []),
	mapcar(alldifferent, Box,        []),
	mapcar(labeling,     Horizontal, []),
    statistics(runtime,[End,_]),
  Time is End-Begin,
  verify(VL,Horizontal,Vertical,Box,Verify),
  (No=5 -> true;write('</td><td>　</td><td>')),
  mapcar(write,['Solved! ',Time,msec,Verify|Write],[]),
  write('</td></tr></table>').

%%%% map call
mapcar(Func,[Arg1|R],Arg2):- !,G=..[Func,Arg1|Arg2],call(G),mapcar(Func,R,Arg2).
mapcar(_,   [],_).

%%%% result verify
verify(L,H,V,B,' Verify OK!'):-
	mapcar(sort,H,L),mapcar(sort,V,L),mapcar(sort,B,L),!.
verify(_,_,_,_,' Verify NG!').

%%% End Of Main Program %%%
%%%%%%%%%%%%%%%%%%%%%%%%%%% 
writeo(L):- writeo(L,'[').

writeo([],_):-!,write(']').
writeo([X|L],SP):- !,write(SP),writev(X,Y),write(Y),writeo(L,',').
writeo(X,_):- write(X).

writev(X,'_'):- var(X),!.
writev(X,X).

add_color(X,Y):-integer(X),!,atom_appends(['<font color=red>',X,'</font>'],Y).
add_color(X,X):- var(X),!.
add_color([],[]):-!.
add_color([X|L],[XX|R]):- !,add_color(X,XX),add_color(L,R).
add_color(X,X).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Making Var List For Constraint if not created 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
?- get_vars(Horizontal,Vertical,Box,Write,4,VerifyL).

Horizontal = [[X1, X2,  X3, X4],     % in 1..4,alldifferent
              [X5, X6,  X7, X8],     % in 1..4,alldifferent
              [X9, X10, X11,X12],    % in 1..4,alldifferent
              [X13,X14, X15,X16]]    % in 1..4,alldifferent

Vertical   = [[X1,X5,X9,X13],        % alldifferent
              [X2,X6,X10,X14],       % alldifferent
              [X3,X7,X11,X15],       % alldifferent
              [X4,X8,X12,X16]]       % alldifferent

Box        = [[X1,X2,X5,X6],         % alldifferent
              [X3,X4,X7,X8],         % alldifferent
              [X9,X10,X13,X14],      % alldifferent
              [X11,X12,X15,X16]]     % alldifferent

Write      = [[X1,X2],  ' ',[X3,X4],'
',            [X5,X6],  ' ',[X7,X8],'
','
',            [X9,X10], ' ',[X11,X12],'
',            [X13,X14],' ',[X15,X16],'
','
']

VerifyL    = [[1,2,3,4]]

*/

:- dynamic sudoku_vars/6.              % dummy for contorol unknown ERROR!
get_vars(H,V,B,W,Length,VL):-             % Created !
	sudoku_vars(H,V,B,W,Length,VL),!.
get_vars(HH,V,B,W,Length,VL):-             % Not Created Yet! 
  	length(HH,Length),
  	S is integer(sqrt(Length)),
	   make_h(Length,Length,H,[],VL),
	   make_v(H,V),
	   make_b(S,H,B),
	   make_w(NL,H,S,S,W),
	asserta(sudoku_vars(H,V,B,W,Length,VL)),
	H=HH,make_w(P,H,S,S,W).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Making Horizontal vars List
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
make_h(_,0,[],   VL,[VL]):-!.
make_h(N,M,[B|H],VL,VLR):- make_h2(N,B),MM is M-1, make_h(N,MM,H,[M|VL],VLR).
  %%
make_h2(0,[]):-!.
make_h2(N,[X|B]):- M is N-1,make_h2(M,B).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Horizontal  ==> Vertical vars
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
make_v([[]|_],[]):-!.
make_v(H,     [B|V]):-make_v2(H,B-B,NextH),make_v(NextH,V).
  %%
make_v2([],       _-[],   []):-!.
make_v2([[X|Q]|H],B-[X|T],[Q|NextH]):- make_v2(H,B-T,NextH).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Horizontal ==> Box vars List
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
make_b(_,[],[]):- !.
make_b(S,[[]|L],Ans):-!,make_b(S,L,Ans).                % delete Null EOL
make_b(S,H,     [B|Ans]):-make_b2(S,S,S,H,B-B,NextH),make_b(S,NextH,Ans).
  %%
make_b2(_,1,0,NextH,    _-[],   NextH):-!.                           % EndOfBox
make_b2(S,M,0,[Q|H],    B,      [Q|R]):-!,N is M-1,make_b2(S,N,S,H,B,R).  % EOL
make_b2(S,M,C,[[X|Q]|H],B-[X|T],NextH):-D is C-1,make_b2(S,M,D,[Q|H],B-T,NextH).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% Horizontal ==> write Goal
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
make_w(Z,H,    S,0,[Z|R]):-!,make_w(Z,H,S,S,R).
make_w(Z,[B|H],S,N,[Z|R]):-!,make_w2(B,S,S,Q-Q,R-T),M is N-1,make_w(Z,H,S,M,T).
make_w(Z,[],   _,_,[Z]):- make_cr(Z).
  %%
make_w2([],   _,_,Q-[],   [Q|R]-R):-!.
make_w2(B,    S,0,Q-[],   [Q,' '|R]-T):-!,make_w2(B,S,S,Y-Y,R-T).
make_w2([X|B],S,N,Q-[X|P],Result):- M is N-1,make_w2(B,S,M,Q-P,Result).
  %%
make_cr('<br>
').

").

:-s_mode(_,off).
