/*
家系分析用Prologプログラム　（漢字データ使用版）
file name; komekin3.txt
home; www.d1.dion.ne.jp/~tmhk/yosida.htm

自殖作物（稲麦など）用

?-kin, kin2，kin3，kakei，zenbu（品種名）などでスタート
kin　は　その後２品種名を入力すればそれら間の近縁係数が計算される
kin2　は　この下部のkin2の品種名に予め品種名を入れておく．増やして可
kin3　は　同上．複数品種間相互の値を計算．最終結果は'out.txt'へ自動的に出力 

kakei，同3(品種名)で家系図作成　後者は一度出たのは省力　
kakei2　全祖先ベタ出力
zenbu，同2，sedai（品種名）で祖先数，除共通，世代数計測（最後表示の数）

両親データは rr('  ') の形で追加．場所はどこでも可．品種名以外は半角入力

original　　　　　　　　　　by　Sasaaki & Yoshida 1988
kataoya shori sumi       　  by T.Y 1995.9.18  
kin,kin2,kin3 added  　             1995.12.15  
Modified for Windows                2004.10.18
Modified for Kanji                  2004.10.20
kin3 > out.txt   added              2004.11.4  
*/
/*        第一部稲近縁係数算出       */
/* 　以下　kin2．予め計算したい品種名をここにいれておく　*/
kin2:-[X,Y]=['コシヒカリ','農林２２号'],katao(X,Y),fail.
kin2:-[X,Y]=['コシヒカリ','農林８号'],katao(X,Y),fail.
/* 　kin2　終わり　   */
/*　以下はいじらない　*/
kin:-write('品種名を入力'),read(X),write('もう一つの品種名を入力'),
read(Y),katao(X,Y),fail.
/*　out出力避けるにはlog部分３行(3,5,9番目)の前に％を     */
kin3:-kotae(0);retract(kotae(V)),fail;
      namae1(X),namae2(Y),kiru(X,L),write(L),kiru(Y,M),write(M),tab(1),katao(X,Y),fail;
      log('out.txt'),
      write('kakka; '),
      nolog,rename('out.txt',[]),log('out.txt'),
      fail;nl,
      namae1(X),namae2(Y),write(X),write(' vs '),write(Y),nl,fail;
      nl,kotae(V),write(V),nl,fail
      ;nolog
      .
/* 　ダミー両親追加．これしないとダメ．　 */
katao(X,Y):-write(X),nl,write(Y),assert(rr('>>>',X,'dummyx')),
assert(rr('<<<',Y,'dummyy')),[W,Z]=['>>>','<<<'],sta(W,Z).
/* 　rr( ) から時間節約のため必要データのみ抽出　 */
r(du1,du2,du3).
rret:-retract(r(X,Y,Z)),fail,!.
oy(A,X):-rr(A,X,_).
oy(A,X):-rr(A,_,X).
oy(X,Y):-fail.
so3(A):-rr(A,Z,W),mae2(A,Z,W),oy(A,X),so3(X).
mae2(A,Z,W):-r(A,Z,W),!,fail;assert(r(A,Z,W)).
/* 以下近縁係数の計算 共通祖先の近交係数を１としている　*/
sta(X,Y):-so3(X).
sta(X,Y):-so3(Y).
sta(X,Y):-start(X,Y).
sta(X,Y):-rret.
sta(X,Y):-retract(rr('>>>',_,_)),retract(rr('<<<',_,_)).
start(X,Y):-(point(Z)->retract(point(Z));true),assert(point(0)),kinkou(X,Y).
kinkou(X,Y):-not(o_srch(X,Y,1,[[],[X]])),not(o_srch(Y,X,1,[[],[Y]])),
not(p_srch(X,Y,1,[X])),nl,write('Coefficient of Relationship = '),point(P),
nl,Q is P * 4,write(Q),nl,assert(kotae(Q)),write('XXXXXXXXXXXXXXXX'),nl,nl.
p_srch(X,Y,P,L):-(r(X,V,_);r(X,_,V)),A is P * 0.5,append(L,V,L1),
not(o_srch(V,Y,A,[L1,[V]])),not(p_srch(V,Y,A,L1)),fail.
o_srch(V,Y,P,[L1,L2]):-(r(Y,V,_);r(Y,_,V)),A is P * 0.5,append(L2,Y,L3),
retract(point(N)),A1 is N + A,assert(point(A1)),keiro(L1,L3,A),!,fail.
o_srch(V,Y,P,[L1,L2]):-(r(C,V,_);r(C,_,V)),not(member(C,L1)),A is P * 0.5,
append(L2,C,L3),not(o_srch(C,Y,A,[L1,L3])),fail.
keiro(L1,L2,A):-write('*  '),l_disp(L1),nl,write('** '),l_disp(L2),nl,
write(A),write('  x4'),nl.
l_disp([]):-!.
l_disp([H|B]):-write(H),write('  '),l_disp(B).
not(X):-X,!,fail.
not(_).
append([],X,[X]).
append([A|X],Y,[A|Z]):-append(X,Y,Z).
member(A,[A|L]).
member(A,[_|L]):-member(A,L).
/*以上で第一部終わり*/
/*
  　第二部　家系図作成
*/
ma('du1').
kakei(A):-d_clear,write('***  '),write(A),write('  の家系図  ***'),
c_era,nl,nl,sosen(A). 
kakei3(A):-d_clear,write('***  '),write(A),write('  の家系図２ ***'),
c_era,nl,nl,sosen3(A),!.
kakei3(A):-ret. 
ret:-retract(ma(X)),fail,!.
oya(X,Y):-tab(2),haha(X,Y),count(N).
oya(X,Y):-titi(X,Y),coun2(N).
oya(X,Y):-coun3(N),fail.
/*　以下の　　k<6　の　6を変えれば（２カ所とも）遡る世代数が変更される　*/
haha(A,X):-rr(A,X,_),cloc4(K),K<6.
titi(A,X):-rr(A,_,X),cloc4(K),K<6,nl,tab(K*18+2).
cloc4(K):-clock(N),cloc2(M),cloc3(J),K is N+M-J.
sosen(A):-oya(A,X),kiru(X,Y),write(Y),sosen(X).
sosen3(A):-mae(A),oya(A,X),kiru(X,Y),write(Y),sosen3(X).
mae(A):-ma(A),cloc4(K),K<7,write(' - shown   '),coun3(N),!,fail;assert(ma(A)).
kakei2(A):-d_clear,write('***  '),write(A),write('  の親一覧  ***'),
nl,nl,sosen2(A).
oya2(X,Y):-tab(2),haha2(X,Y).
oya2(X,Y):-titi2(X,Y).
haha2(A,X):-rr(A,X,_).
titi2(A,X):-rr(A,_,X),nl.
sosen2(A):-oya2(A,X),write(X),sosen2(X).
kiru(X,Y):-name(X,T),
append2(T,[33092,33092,33092,33092,33092,33092,33092],Z),
Z=[X1,X2,X3,X4,X5,X6,X7,X8|Rest],
W=[X1,X2,X3,X4,X5,X6,X7,X8],name(Y,W).
append2([],X,X).
append2([A|X],Y,[A|Z]):-append2(X,Y,Z).
clock(0).
cloc2(0).
cloc3(0).
coun3(N):-cloc3(M),N is M+1,retract(cloc3(M)),assert(cloc3(N)).
coun2(N):-cloc2(M),N is M+1,retract(cloc2(M)),assert(cloc2(N)).
count(N):-clock(M),N is M+1,retract(clock(M)),assert(clock(N)).
c_era:-retract(clock(N)),assert(clock(0)),retract(cloc2(M)),
assert(cloc2(0)),retract(cloc3(J)),assert(cloc3(0)).
/* 第３部　　家系図中祖先数など　 */
/*　総祖先数　*/
zenbu(A):-motoni,sosu(A).
zenbu(A):-write(' <= total sosen no kazu '),nl.
sosu(A):-pama(A,X),write(X),kazu(N),tab(1),write(N),sosu(X).
pama(X,Y):-tab(1),mama(X,Y).
pama(X,Y):-papa(X,Y).
mama(A,X):-rr(A,X,_).
papa(A,X):-rr(A,_,X),nl.
azukari(0).
kazu(N):-azukari(M),N is M+1,retract(azukari(M)),assert(azukari(N)).
motoni:-retract(azukari(N)),assert(azukari(0)).
/* 除共通 */
zenbu2(A):-motoni2,sosu2(A).
zenbu2(A):-write(' <= kyotu nozoita sosen no kazu '),nl,motohe. 
motohe:-retract(fu(X)),fail,!.
fu('du1').
sosu2(A):-fue(A),pama2(A,X),write(X),kazu2(N),tab(1),write(N),sosu2(X).
pama2(X,Y):-tab(1),mama2(X,Y).
pama2(X,Y):-papa2(X,Y).
mama2(A,X):-rr(A,X,_).
papa2(A,X):-rr(A,_,X),nl.
fue(A):-fu(A),write(' - shown '),hiku(N),!,fail;assert(fu(A)).
azukari2(0).
kazu2(N):-azukari2(M),N is M+1,retract(azukari2(M)),assert(azukari2(N)).
hiku(N):-azukari2(M),N is M-1,write(N),retract(azukari2(M)),assert(azukari2(N)).
motoni2:-retract(azukari2(N)),assert(azukari2(0)).
/* 世代数 */
sed(0).
sedai(A):-assert(azukari7(0)),fail.
sedai(A):-motoni4,saishu(A),fail. 
sedai(A):-sed(K),write(K),tab(1),fail,!.
sedai(A):-nl,write(' saidai sedai suu => '),hikaku,fail.
hikaku:-sed(K),hikaku2(K),fail,!.
hikaku2(K):-azukari7(M),K > M -> assert(azukari7(K)),retract(azukari7(M));!.
sedai(A):-azukari7(M),N is M + 1,write(N),nl,fail.
sedai(A):-retract(azukari7(M)),fail.
sedai(A):-motoni3.
pama3(X,Y):-tab(1),mama3(X,Y),kazu3(N).
pama3(X,Y):-papa3(X,Y),kazu4(N).
pama3(X,Y):-kazu5(N),fail.
mama3(A,X):-rr(A,X,_),azukari6(K),write(K),assert(sed(K)),tab(1).
papa3(A,X):-rr(A,_,X),azukari6(K),write(K),assert(sed(K)),tab(1),nl.
azukari6(K):-azukari3(N),azukari4(M),azukari5(J),K is N+M-J.
saishu(A):-pama3(A,X),write(X),saishu(X).
azukari3(0).
azukari4(0).
azukari5(0).
kazu7(M,L):-azukari7(M),retract(azukari7(M)),assert(azukari7(L)).
kazu5(N):-azukari5(M),N is M+1,retract(azukari5(M)),assert(azukari5(N)).
kazu4(N):-azukari4(M),N is M+1,retract(azukari4(M)),assert(azukari4(N)).
kazu3(N):-azukari3(M),N is M+1,retract(azukari3(M)),assert(azukari3(N)).
motoni4:-retract(azukari3(N)),assert(azukari3(0)),retract(azukari4(M)),
assert(azukari4(0)),retract(azukari5(J)),assert(azukari5(0)).
motoni3:-retract(sed(X)),fail,!.
/*　以上でプログラム本体終わり　*/
/*
      家系分析　自殖作物用（漢字版）　品種名サンプルデータベース 

　　　品種名は全部（数字，記号も）全角入力しないと家系図が
　　　　乱れるが，混在しても計算はする．
　　　
　　　交配両親名はローマ字版が最終祖先まで完備している．     
*/
/*　 -------------------------------------------------
       以下は kin3 用
     -------------------------------------------------   */
namae1('コシヒカリ').
namae1('農林２２号').
namae2('農林６号').
namae2('農林８号').
/*  -----------------------------------
　　　以下交配両親名データ  
　　　rr('品種名','母親名','父親名').
    -----------------------------------   */
rr('コシヒカリ','農林２２号','農林１号').
rr('農林２２号','農林８号','農林６号').
rr('農林８号','愛国','旭').
rr('農林６号','上州','器量好').
rr('農林１号','大場','陸羽１３２号').
rr('陸羽１３２号','愛国','亀の尾').
rr('ナゴユタカ','トドロキワセ','ギンマサリ').
rr('ギンマサリ','京都旭１号','北陸１４号').
rr('北陸１４号','刈羽神種','新イ号').
rr('トドロキワセ','収９２１','ホウネンワセ').
rr('収９２１','ハツミノリ','藤坂５号').
rr('藤坂５号','双葉','善石早生').
rr('善石早生','板戸早生','旧「イ号」').
rr('双葉','真珠２号','高根旭').
rr('真珠２号','田戦捷','愛知早生旭２号').
rr('愛知早生旭２号','旭','愛知早稲１号').
rr('高根旭','早生旭','早生神力').
rr('ハツミノリ','農林２１号','農林１号').
rr('農林２１号','旭','農林１号').
rr('ホウネンワセ','農林２２号','農林１号').
rr('田戦捷','晩６８','中弁１２２号').
rr('晩６８','陸稲戦捷','交晩３３号').
rr('交晩３３号','神力','新関取').
rr('中弁１２２号','中生神力','弁慶１１６号').
rr('愛知早稲１号','器量好','万才').