/*  Inbreeding and Pedigree Tree for outcross crops         */
/*                      file name; kinkou.txt               */
/*                      by T.Yoshida 2002.12.29             */
/*                      Modefied for Windows  2004.10.19    */
/*                      kin3 > out.txt added  2004.11.4     */
/*                                                          */
/*     For practice, try ?-inb.  ?-ko8.  &  ?-kakei(ko8).   */
/*                                                          */
/*     ?- inb.  ; Input a candidate name                    */
/*     ?- kin.  ; Input parents name.                       */
/*                  Value of the offspring is obtained      */
/*     ?- kin2. ; Input candedate names in this file        */
/*     ?- kin3. ; do, diallel cross, outfile is 'out.txt'   */
/*     Accumulate new ancestor value in kiti(name,value)    */
/*     ?- kakei('name')  ; Pedigree tree                    */
/*     ?- kakei3('name') ; do omitting former ones          */
/*     To log ; ?-log('ex.txt'). End by ?-nolog.            */
/*     CTRL-G ; stop crashing                               */
/*     Garbage collection ; s_verbos(X,on),s_reclaim.       */
/*     home; www.d1.dion.ne.jp/~tmhk/yosida.htm             */
/* ------------------------------------ */
/*   Part-1  Coefficient of inbreeding  */
/* ------------------------------------ */
inb:-write('name ?'),read(Z),rr(Z,X,Y),katao(X,Y),fail.
kin:-write('name1 ?'),read(X),write('name2 ?'),read(Y),katao(X,Y),fail.
/*  For kin2   */
kin2:-[X,Y]=['siroyutaka','benikomati'],katao(X,Y),fail.
kin2:-[X,Y]=['satumahikari','beniotome'],katao(X,Y),fail.
/*�@Kin3 computation. To avoid out.txt, put % in log (line 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
      .
/* -------------------------  */
/*         For kin3           */
/* -------------------------  */
namae1('ko1').
namae1('ko2').
namae1('ko3').
namae2('ko2').
namae2('ko4').
/* -------------------------  */
/* Dummy parents to avoid error  */
katao(X,Y):-nl,write(X),nl,write(Y),assert(rr('>>>',X,'dummyx')),
assert(rr('<<<',Y,'dummyy')),[W,Z]=['>>>','<<<'],sta(W,Z).
/* select rr( ) from r( ) to save time  */
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)).
/* Main computation */
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 Inbreeding =  (first 0 not included)'),point(P),nl,
Q is P *2,write(Q),write(' + '),wa(Q),nl.
waa(0).
atai(0).
wa(Q):-tasizan;saigo(Q);write('kesu'),kesu;assert(atai(0)).
tasizan:-atai(S),write(S),write(' '),waa(T),U is S + T,retract(waa(T)),
assert(waa(U)),fail.
saigo(Q):-waa(U),retract(waa(U)),V is Q + U,nl,write(V),assert(kotae(V)),
write('  <- result '),assert(waa(0)).
kesu:-retract(atai(S)),fail;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):-nl,write('*  '),l_disp(L1),nl,member(C,L2),write(C),
hosei(C,Q),write(Q),write(' -inb ** '),l_disp(L2),nl,keisan(Q,A,R),
keisan2(R,S),write(S),write(' <hosei | kero_mototi> '),write(A),write(' x2 ').
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).
nasi(C,0).
hosei(C,Q):-kiti(C,Q),write(' ').
hosei(C,Q):-not(kiti(C,Q)),nasi(C,Q),write(' <nasi> ').
keisan(Q,A,R):-R is Q * A.
keisan2(R,S):-S is R * 2,assert(atai(S)).
/* End of part-1 */
/* -------------------------------------------------- */
/* Part-2  kakei('entry).   Pedigree tree drawing.    */
/*         kakei3('entry'). Do omitting shown one.    */
/*   * is attached in tree if the entry has kiti data */
/* -------------------------------------------------- */
ma('du1').
kakei(A):-d_clear,write('***  Pedigree Tree of '),write(A),write('   ***'),
c_era,nl,nl,sosen(A). 
kakei3(A):-d_clear,write('*** Pedigree Tree of '),write(A),write('   ***'),
c_era,nl,nl,sosen3(A),!.
kakei3(A):-ret. 
ret:-retract(ma(X)),fail,!.
oya(X,Y):-tab(1),haha(X,Y),count(N).
oya(X,Y):-titi(X,Y),coun2(N).
oya(X,Y):-coun3(N),fail.
/*   For longer generations, change 6  */
haha(A,X):-rr(A,X,_),cloc4(K),K<6.
titi(A,X):-rr(A,_,X),cloc4(K),K<6,nl,tab(K*12+1).
ari(X):-kiti(X,_),write('*');not(kiti(X,_)),write(' ').
cloc4(K):-clock(N),cloc2(M),cloc3(J),K is N+M-J.
sosen(A):-oya(A,X),kiru(X,Y),ari(X),write(Y),sosen(X).
sosen3(A):-mae(A),oya(A,X),kiru(X,Y),ari(X),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('*** All ancestors of '),write(A),write(' ***'),
nl,nl,sosen2(A).
oya2(X,Y):-tab(1),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,[46,46,46,46,46,46,46,46,46],Z),
Z=[X1,X2,X3,X4,X5,X6,X7,X8,X9,X10|Rest],
W=[X1,X2,X3,X4,X5,X6,X7,X8,X9,X10],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)).
/*  End of part-2  */
/* --------------------------------------- */
/*    Data-base ;                          */
/*       rr('entry','female p','male p').  */
/*       kiti('entry',calculated value).   */
/* --------------------------------------- */
rr('jibun','haha','titi').
rr('haha','baba','jiji').
rr('imoto','haha','titi').
rr('imoto2','haha2','titi').
kiti('jiji',0.1).
rr('titi','baba2','jiji2').
rr('oba','baba','jiji').
rr('itoko','oba','oji').
rr('ko1','tuma','jibun').
rr('ko2','tuma','jibun').
rr('ko3','tuma2','jibun').
rr('ko4','imoto','jibun').
rr('ko5','haha','jibun').
rr('ko6','oba','jibun').
rr('ko7','baba','jibun').
rr('ko8','itoko','jibun').
rr('ko9','imoto2','jibun').