Uživatelské nástroje

Nástroje pro tento web


pitel:flp:99pl

P-99: Ninety-Nine Prolog Problems

p1_01.pl

p1_01.pl
% 1.01 (*): Find the last element of a list
 
% my_last(X,L) :- X is the last element of the list L
%    (element,list) (?,?)
 
% Note: last(?Elem, ?List) is predefined
 
my_last(X,[X]).
my_last(X,[_|L]) :- my_last(X,L).

p1_02.pl

p1_02.pl
% 1.02 (*): Find the last but one element of a list
 
% last_but_one(X,L) :- X is the last but one element of the list L
%    (element,list) (?,?)
 
last_but_one(X,[X,_]).
last_but_one(X,[_,Y|Ys]) :- last_but_one(X,[Y|Ys]).

p1_03.pl

p1_03.pl
% 1.03 (*): Find the K'th element of a list.
% The first element in the list is number 1.
 
% element_at(X,L,K) :- X is the K'th element of the list L
%    (element,list,integer) (?,?,+)
 
% Note: nth1(?Index, ?List, ?Elem) is predefined
 
element_at(X,[X|_],1).
element_at(X,[_|L],K) :- K > 1, K1 is K - 1, element_at(X,L,K1).

p1_04.pl

p1_04.pl
% 1.04 (*): Find the number of elements of a list.
 
% my_length(L,N) :- the list L contains N elements
%    (list,integer) (+,?) 
 
% Note: length(?List, ?Int) is predefined
 
my_length([],0).
my_length([_|L],N) :- my_length(L,N1), N is N1 + 1.

p1_05.pl

p1_05.pl
% 1.05 (*): Reverse a list.
 
% my_reverse(L1,L2) :- L2 is the list obtained from L1 by reversing 
%    the order of the elements.
%    (list,list) (?,?)
 
% Note: reverse(+List1, -List2) is predefined
 
my_reverse(L1,L2) :- my_rev(L1,L2,[]).
 
my_rev([],L2,L2) :- !.
my_rev([X|Xs],L2,Acc) :- my_rev(Xs,L2,[X|Acc]).

p1_06.pl

p1_06.pl
% 1.06 (*): Find out whether a list is a palindrome
% A palindrome can be read forward or backward; e.g. [x,a,m,a,x]
 
% is_palindrome(L) :- L is a palindrome list
%    (list) (?)
 
is_palindrome(L) :- reverse(L,L).

p1_07.pl

p1_07.pl
% 1.07 (**): Flatten a nested list structure.
 
% my_flatten(L1,L2) :- the list L2 is obtained from the list L1 by
%    flattening; i.e. if an element of L1 is a list then it is replaced
%    by its elements, recursively. 
%    (list,list) (+,?)
 
% Note: flatten(+List1, -List2) is a predefined predicate
 
my_flatten(X,[X]) :- \+ is_list(X).
my_flatten([],[]).
my_flatten([X|Xs],Zs) :- my_flatten(X,Y), my_flatten(Xs,Ys), append(Y,Ys,Zs).

p1_08.pl

p1_08.pl
% 1.08 (**): Eliminate consecutive duplicates of list elements.
 
% compress(L1,L2) :- the list L2 is obtained from the list L1 by
%    compressing repeated occurrences of elements into a single copy
%    of the element.
%    (list,list) (+,?)
 
compress([],[]).
compress([X],[X]).
compress([X,X|Xs],Zs) :- compress([X|Xs],Zs).
compress([X,Y|Ys],[X|Zs]) :- X \= Y, compress([Y|Ys],Zs).

p1_09.pl

p1_09.pl
% 1.09 (**):  Pack consecutive duplicates of list elements into sublists.
 
% pack(L1,L2) :- the list L2 is obtained from the list L1 by packing
%    repeated occurrences of elements into separate sublists.
%    (list,list) (+,?)
 
pack([],[]).
pack([X|Xs],[Z|Zs]) :- transfer(X,Xs,Ys,Z), pack(Ys,Zs).
 
% transfer(X,Xs,Ys,Z) Ys is the list that remains from the list Xs
%    when all leading copies of X are removed and transfered to Z
 
transfer(X,[],[],[X]).
transfer(X,[Y|Ys],[Y|Ys],[X]) :- X \= Y.
transfer(X,[X|Xs],Ys,[X|Zs]) :- transfer(X,Xs,Ys,Zs).

p1_10.pl

p1_10.pl
% 1.10 (*):  Run-length encoding of a list
 
% encode(L1,L2) :- the list L2 is obtained from the list L1 by run-length
%    encoding. Consecutive duplicates of elements are encoded as terms [N,E],
%    where N is the number of duplicates of the element E.
%    (list,list) (+,?)
 
:- ensure_loaded(p1_09).
 
encode(L1,L2) :- pack(L1,L), transform(L,L2).
 
transform([],[]).
transform([[X|Xs]|Ys],[[N,X]|Zs]) :- length([X|Xs],N), transform(Ys,Zs).

p1_11.pl

p1_11.pl
% 1.11 (*):  Modified run-length encoding
 
% encode_modified(L1,L2) :- the list L2 is obtained from the list L1 by 
%    run-length encoding. Consecutive duplicates of elements are encoded 
%    as terms [N,E], where N is the number of duplicates of the element E.
%    However, if N equals 1 then the element is simply copied into the 
%    output list.
%    (list,list) (+,?)
 
:- ensure_loaded(p1_10).
 
encode_modified(L1,L2) :- encode(L1,L), strip(L,L2).
 
strip([],[]).
strip([[1,X]|Ys],[X|Zs]) :- strip(Ys,Zs).
strip([[N,X]|Ys],[[N,X]|Zs]) :- N > 1, strip(Ys,Zs).

p1_12.pl

p1_12.pl
% 1.12 (**): Decode a run-length compressed list.
 
% decode(L1,L2) :- L2 is the uncompressed version of the run-length
%    encoded list L1.
%    (list,list) (+,?)
 
decode([],[]).
decode([X|Ys],[X|Zs]) :- \+ is_list(X), decode(Ys,Zs).
decode([[1,X]|Ys],[X|Zs]) :- decode(Ys,Zs).
decode([[N,X]|Ys],[X|Zs]) :- N > 1, N1 is N - 1, decode([[N1,X]|Ys],Zs).

p1_13.pl

p1_13.pl
% 1.13 (**): Run-length encoding of a list (direct solution) 
 
% encode_direct(L1,L2) :- the list L2 is obtained from the list L1 by 
%    run-length encoding. Consecutive duplicates of elements are encoded 
%    as terms [N,E], where N is the number of duplicates of the element E.
%    However, if N equals 1 then the element is simply copied into the 
%    output list.
%    (list,list) (+,?)
 
encode_direct([],[]).
encode_direct([X|Xs],[Z|Zs]) :- count(X,Xs,Ys,1,Z), encode_direct(Ys,Zs).
 
% count(X,Xs,Ys,K,T) Ys is the list that remains from the list Xs
%    when all leading copies of X are removed. T is the term [N,X],
%    where N is K plus the number of X's that can be removed from Xs.
%    In the case of N=1, T is X, instead of the term [1,X].
 
count(X,[],[],1,X).
count(X,[],[],N,[N,X]) :- N > 1.
count(X,[Y|Ys],[Y|Ys],1,X) :- X \= Y.
count(X,[Y|Ys],[Y|Ys],N,[N,X]) :- N > 1, X \= Y.
count(X,[X|Xs],Ys,K,T) :- K1 is K + 1, count(X,Xs,Ys,K1,T).

p1_14.pl

p1_14.pl
% 1.14 (*): Duplicate the elements of a list
 
% dupli(L1,L2) :- L2 is obtained from L1 by duplicating all elements.
%    (list,list) (?,?)
 
dupli([],[]).
dupli([X|Xs],[X,X|Ys]) :- dupli(Xs,Ys).

p1_15.pl

p1_15.pl
% 1.15 (**): Duplicate the elements of a list agiven number of times
 
% dupli(L1,N,L2) :- L2 is obtained from L1 by duplicating all elements
%    N times.
%    (list,integer,list) (?,+,?)
 
dupli(L1,N,L2) :- dupli(L1,N,L2,N).
 
% dupli(L1,N,L2,K) :- L2 is obtained from L1 by duplicating its leading
%    element K times, all other elements N times.
%    (list,integer,list,integer) (?,+,?,+)
 
dupli([],_,[],_).
dupli([_|Xs],N,Ys,0) :- dupli(Xs,N,Ys,N).
dupli([X|Xs],N,[X|Ys],K) :- K > 0, K1 is K - 1, dupli([X|Xs],N,Ys,K1).

p1_16.pl

p1_16.pl
% 1.16 (**):  Drop every N'th element from a list
 
% drop(L1,N,L2) :- L2 is obtained from L1 by dropping every N'th element.
%    (list,integer,list) (?,+,?)
 
drop(L1,N,L2) :- drop(L1,N,L2,N).
 
% drop(L1,N,L2,K) :- L2 is obtained from L1 by first copying K-1 elements
%    and then dropping an element and, from then on, dropping every
%    N'th element.
%    (list,integer,list,integer) (?,+,?,+)
 
drop([],_,[],_).
drop([_|Xs],N,Ys,1) :- drop(Xs,N,Ys,N).
drop([X|Xs],N,[X|Ys],K) :- K > 1, K1 is K - 1, drop(Xs,N,Ys,K1).

p1_17.pl

p1_17.pl
% 1.17 (*): Split a list into two parts
 
% split(L,N,L1,L2) :- the list L1 contains the first N elements
%    of the list L, the list L2 contains the remaining elements.
%    (list,integer,list,list) (?,+,?,?)
 
split(L,0,[],L).
split([X|Xs],N,[X|Ys],Zs) :- N > 0, N1 is N - 1, split(Xs,N1,Ys,Zs).

p1_18.pl

p1_18.pl
% 1.18 (**):  Extract a slice from a list
 
% slice(L1,I,K,L2) :- L2 is the list of the elements of L1 between
%    index I and index K (both included).
%    (list,integer,integer,list) (?,+,+,?)
 
slice([X|_],1,1,[X]).
slice([X|Xs],1,K,[X|Ys]) :- K > 1, 
   K1 is K - 1, slice(Xs,1,K1,Ys).
slice([_|Xs],I,K,Ys) :- I > 1, 
   I1 is I - 1, K1 is K - 1, slice(Xs,I1,K1,Ys).

p1_19.pl

p1_19.pl
% 1.19 (**): Rotate a list N places to the left 
 
% rotate(L1,N,L2) :- the list L2 is obtained from the list L1 by 
%    rotating the elements of L1 N places to the left.
%    Examples: 
%    rotate([a,b,c,d,e,f,g,h],3,[d,e,f,g,h,a,b,c])
%    rotate([a,b,c,d,e,f,g,h],-2,[g,h,a,b,c,d,e,f])
%    (list,integer,list) (+,+,?)
 
:- ensure_loaded(p1_17).
 
rotate(L1,N,L2) :- N >= 0, 
   length(L1,NL1), N1 is N mod NL1, rotate_left(L1,N1,L2).
rotate(L1,N,L2) :- N < 0,
   length(L1,NL1), N1 is NL1 + (N mod NL1), rotate_left(L1,N1,L2).
 
rotate_left(L,0,L).
rotate_left(L1,N,L2) :- N > 0, split(L1,N,S1,S2), append(S2,S1,L2).

p1_20.pl

p1_20.pl
% 1.20 (*): Remove the K'th element from a list.
% The first element in the list is number 1.
 
% remove_at(X,L,K,R) :- X is the K'th element of the list L; R is the
%    list that remains when the K'th element is removed from L.
%    (element,list,integer,list) (?,?,+,?)
 
remove_at(X,[X|Xs],1,Xs).
remove_at(X,[Y|Xs],K,[Y|Ys]) :- K > 1, 
   K1 is K - 1, remove_at(X,Xs,K1,Ys).

p1_21.pl

p1_21.pl
% P21 (*): Insert an element at a given position into a list
% The first element in the list is number 1.
 
% insert_at(X,L,K,R) :- X is inserted into the list L such that it
%    occupies position K. The result is the list R.
%    (element,list,integer,list) (?,?,+,?)
 
:- ensure_loaded(p20).
 
insert_at(X,L,K,R) :- remove_at(X,R,K,L).

p1_22.pl

p1_22.pl
% 1.22 (*):  Create a list containing all integers within a given range.
 
% range(I,K,L) :- I <= K, and L is the list containing all 
%    consecutive integers from I to K.
%    (integer,integer,list) (+,+,?)
 
range(I,I,[I]).
range(I,K,[I|L]) :- I < K, I1 is I + 1, range(I1,K,L).

p1_23.pl

p1_23.pl
% 1.23 (**): Extract a given number of randomly selected elements 
%    from a list.
 
% rnd_select(L,N,R) :- the list R contains N randomly selected 
%    items taken from the list L.
%    (list,integer,list) (+,+,-)
 
:- ensure_loaded(p1_20).
 
rnd_select(_,0,[]).
rnd_select(Xs,N,[X|Zs]) :- N > 0,
    length(Xs,L),
    I is random(L) + 1,
    remove_at(X,Xs,I,Ys),
    N1 is N - 1,
    rnd_select(Ys,N1,Zs).

p1_24.pl

p1_24.pl
% 1.24 (*): Lotto: Draw N different random numbers from the set 1..M
 
% lotto(N,M,L) :- the list L contains N randomly selected distinct
%    integer numbers from the interval 1..M
%    (integer,integer,number-list) (+,+,-)
 
:- ensure_loaded(p1_22).
:- ensure_loaded(p1_23).
 
lotto(N,M,L) :- range(1,M,R), rnd_select(R,N,L).

p1_25.pl

p1_25.pl
% 1.25 (*):  Generate a random permutation of the elements of a list
 
% rnd_permu(L1,L2) :- the list L2 is a random permutation of the
%    elements of the list L1.
%    (list,list) (+,-)
 
:- ensure_loaded(p1_23).
 
rnd_permu(L1,L2) :- length(L1,N), rnd_select(L1,N,L2).

p1_26.pl

p1_26.pl
% 1.26 (**):  Generate the combinations of k distinct objects
%            chosen from the n elements of a list.
 
% combination(K,L,C) :- C is a list of K distinct elements 
%    chosen from the list L
 
combination(0,_,[]).
combination(K,L,[X|Xs]) :- K > 0,
   el(X,L,R), K1 is K-1, combination(K1,R,Xs).
 
% Find out what the following predicate el/3 exactly does.
 
el(X,[X|L],L).
el(X,[_|L],R) :- el(X,L,R).

p1_27.pl

p1_27.pl
% 1.27 (**) Group the elements of a set into disjoint subsets.
 
% Problem a)
 
% group3(G,G1,G2,G3) :- distribute the 9 elements of G into G1, G2, and G3,
%    such that G1, G2 and G3 contain 2,3 and 4 elements respectively
 
group3(G,G1,G2,G3) :- 
   selectN(2,G,G1),
   subtract(G,G1,R1),
   selectN(3,R1,G2),
   subtract(R1,G2,R2),
   selectN(4,R2,G3),
   subtract(R2,G3,[]).
 
% selectN(N,L,S) :- select N elements of the list L and put them in 
%    the set S. Via backtracking return all posssible selections, but
%    avoid permutations; i.e. after generating S = [a,b,c] do not return
%    S = [b,a,c], etc.
 
selectN(0,_,[]) :- !.
selectN(N,L,[X|S]) :- N > 0, 
   el(X,L,R), 
   N1 is N-1,
   selectN(N1,R,S).
 
el(X,[X|L],L).
el(X,[_|L],R) :- el(X,L,R).
 
% subtract/3 is predefined
 
% Problem b): Generalization
 
% group(G,Ns,Gs) :- distribute the elements of G into the groups Gs.
%    The group sizes are given in the list Ns.
 
group([],[],[]).
group(G,[N1|Ns],[G1|Gs]) :- 
   selectN(N1,G,G1),
   subtract(G,G1,R),
   group(R,Ns,Gs).

p1_28.pl

p1_28.pl
% 1.28 (**) Sorting a list of lists according to length
%
% a) length sort
%
% lsort(InList,OutList) :- it is supposed that the elements of InList 
% are lists themselves. Then OutList is obtained from InList by sorting 
% its elements according to their length. lsort/2 sorts ascendingly,
% lsort/3 allows for ascending or descending sorts.
% (list_of_lists,list_of_lists), (+,?)
 
lsort(InList,OutList) :- lsort(InList,OutList,asc).
 
% sorting direction Dir is either asc or desc
 
lsort(InList,OutList,Dir) :-
   add_key(InList,KList,Dir),
   keysort(KList,SKList),
   rem_key(SKList,OutList).
 
add_key([],[],_).
add_key([X|Xs],[L-p(X)|Ys],asc) :- !, 
	length(X,L), add_key(Xs,Ys,asc).
add_key([X|Xs],[L-p(X)|Ys],desc) :- 
	length(X,L1), L is -L1, add_key(Xs,Ys,desc).
 
rem_key([],[]).
rem_key([_-p(X)|Xs],[X|Ys]) :- rem_key(Xs,Ys).
 
% b) length frequency sort
%
% lfsort (InList,OutList) :- it is supposed that the elements of InList
% are lists themselves. Then OutList is obtained from InList by sorting
% its elements according to their length frequency; i.e. in the default,
% where sorting is done ascendingly, lists with rare lengths are placed
% first, other with more frequent lengths come later.
%
% Example:
% ?- lfsort([[a,b,c],[d,e],[f,g,h],[d,e],[i,j,k,l],[m,n],[o]],L).
% L = [[i, j, k, l], [o], [a, b, c], [f, g, h], [d, e], [d, e], [m, n]]
%
% Note that the first two lists in the Result have length 4 and 1, both
% length appear just once. The third and forth list have length 3 which
% appears, there are two list of this length. And finally, the last
% three lists have length 2. This is the most frequent length.
 
lfsort(InList,OutList) :- lfsort(InList,OutList,asc).
 
% sorting direction Dir is either asc or desc
 
lfsort(InList,OutList,Dir) :-
	add_key(InList,KList,desc),
   keysort(KList,SKList),
   pack(SKList,PKList),
   lsort(PKList,SPKList,Dir),
   flatten(SPKList,FKList),
   rem_key(FKList,OutList).
 
pack([],[]).
pack([L-X|Xs],[[L-X|Z]|Zs]) :- transf(L-X,Xs,Ys,Z), pack(Ys,Zs).
 
% transf(L-X,Xs,Ys,Z) Ys is the list that remains from the list Xs
%    when all leading copies of length L are removed and transfed to Z
 
transf(_,[],[],[]).
transf(L-_,[K-Y|Ys],[K-Y|Ys],[]) :- L \= K.
transf(L-_,[L-X|Xs],Ys,[L-X|Zs]) :- transf(L-X,Xs,Ys,Zs).
 
test :-
   L = [[a,b,c],[d,e],[f,g,h],[d,e],[i,j,k,l],[m,n],[o]],
   write('L = '), write(L), nl,
   lsort(L,LS),
   write('LS = '), write(LS), nl,
   lsort(L,LSD,desc),
   write('LSD = '), write(LSD), nl,
   lfsort(L,LFS),
   write('LFS = '), write(LFS), nl.

p2_01.pl

p2_01.pl
% 2.01 (**) Determine whether a given integer number is prime. 
 
% is_prime(P) :- P is a prime number
%    (integer) (+)
 
is_prime(2).
is_prime(3).
is_prime(P) :- integer(P), P > 3, P mod 2 =\= 0, \+ has_factor(P,3).  
 
% has_factor(N,L) :- N has an odd factor F >= L.
%    (integer, integer) (+,+)
 
has_factor(N,L) :- N mod L =:= 0.
has_factor(N,L) :- L * L < N, L2 is L + 2, has_factor(N,L2).

p2_02.pl

p2_02.pl
% 2.02 (**) Determine the prime factors of a given positive integer. 
 
% prime_factors(N, L) :- N is the list of prime factors of N.
%    (integer,list) (+,?)
 
prime_factors(N,L) :- N > 0,  prime_factors(N,L,2).
 
% prime_factors(N,L,K) :- L is the list of prime factors of N. It is 
% known that N does not have any prime factors less than K.
 
prime_factors(1,[],_) :- !.
prime_factors(N,[F|L],F) :-                           % N is multiple of F
   R is N // F, N =:= R * F, !, prime_factors(R,L,F).
prime_factors(N,L,F) :- 
   next_factor(N,F,NF), prime_factors(N,L,NF).        % N is not multiple of F
 
 
% next_factor(N,F,NF) :- when calculating the prime factors of N
%    and if F does not divide N then NF is the next larger candidate to
%    be a factor of N.
 
next_factor(_,2,3) :- !.
next_factor(N,F,NF) :- F * F < N, !, NF is F + 2.
next_factor(N,_,N).                                 % F > sqrt(N)

p2_03.pl

p2_03.pl
% 2.03 (**) Determine the prime factors of a given positive integer (2). 
% Construct a list containing the prime factors and their multiplicity.
% Example: 
% ?- prime_factors_mult(315, L).
% L = [[3,2],[5,1],[7,1]]
 
:- ensure_loaded(p2_02).  % make sure next_factor/3 is loaded
 
% prime_factors_mult(N, L) :- L is the list of prime factors of N. It is
%    composed of terms [F,M] where F is a prime factor and M its multiplicity.
%    (integer,list) (+,?)
 
prime_factors_mult(N,L) :- N > 0, prime_factors_mult(N,L,2).
 
% prime_factors_mult(N,L,K) :- L is the list of prime factors of N. It is 
% known that N does not have any prime factors less than K.
 
prime_factors_mult(1,[],_) :- !.
prime_factors_mult(N,[[F,M]|L],F) :- divide(N,F,M,R), !, % F divides N
   next_factor(R,F,NF), prime_factors_mult(R,L,NF).
prime_factors_mult(N,L,F) :- !,                          % F does not divide N
   next_factor(N,F,NF), prime_factors_mult(N,L,NF).
 
% divide(N,F,M,R) :- N = R * F**M, M >= 1, and F is not a factor of R. 
%    (integer,integer,integer,integer) (+,+,-,-)
 
divide(N,F,M,R) :- divi(N,F,M,R,0), M > 0.
 
divi(N,F,M,R,K) :- S is N // F, N =:= S * F, !,          % F divides N
   K1 is K + 1, divi(S,F,M,R,K1).
divi(N,_,M,N,M).

p2_04.pl

p2_04.pl
% 2.04 (*) A list of prime numbers. 
% Given a range of integers by its lower and upper limit, construct a 
% list of all prime numbers in that range.
 
:- ensure_loaded(p2_01).   % make sure is_prime/1 is loaded
 
% prime_list(A,B,L) :- L is the list of prime number P with A <= P <= B
 
prime_list(A,B,L) :- A =< 2, !, p_list(2,B,L).
prime_list(A,B,L) :- A1 is (A // 2) * 2 + 1, p_list(A1,B,L).
 
p_list(A,B,[]) :- A > B, !.
p_list(A,B,[A|L]) :- is_prime(A), !, 
   next(A,A1), p_list(A1,B,L). 
p_list(A,B,L) :- 
   next(A,A1), p_list(A1,B,L).
 
next(2,3) :- !.
next(A,A1) :- A1 is A + 2.

p2_05.pl

p2_05.pl
% 2.05 (**) Goldbach's conjecture. 
% Goldbach's conjecture says that every positive even number greater 
% than 2 is the sum of two prime numbers. Example: 28 = 5 + 23.
 
:- ensure_loaded(p2_01).
 
% goldbach(N,L) :- L is the list of the two prime numbers that
%    sum up to the given N (which must be even).
%    (integer,integer) (+,-)
 
goldbach(4,[2,2]) :- !.
goldbach(N,L) :- N mod 2 =:= 0, N > 4, goldbach(N,L,3).
 
goldbach(N,[P,Q],P) :- Q is N - P, is_prime(Q), !.
goldbach(N,L,P) :- P < N, next_prime(P,P1), goldbach(N,L,P1).
 
next_prime(P,P1) :- P1 is P + 2, is_prime(P1), !.
next_prime(P,P1) :- P2 is P + 2, next_prime(P2,P1).

p2_06.pl

p2_06.pl
% 2.06 (*) A list of Goldbach compositions. 
% Given a range of integers by its lower and upper limit, 
% print a list of all even numbers and their Goldbach composition.
 
:- ensure_loaded(p2_05).
 
% goldbach_list(A,B) :- print a list of the Goldbach composition
%    of all even numbers N in the range A <= N <= B
%    (integer,integer) (+,+)
 
goldbach_list(A,B) :- goldbach_list(A,B,2).
 
% goldbach_list(A,B,L) :- perform goldbach_list(A,B), but suppress
% all output when the first prime number is less than the limit L.
 
goldbach_list(A,B,L) :- A =< 4, !, g_list(4,B,L).
goldbach_list(A,B,L) :- A1 is ((A+1) // 2) * 2, g_list(A1,B,L).
 
g_list(A,B,_) :- A > B, !.
g_list(A,B,L) :- 
   goldbach(A,[P,Q]),
   print_goldbach(A,P,Q,L),
   A2 is A + 2,
   g_list(A2,B,L).
 
print_goldbach(A,P,Q,L) :- P >= L, !,
   writef('%t = %t + %t',[A,P,Q]), nl.
print_goldbach(_,_,_,_).

p2_07.pl

p2_07.pl
% 2.07 (**) Determine the greatest common divisor of two positive integers.
 
% gcd(X,Y,G) :- G is the greatest common divisor of X and Y
%    (integer, integer, integer) (+,+,?)
 
 
gcd(X,0,X) :- X > 0.
gcd(X,Y,G) :- Y > 0, Z is X mod Y, gcd(Y,Z,G).
 
 
% Declare gcd as an arithmetic function; so you can use it
% like this:  ?- G is gcd(36,63).
 
:- arithmetic_function(gcd/2).

p2_08.pl

p2_08.pl
% 2.08 (*) Determine whether two positive integer numbers are coprime. 
%     Two numbers are coprime if their greatest common divisor equals 1.
 
% coprime(X,Y) :- X and Y are coprime.
%    (integer, integer) (+,+)
 
:- ensure_loaded(p2_07).
 
coprime(X,Y) :- gcd(X,Y,1).

p2_09.pl

p2_09.pl
% 2.09 (**) Calculate Euler's totient function phi(m). 
%    Euler's so-called totient function phi(m) is defined as the number 
%    of positive integers r (1 <= r < m) that are coprime to m. 
%    Example: m = 10: r = 1,3,7,9; thus phi(m) = 4. Note: phi(1) = 1.
 
% totient_phi(M,Phi) :- Phi is the value of the Euler's totient function
%    phi for the argument M.
%    (integer, integer) (+,-)
 
:- ensure_loaded(p2_08).
:- arithmetic_function(totient_phi/1).
 
totient_phi(1,1) :- !.
totient_phi(M,Phi) :- t_phi(M,Phi,1,0).
 
% t_phi(M,Phi,K,C) :- Phi = C + N, where N is the number of integers R
%    such that K <= R < M and R is coprime to M.
%    (integer,integer,integer,integer) (+,-,+,+)
 
t_phi(M,Phi,M,Phi) :- !.
t_phi(M,Phi,K,C) :- 
   K < M, coprime(K,M), !, 
   C1 is C + 1, K1 is K + 1,
   t_phi(M,Phi,K1,C1).
t_phi(M,Phi,K,C) :- 
   K < M, K1 is K + 1,
   t_phi(M,Phi,K1,C).

p2_10.pl

p2_10.pl
% 2.10 (**) Calculate Euler's totient function phi(m) (2). 
% See problem 2.09 for the definition of Euler's totient function. 
% If the list of the prime factors of a number m is known in the 
% form of problem P36 then the function phi(m) can be efficiently
% calculated as follows: 
%
% Let [[p1,m1],[p2,m2],[p3,m3],...] be the list of prime factors (and their
% multiplicities) of a given number m. Then phi(m) can be calculated 
% with the following formula:
%
% phi(m) = (p1 - 1) * p1 ** (m1 - 1) * (p2 - 1) * p2 ** (m2 - 1) * 
%          (p3 - 1) * p3 ** (m3 - 1) * ...
%
% Note that a ** b stands for the b'th power of a.
 
:- ensure_loaded(p2_03).  % make sure prime_factors_mult is loaded
 
% totient_phi_2(N,Phi) :- Phi is the value of Euler's totient function
%    for the argument N.
%    (integer,integer) (+,?)
 
totient_phi_2(N,Phi) :- prime_factors_mult(N,L), to_phi(L,Phi).
 
to_phi([],1).
to_phi([[F,1]|L],Phi) :- !,
   to_phi(L,Phi1), Phi is Phi1 * (F - 1).
to_phi([[F,M]|L],Phi) :- M > 1,
   M1 is M - 1, to_phi([[F,M1]|L],Phi1), Phi is Phi1 * F.

p2_11.pl

p2_11.pl
% 2.11 (*) Compare the two methods of calculating Euler's totient function. 
% Use the solutions of problems 2.09 and 2.10 to compare the algorithms. 
% Take the number of logical inferences as a measure for efficiency.
 
:- ensure_loaded(p2_09).
:- ensure_loaded(p2_10).
 
totient_test(N) :-
   write('totient_phi (P34):'),
   time(totient_phi(N,Phi1)),
   write('result = '), write(Phi1), nl,
   write('totient_phi_2 (P37):'),
   time(totient_phi_2(N,Phi2)),
   write('result = '), write(Phi2), nl.

p3_01.pl

p3_01.pl
% 3.01 (**) Truth tables for logical expressions.
% Define predicates and/2, or/2, nand/2, nor/2, xor/2, impl/2 
% and equ/2 (for logical equivalence) which succeed or
% fail according to the result of their respective operations; e.g.
% and(A,B) will succeed, if and only if both A and B succeed.
% Note that A and B can be Prolog goals (not only the constants
% true and fail).
% A logical expression in two variables can then be written in 
% prefix notation, as in the following example: and(or(A,B),nand(A,B)).
%
% Now, write a predicate table/3 which prints the truth table of a
% given logical expression in two variables.
%
% Example:
% ?- table(A,B,and(A,or(A,B))).
% true  true  true
% true  fail  true
% fail  true  fail
% fail  fail  fail
 
and(A,B) :- A, B.
 
or(A,_) :- A.
or(_,B) :- B.
 
equ(A,B) :- or(and(A,B), and(not(A),not(B))).
 
xor(A,B) :- not(equ(A,B)).
 
nor(A,B) :- not(or(A,B)).
 
nand(A,B) :- not(and(A,B)).
 
impl(A,B) :- or(not(A),B).
 
% bind(X) :- instantiate X to be true and false successively
 
bind(true).
bind(fail).
 
table(A,B,Expr) :- bind(A), bind(B), do(A,B,Expr), fail.
 
do(A,B,_) :- write(A), write('  '), write(B), write('  '), fail.
do(_,_,Expr) :- Expr, !, write(true), nl.
do(_,_,_) :- write(fail), nl.

p3_02.pl

p3_02.pl
% 3.02 (*) Truth tables for logical expressions (2).
% Continue problem 3.01 by defining and/2, or/2, etc as being
% operators. This allows to write the logical expression in the
% more natural way, as in the example: A and (A or not B).
% Define operator precedence as usual; i.e. as in Java.
%
% Example:
% ?- table(A,B, A and (A or not B)).
% true  true  true
% true  fail  true
% fail  true  fail
% fail  fail  fail
 
:- ensure_loaded(p3_01).
 
:- op(900, fy,not).
:- op(910, yfx, and).
:- op(910, yfx, nand).
:- op(920, yfx, or).
:- op(920, yfx, nor).
:- op(930, yfx, impl).
:- op(930, yfx, equ).
:- op(930, yfx, xor).
 
% I.e. not binds stronger than (and, nand), which bind stronger than
% (or,nor) which in turn bind stronger than implication, equivalence
% and xor.

p3_03.pl

p3_03.pl
% 3.03 (**) Truth tables for logical expressions (3).
% Generalize problem P47 in such a way that the logical
% expression may contain any number of logical variables.
%
% Example:
% ?- table([A,B,C], A and (B or C) equ A and B or A and C).
% true  true  true  true
% true  true  fail  true
% true  fail  true  true
% true  fail  fail  true
% fail  true  true  true
% fail  true  fail  true
% fail  fail  true  true
% fail  fail  fail  true
 
:- ensure_loaded(p3_02).    
 
% table(List,Expr) :- print the truth table for the expression Expr,
%   which contains the logical variables enumerated in List.
 
table(VarList,Expr) :- bindList(VarList), do(VarList,Expr), fail.
 
bindList([]).
bindList([V|Vs]) :- bind(V), bindList(Vs).
 
do(VarList,Expr) :- writeVarList(VarList), writeExpr(Expr), nl.
 
writeVarList([]).
writeVarList([V|Vs]) :- write(V), write('  '), writeVarList(Vs).
 
writeExpr(Expr) :- Expr, !, write(true).
writeExpr(_) :- write(fail).

p3_04.pl

p3_04.pl
% (**) 3.04 Gray codes
 
% gray(N,C) :- C is the N-bit Gray code
 
gray(1,['0','1']).
gray(N,C) :- N > 1, N1 is N-1,
   gray(N1,C1), reverse(C1,C2),
   prepend('0',C1,C1P),
   prepend('1',C2,C2P),
   append(C1P,C2P,C).
 
prepend(_,[],[]) :- !.
prepend(X,[C|Cs],[CP|CPs]) :- atom_concat(X,C,CP), prepend(X,Cs,CPs).
 
 
% This gives a nice example for the result caching technique:
 
:- dynamic gray_c/2.
 
gray_c(1,['0','1']) :- !.
gray_c(N,C) :- N > 1, N1 is N-1, 
   gray_c(N1,C1), reverse(C1,C2),
   prepend('0',C1,C1P),
   prepend('1',C2,C2P),
   append(C1P,C2P,C),
   asserta((gray_c(N,C) :- !)).
 
% Try the following goal sequence and see what happens:
 
% ?- [p3_04]. 
% ?- listing(gray_c/2).
% ?- gray_c(5,C).
% ?- listing(gray_c/2).
 
 
% There is an alternative definition for the gray code construction:
 
gray_alt(1,['0','1']).
gray_alt(N,C) :- N > 1, N1 is N-1,
   gray_alt(N1,C1), 
   postpend(['0','1'],C1,C).   
 
postpend(_,[],[]).
postpend(P,[C|Cs],[C1P,C2P|CsP]) :- P = [P1,P2],
   atom_concat(C,P1,C1P), 
   atom_concat(C,P2,C2P),
   reverse(P,PR),
   postpend(PR,Cs,CsP).

p3_05.pl

p3_05.pl
% (***) 3.05 Huffman code
 
% We suppose a set of symbols with their frequencies, given as a list 
% of fr(S,F) terms. 
% Example: [fr(a,45),fr(b,13),fr(c,12),fr(d,16),fr(e,9),fr(f,5)]. 
% Our objective is to construct a list hc(S,C) terms, where C is the Huffman
% code word for the symbol S. In our example the result could be 
% [hc(a, '0'), hc(b, '101'), hc(c, '100'), hc(d, '111'), hc(e, '1101'), 
% hc(f, '1100')]  
 
% The task shall be performed by the predicate huffman/2 defined as follows: 
 
% huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs
% (list-of-fr/2-terms, list-of-hc/2-terms)  (+,-).
 
% During the construction process, we need nodes n(F,S) where, at the 
% beginning, F is a frequency and S a symbol. During the process, as n(F,S)
% becomes an internal node, S becomes a term s(L,R) with L and R being 
% again n(F,S) terms. A list of n(F,S) terms, called Ns, is maintained 
% as a sort of priority queue.
 
huffman(Fs,Cs) :-
   initialize(Fs,Ns),
   make_tree(Ns,T),
   traverse_tree(T,Cs).
 
initialize(Fs,Ns) :- init(Fs,NsU), sort(NsU,Ns).
 
init([],[]).
init([fr(S,F)|Fs],[n(F,S)|Ns]) :- init(Fs,Ns).
 
make_tree([T],T).
make_tree([n(F1,X1),n(F2,X2)|Ns],T) :- 
   F is F1+F2,
   insert(n(F,s(n(F1,X1),n(F2,X2))),Ns,NsR),
   make_tree(NsR,T).
 
% insert(n(F,X),Ns,NsR) :- insert the node n(F,X) into Ns such that the
%    resulting list NsR is again sorted with respect to the frequency F.
 
insert(N,[],[N]) :- !.
insert(n(F,X),[n(F0,Y)|Ns],[n(F,X),n(F0,Y)|Ns]) :- F < F0, !.
insert(n(F,X),[n(F0,Y)|Ns],[n(F0,Y)|Ns1]) :- F >= F0, insert(n(F,X),Ns,Ns1).
 
% traverse_tree(T,Cs) :- traverse the tree T and construct the Huffman 
%    code table Cs,
 
traverse_tree(T,Cs) :- traverse_tree(T,'',Cs1-[]), sort(Cs1,Cs).
 
traverse_tree(n(_,A),Code,[hc(A,Code)|Cs]-Cs) :- atom(A). % leaf node
traverse_tree(n(_,s(Left,Right)),Code,Cs1-Cs3) :-         % internal node
   atom_concat(Code,'0',CodeLeft), 
   atom_concat(Code,'1',CodeRight),
   traverse_tree(Left,CodeLeft,Cs1-Cs2),
   traverse_tree(Right,CodeRight,Cs2-Cs3).
 
 
% The following predicate gives some statistical information.
 
huffman(Fs) :- huffman(Fs,Hs) , nl, report(Hs,5), stats(Fs,Hs).
 
report([],_) :- !, nl, nl.
report(Hs,0) :- !, nl, report(Hs,5).
report([hc(S,C)|Hs],N) :- N > 0, N1 is N-1, 
   writef('%w %8l  ',[S,C]), report(Hs,N1).
 
stats(Fs,Cs) :- sort(Fs,FsS), sort(Cs,CsS), stats(FsS,CsS,0,0).
 
stats([],[],FreqCodeSum,FreqSum) :- Avg is FreqCodeSum/FreqSum,
   writef('Average code length (weighted) = %w\n',[Avg]). 
stats([fr(S,F)|Fs],[hc(S,C)|Hs],FCS,FS) :- 
   atom_chars(C,CharList), length(CharList,N),
   FCS1 is FCS + F*N, FS1 is FS + F,
   stats(Fs,Hs,FCS1,FS1). 
 

p4_01.pl

p4_01.pl
% 4.01 Write a predicate istree/1 which succeeds if and only if its argument
%      is a Prolog term representing a binary tree.
%
% istree(T) :- T is a term representing a binary tree (i), (o)
 
istree(nil).
istree(t(_,L,R)) :- istree(L), istree(R).
 
 
% Test cases (can be used for other binary tree problems as well)
 
tree(1,t(a,t(b,t(d,nil,nil),t(e,nil,nil)),t(c,nil,t(f,t(g,nil,nil),nil)))).
tree(2,t(a,nil,nil)).
tree(3,nil).

p4_02.pl

p4_02.pl
% 4.02 (**) Construct completely balanced binary trees for a given 
% number of nodes.
 
% cbal_tree(N,T) :- T is a completely balanced binary tree with N nodes.
% (integer, tree)  (+,?)
 
cbal_tree(0,nil) :- !.
cbal_tree(N,t(x,L,R)) :- N > 0,
	N0 is N - 1, 
	N1 is N0//2, N2 is N0 - N1,
	distrib(N1,N2,NL,NR),
	cbal_tree(NL,L), cbal_tree(NR,R).
 
distrib(N,N,N,N) :- !.
distrib(N1,N2,N1,N2).
distrib(N1,N2,N2,N1).

p4_03.pl

p4_03.pl
% 4.03 (**) Symmetric binary trees 
% Let us call a binary tree symmetric if you can draw a vertical 
% line through the root node and then the right subtree is the mirror
% image of the left subtree.
% Write a predicate symmetric/1 to check whether a given binary
% tree is symmetric. Hint: Write a predicate mirror/2 first to check
% whether one tree is the mirror image of another.
 
% symmetric(T) :- the binary tree T is symmetric.
 
symmetric(nil).
symmetric(t(_,L,R)) :- mirror(L,R).
 
mirror(nil,nil).
mirror(t(_,L1,R1),t(_,L2,R2)) :- mirror(L1,R2), mirror(R1,L2).

p4_04.pl

p4_04.pl
% 4.04 (**) Binary search trees (dictionaries)
 
% Use the predicate add/3, developed in chapter 4 of the course,
% to write a predicate to construct a binary search tree 
% from a list of integer numbers. Then use this predicate to test 
% the solution of the problem P56
 
:- ensure_loaded(p4_03).
 
% add(X,T1,T2) :- the binary dictionary T2 is obtained by 
% adding the item X to the binary dictionary T1
% (element,binary-dictionary,binary-dictionary) (i,i,o)
 
add(X,nil,t(X,nil,nil)).
add(X,t(Root,L,R),t(Root,L1,R)) :- X @< Root, add(X,L,L1).
add(X,t(Root,L,R),t(Root,L,R1)) :- X @> Root, add(X,R,R1).
 
construct(L,T) :- construct(L,T,nil).
 
construct([],T,T).
construct([N|Ns],T,T0) :- add(N,T0,T1), construct(Ns,T,T1).
 
test_symmetric(L) :- construct(L,T), symmetric(T).

p4_05.pl

p4_05.pl
% 4.05 (**) Generate-and-test paradigm
 
% Apply the generate-and-test paradigm to construct all symmetric,
% completely balanced binary trees with a given number of nodes.
 
:- ensure_loaded(p4_02).
:- ensure_loaded(p4_03).
 
 
sym_cbal_tree(N,T) :- cbal_tree(N,T), symmetric(T).
 
sym_cbal_trees(N,Ts) :- setof(T,sym_cbal_tree(N,T),Ts).
 
investigate(A,B) :-
	between(A,B,N),
	sym_cbal_trees(N,Ts), length(Ts,L),
	writef('%w   %w',[N,L]), nl,
    fail.
investigate(_,_).

p4_06.pl

p4_06.pl
% 4.06 (**) Construct height-balanced binary trees
% In a height-balanced binary tree, the following property holds for
% every node: The height of its left subtree and the height of  
% its right subtree are almost equal, which means their
% difference is not greater than one.
% Write a predicate hbal_tree/2 to construct height-balanced
% binary trees for a given height. The predicate should
% generate all solutions via backtracking. Put the letter 'x'
% as information into all nodes of the tree.
 
% hbal_tree(D,T) :- T is a height-balanced binary tree with depth T
 
hbal_tree(0,nil) :- !.
hbal_tree(1,t(x,nil,nil)) :- !.
hbal_tree(D,t(x,L,R)) :- D > 1,
	D1 is D - 1, D2 is D - 2,
	distr(D1,D2,DL,DR),
	hbal_tree(DL,L), hbal_tree(DR,R).
 
distr(D1,_,D1,D1).
distr(D1,D2,D1,D2).
distr(D1,D2,D2,D1).

p4_07.pl

p4_07.pl
% 4.07 (**) Construct height-balanced binary trees with a given number of nodes
 
:- ensure_loaded(p4_06).
 
% minNodes(H,N) :- N is the minimum number of nodes in a height-balanced 
% binary tree of height H
% (integer,integer) (+,?)
 
minNodes(0,0) :- !.
minNodes(1,1) :- !.
minNodes(H,N) :- H > 1, 
	H1 is H - 1, H2 is H - 2,
	minNodes(H1,N1), minNodes(H2,N2),
	N is 1 + N1 + N2.
 
% maxNodes(H,N) :- N is the maximum number of nodes in a height-balanced 
% binary tree of height H
% (integer,integer) (+,?)
 
maxNodes(H,N) :- N is 2**H - 1.
 
% minHeight(N,H) :- H is the minimum height of a height-balanced 
% binary tree with N nodes
% (integer,integer) (+,?)
 
minHeight(0,0) :- !.
minHeight(N,H) :- N > 0, N1 is N//2, minHeight(N1,H1), H is H1 + 1.
 
% maxHeight(N,H) :- H is the maximum height of a height-balanced 
% binary tree with N nodes
% (integer,integer) (+,?)
 
maxHeight(N,H) :- maxHeight(N,H,1,1).
 
maxHeight(N,H,H1,N1) :- N1 > N, !, H is H1 - 1.
maxHeight(N,H,H1,N1) :- N1 =< N, 
	H2 is H1 + 1, minNodes(H2,N2), maxHeight(N,H,H2,N2).
 
% hbal_tree_nodes(N,T) :- T is a height-balanced binary tree with N nodes.
 
hbal_tree_nodes(N,T) :- 
	minHeight(N,Hmin), maxHeight(N,Hmax),
	between(Hmin,Hmax,H),
	hbal_tree(H,T), nodes(T,N).
 
% the following predicate is from the course (chapter 4)
 
%  nodes(T,N) :- the binary tree T has N nodes
% (tree,integer);  (i,*) 
 
nodes(nil,0).
nodes(t(_,Left,Right),N) :-
   nodes(Left,NLeft),
   nodes(Right,NRight),
   N is NLeft + NRight + 1.
 
% count_hbal_trees(N,C) :- there are C different height-balanced binary
% trees with N nodes.
 
count_hbal_trees(N,C) :- setof(T,hbal_tree_nodes(N,T),Ts), length(Ts,C). 

p4_08.pl

p4_08.pl
% 4.08 (*) Count the leaves of a binary tree
 
:- ensure_loaded(p4_01).
 
% count_leaves(T,N) :- the binary tree T has N leaves
 
count_leaves(nil,0).
count_leaves(t(_,nil,nil),1).
count_leaves(t(_,L,nil),N) :- L = t(_,_,_), count_leaves(L,N).
count_leaves(t(_,nil,R),N) :- R = t(_,_,_), count_leaves(R,N).
count_leaves(t(_,L,R),N) :- L = t(_,_,_), R = t(_,_,_),
   count_leaves(L,NL), count_leaves(R,NR), N is NL + NR.
 
% The above solution works in the flow patterns (i,o) and (i,i)
% without cut and produces a single correct result. Using a cut 
% we can obtain the same result in a much shorter program, like this:
 
count_leaves1(nil,0).
count_leaves1(t(_,nil,nil),1) :- !.
count_leaves1(t(_,L,R),N) :- 
    count_leaves1(L,NL), count_leaves1(R,NR), N is NL+NR.
 
% For the flow pattern (o,i) see problem 4.09

p4_09.pl

p4_09.pl
% 4.09 (*) Collect the leaves of a binary tree in a list
 
:- ensure_loaded(p4_01).
 
% leaves(T,S) :- S is the list of the leaves of the binary tree T
 
leaves(nil,[]).
leaves(t(X,nil,nil),[X]).
leaves(t(_,L,nil),S) :- L = t(_,_,_), leaves(L,S).
leaves(t(_,nil,R),S) :- R = t(_,_,_), leaves(R,S).
leaves(t(_,L,R),S) :- L = t(_,_,_), R = t(_,_,_),
    leaves(L,SL), leaves(R,SR), append(SL,SR,S).
 
% The above solution works in the flow patterns (i,o) and (i,i)
% without cut and produces a single correct result. Using a cut 
% we can obtain the same result in a much shorter program, like this:
 
leaves1(nil,[]).
leaves1(t(X,nil,nil),[X]) :- !.
leaves1(t(_,L,R),S) :- 
    leaves1(L,SL), leaves1(R,SR), append(SL,SR,S).
 
% To write a predicate that works in the flow pattern (o,i)
% is a more difficult problem, because using append/3 in
% the flow pattern (o,o,i) always generates an empty list 
% as first solution and the result is an infinite recursion
% along the left subtree of the generated binary tree.
% A possible solution is the following trick: we successively
% construct binary tree structures for a given number of nodes
% and fill the leaf nodes with the elements of the leaf list.
% We then increment the number of tree nodes successively,
% and so on. 
 
% nnodes(T,N) :- T is a binary tree with N nodes (o,i)
nnodes(nil,0) :- !.
nnodes(t(_,L,R),N) :- N > 0, N1 is N-1, 
   between(0,N1,NL), NR is N1-NL,
   nnodes(L,NL), nnodes(R,NR).
 
 
% leaves2(T,S) :- S is the list of leaves of the tree T (o,i)
 
leaves2(T,S) :- leaves2(T,S,0).
 
leaves2(T,S,N) :- nnodes(T,N), leaves1(T,S).
leaves2(T,S,N) :- N1 is N+1, leaves2(T,S,N1).
 
% OK, this was difficulty (**)

p4_10.pl

p4_10.pl
% 4.10 (*) Collect the internal nodes of a binary tree in a list
 
:- ensure_loaded(p4_01).
 
% internals(T,S) :- S is the list of internal nodes of the binary tree T.
 
internals(nil,[]).
internals(t(_,nil,nil),[]).
internals(t(X,L,nil),[X|S]) :- L = t(_,_,_), internals(L,S).
internals(t(X,nil,R),[X|S]) :- R = t(_,_,_), internals(R,S).
internals(t(X,L,R),[X|S]) :- L = t(_,_,_), R = t(_,_,_), 
   internals(L,SL), internals(R,SR), append(SL,SR,S).
 
% The above solution works in the flow patterns (i,o) and (i,i)
% without cut and produces a single correct result. Using a cut 
% we can obtain the same result in a much shorter program, like this:
 
internals1(nil,[]).
internals1(t(_,nil,nil),[]) :- !.
internals1(t(X,L,R),[X|S]) :- 
    internals1(L,SL), internals1(R,SR), append(SL,SR,S).
 
% For the flow pattern (o,i) there is the following very
% elegant solution:
 
internals2(nil,[]).
internals2(t(X,L,R),[X|S]) :- 
   append(SL,SR,S), internals2(L,SL), internals2(R,SR).

p4_11.pl

p4_11.pl
% 4.11 (*) Collect the nodes of a binary tree at a given level in a list
 
:- ensure_loaded(p4_01).
 
% atlevel(T,D,S) :- S is the list of nodes of the binary tree T at level D
% (i,i,o)
 
atlevel(nil,_,[]).
atlevel(t(X,_,_),1,[X]).
atlevel(t(_,L,R),D,S) :- D > 1, D1 is D-1,
   atlevel(L,D1,SL), atlevel(R,D1,SR), append(SL,SR,S).
 
 
% The following is a quick-and-dirty solution for the
% level-order sequence
 
levelorder(T,S) :- levelorder(T,S,1).
 
levelorder(T,[],D) :- atlevel(T,D,[]), !.
levelorder(T,S,D) :- atlevel(T,D,SD),
   D1 is D+1, levelorder(T,S1,D1), append(SD,S1,S).

p4_12.pl

p4_12.pl
% 4.12 (**) Construct a complete binary tree
%
% A complete binary tree with height H is defined as follows: 
% The levels 1,2,3,...,H-1 contain the maximum number of nodes 
% (i.e 2**(i-1) at the level i, note that we start counting the 
% levels from 1 at the root). In level H, which may contain less 
% than the maximum number possible of nodes, all the nodes are 
% "left-adjusted". This means that in a levelorder tree traversal 
% all internal nodes come first, the leaves come second, and
% empty successors (the nils which are not really nodes!) 
% come last. Complete binary trees are used for heaps.
 
:- ensure_loaded(p4_04).
 
% complete_binary_tree(N,T) :- T is a complete binary tree with
% N nodes. (+,?)
 
complete_binary_tree(N,T) :- complete_binary_tree(N,T,1).
 
complete_binary_tree(N,nil,A) :- A > N, !.
complete_binary_tree(N,t(_,L,R),A) :- A =< N,
	AL is 2 * A, AR is AL + 1,
	complete_binary_tree(N,L,AL),
	complete_binary_tree(N,R,AR).
 
 
% ----------------------------------------------------------------------
 
% This was the solution of the exercise. What follows is an application
% of this result.
 
% We define a heap as a term heap(N,T) where N is the number of elements
% and T a complete binary tree (in the sense used above).
 
% The conservative usage of a heap is first to declare it with a predicate
% declare_heap/2 and then use it with a predicate element_at/3.
 
% declare_heap(H,N) :- 
%    declare H to be a heap with a fixed number N  of elements
 
declare_heap(heap(N,T),N) :- complete_binary_tree(N,T).
 
% element_at(H,K,X) :- X is the element at address K in the heap H. 
%  The first element has address 1.
%  (+,+,?)
 
element_at(heap(_,T),K,X) :- 
   binary_path(K,[],BP), element_at_path(T,BP,X).
 
binary_path(1,Bs,Bs) :- !.
binary_path(K,Acc,Bs) :- K > 1, 
   B is K /\ 1, K1 is K >> 1, binary_path(K1,[B|Acc],Bs).
 
element_at_path(t(X,_,_),[],X) :- !.
element_at_path(t(_,L,_),[0|Bs],X) :- !, element_at_path(L,Bs,X).
element_at_path(t(_,_,R),[1|Bs],X) :- element_at_path(R,Bs,X).
 
 
% We can transform lists into heaps and vice versa with the following
% useful predicate:
 
% list_heap(L,H) :- transform a list into a (limited) heap and vice versa.
 
list_heap(L,H) :- is_list(L), list_to_heap(L,H).
list_heap(L,heap(N,T)) :- integer(N), fill_list(heap(N,T),N,1,L).
 
list_to_heap(L,H) :- 
   length(L,N), declare_heap(H,N), fill_heap(H,L,1).
 
fill_heap(_,[],_).
fill_heap(H,[X|Xs],K) :- element_at(H,K,X), K1 is K+1, fill_heap(H,Xs,K1).
 
fill_list(_,N,K,[]) :- K > N.
fill_list(H,N,K,[X|Xs]) :- K =< N, 
   element_at(H,K,X), K1 is K+1, fill_list(H,N,K1,Xs).
 
 
% However, a more aggressive usage is *not* to define the heap in the
% beginning, but to use it as a partially instantiated data structure.
% Used in this way, the number of elements in the heap is unlimited.
% This is Power-Prolog!
 
% Try the following and find out exactly what happens.
 
% ?- element_at(H,5,alfa), element_at(H,2,beta), element(H,5,A).
 
% -------------------------------------------------------------------------
 
% Test section. Suppose you have N elements in a list which must be looked
% up M times in a random order.
 
test1(N,M) :-
   length(List,N), lookup_list(List,N,M).
 
lookup_list(_,_,0) :- !.
lookup_list(List,N,M) :- 
   K is random(N)+1,       % determine a random address
   nth1(K,List,_),         % look up and throw away
   M1 is M-1,
   lookup_list(List,N,M1).
 
% ?- time(test1(100,100000)).
% 1,384,597 inferences in 3.98 seconds (347889 Lips)
% ?- time(test1(500,100000)).
% 4,721,902 inferences in 13.82 seconds (341672 Lips)
% ?- time(test1(10000,100000)).
% 84,016,719 inferences in 277.51 seconds (302752 Lips)
 
test2(N,M) :-
   declare_heap(Heap,N), 
   lookup_heap(Heap,N,M).
 
lookup_heap(_,_,0) :- !.
lookup_heap(Heap,N,M) :- 
   K is random(N)+1,       % determine a random address
   element_at(Heap,K,_),   % look up and throw away
   M1 is M-1,
   lookup_heap(Heap,N,M1).
 
% ?- time(test2(100,100000)).
% 3,002,061 inferences in 7.81 seconds (384387 Lips)                          
% ?- time(test2(500,100000)).
% 4,097,961 inferences in 10.75 seconds (381206 Lips)
% ?- time(test2(10000,100000)).
% 6,366,206 inferences in 19.16 seconds (332265 Lips)
 
% Conclusion: In this scenario, for lists longer than 500 elements 
% it is more efficient to use a heap.

p4_13.pl

p4_13.pl
% 4.13 (**) Layout a binary tree (1)
%
% Given a binary tree as the usual Prolog term t(X,L,R) (or nil).
% As a preparation for drawing the tree, a layout algorithm is
% required to determine the position of each node in a rectangular
% grid. Several layout methods are conceivable, one of them is
% the following:
%
% The position of a node v is obtained by the following two rules:
%   x(v) is equal to the position of the node v in the inorder sequence
%   y(v) is equal to the depth of the node v in the tree
%
% In order to store the position of the nodes, we extend the Prolog 
% term representing a node (and its successors) as follows:
%    nil represents the empty tree (as usual)
%    t(W,X,Y,L,R) represents a (non-empty) binary tree with root
%        W positionned at (X,Y), and subtrees L and R
%
% Write a predicate layout_binary_tree/2:
 
% layout_binary_tree(T,PT) :- PT is the "positionned" binary
%    tree obtained from the binary tree T. (+,?) or (?,+)
 
:- ensure_loaded(p4_04). % for test
 
layout_binary_tree(T,PT) :- layout_binary_tree(T,PT,1,_,1).
 
% layout_binary_tree(T,PT,In,Out,D) :- T and PT as in layout_binary_tree/2;
%    In is the position in the inorder sequence where the tree T (or PT)
%    begins, Out is the position after the last node of T (or PT) in the 
%    inorder sequence. D is the depth of the root of T (or PT). 
%    (+,?,+,?,+) or (?,+,+,?,+)
 
layout_binary_tree(nil,nil,I,I,_).
layout_binary_tree(t(W,L,R),t(W,X,Y,PL,PR),Iin,Iout,Y) :- 
   Y1 is Y + 1,
   layout_binary_tree(L,PL,Iin,X,Y1), 
   X1 is X + 1,
   layout_binary_tree(R,PR,X1,Iout,Y1).
 
% Test (see example given in the problem description):
% ?-  construct([n,k,m,c,a,h,g,e,u,p,s,q],T),layout_binary_tree(T,PT).

p4_14.pl

p4_14.pl
% 4.14 (**) Layout a binary tree (2)
%
% See problem 4.13 for the conventions.
%
% The position of a node v is obtained by the following rules:
%   (1) y(v) is equal to the depth of the node v in the tree
%   (2) if D denotes the depth of the tree (i.e. the number of
%       populated levels) then the horizontal distance between
%       nodes at level i (counted from the root, beginning with 1)
%       is equal to 2**(D-i+1). The leftmost node of the tree
%       is at position 1.
 
% layout_binary_tree2(T,PT) :- PT is the "positionned" binary
%    tree obtained from the binary tree T. (+,?)
 
:- ensure_loaded(p4_04). % for test
 
layout_binary_tree2(nil,nil) :- !. 
layout_binary_tree2(T,PT) :- 
   hor_dist(T,D4), D is D4//4, x_pos(T,X,D), 
   layout_binary_tree2(T,PT,X,1,D).
 
% hor_dist(T,D4) :- D4 is four times the horizontal distance between the 
%    root node of T and its successor(s) (if any).
%    (+,-)
 
hor_dist(nil,1).
hor_dist(t(_,L,R),D4) :- 
   hor_dist(L,D4L), 
   hor_dist(R,D4R),
   D4 is 2 * max(D4L,D4R).
 
% x_pos(T,X,D) :- X is the horizontal position of the root node of T
%    with respect to the picture co-ordinate system. D is the horizontal
%    distance between the root node of T and its successor(s) (if any).
%    (+,-,+)
 
x_pos(t(_,nil,_),1,_) :- !.
x_pos(t(_,L,_),X,D) :- D2 is D//2, x_pos(L,XL,D2), X is XL+D.
 
% layout_binary_tree2(T,PT,X,Y,D) :- T and PT as in layout_binary_tree/2;
%    D is the the horizontal distance between the root node of T and 
%    its successor(s) (if any). X, Y are the co-ordinates of the root node.
%    (+,-,+,+,+)
 
layout_binary_tree2(nil,nil,_,_,_).
layout_binary_tree2(t(W,L,R),t(W,X,Y,PL,PR),X,Y,D) :- 
   Y1 is Y + 1,
   Xleft is X - D,
   D2 is D//2,
   layout_binary_tree2(L,PL,Xleft,Y1,D2), 
   Xright is X + D,
   layout_binary_tree2(R,PR,Xright,Y1,D2).
 
% Test (see example given in the problem description):
% ?- construct([n,k,m,c,a,e,d,g,u,p,q],T),layout_binary_tree2(T,PT).

p4_15.pl

p4_15.pl
% 4.15 (***) Layout a binary tree (3)
%
% See problem 4.13 for the conventions.
%
% The position of a node v is obtained by the following rules:
%   (1) y(v) is equal to the depth of the node v in the tree
%   (2) in order to determine the horizontal positions of the nodes we
%       construct "contours" for each subtree and shift them together 
%       horizontally as close as possible. However, we maintain the
%       symmetry in each node; i.e. the horizontal distance between
%       a node and the root of its left subtree is the same as between
%       it and the root of its right subtree.
%
%       The "contour" of a tree is a list of terms c(Xleft,Xright) which
%       give the horizontal position of the outermost nodes of the tree
%       on each level, relative to the root position. In the example
%       given in the problem description, the "contour" of the tree with
%       root k would be [c(-1,1),c(-2,0),c(-1,1)]. Note that the first
%       element in the "contour" list is derived from the position of
%       the nodes c and m.
 
% layout_binary_tree3(T,PT) :- PT is the "positionned" binary
%    tree obtained from the binary tree T. (+,?)
 
:- ensure_loaded(p4_04). % for test
 
layout_binary_tree3(nil,nil) :- !. 
layout_binary_tree3(T,PT) :-
   contour_tree(T,CT),      % construct the "contour" tree CT
   CT = t(_,_,_,Contour),
   mincont(Contour,MC,0),   % find the position of the leftmost node
   Xroot is 1-MC,
   layout_binary_tree3(CT,PT,Xroot,1).
 
contour_tree(nil,nil).
contour_tree(t(X,L,R),t(X,CL,CR,Contour)) :- 
   contour_tree(L,CL),
   contour_tree(R,CR),
   combine(CL,CR,Contour).
 
combine(nil,nil,[]).
combine(t(_,_,_,CL),nil,[c(-1,-1)|Cs]) :- shift(CL,-1,Cs).
combine(nil,t(_,_,_,CR),[c(1,1)|Cs]) :- shift(CR,1,Cs).
combine(t(_,_,_,CL),t(_,_,_,CR),[c(DL,DR)|Cs]) :-
   maxdiff(CL,CR,MD,0), 
   DR is (MD+2)//2, DL is -DR,
   merge(CL,CR,DL,DR,Cs).
 
shift([],_,[]).
shift([c(L,R)|Cs],S,[c(LS,RS)|CsS]) :-
   LS is L+S, RS is R+S, shift(Cs,S,CsS).
 
maxdiff([],_,MD,MD) :- !.
maxdiff(_,[],MD,MD) :- !.
maxdiff([c(_,R1)|Cs1],[c(L2,_)|Cs2],MD,A) :- 
   A1 is max(A,R1-L2),
   maxdiff(Cs1,Cs2,MD,A1).
 
merge([],CR,_,DR,Cs) :- !, shift(CR,DR,Cs).
merge(CL,[],DL,_,Cs) :- !, shift(CL,DL,Cs).
merge([c(L1,_)|Cs1],[c(_,R2)|Cs2],DL,DR,[c(L,R)|Cs]) :-
   L is L1+DL, R is R2+DR,
   merge(Cs1,Cs2,DL,DR,Cs).
 
mincont([],MC,MC).
mincont([c(L,_)|Cs],MC,A) :- 
   A1 is min(A,L), mincont(Cs,MC,A1).
 
layout_binary_tree3(nil,nil,_,_).
layout_binary_tree3(t(W,nil,nil,_),t(W,X,Y,nil,nil),X,Y) :- !. 
layout_binary_tree3(t(W,L,R,[c(DL,DR)|_]),t(W,X,Y,PL,PR),X,Y) :- 
   Y1 is Y + 1,
   Xleft is X + DL,
   layout_binary_tree3(L,PL,Xleft,Y1), 
   Xright is X + DR,
   layout_binary_tree3(R,PR,Xright,Y1).
 
% Test (see example given in the problem description):
% ?- construct([n,k,m,c,a,e,d,g,u,p,q],T),layout_binary_tree3(T,PT).

p4_16a.pl

p4_16a.pl
% 4.16a (**)  A string representation of binary trees
 
% The string representation has the following syntax:
%
% <tree> ::=  | <letter><subtrees>
%
% <subtrees> ::=  | '(' <tree> ',' <tree> ')'
%
% According to this syntax, a leaf node (with letter x) could
% be represented by x(,) and not only by the single character x.
% However, we will avoid this when generating the string 
% representation.
 
tree_string(T,S) :- nonvar(T), !, tree_to_string(T,S). 
tree_string(T,S) :- nonvar(S), string_to_tree(S,T). 
 
tree_to_string(T,S) :- tree_to_list(T,L), atom_chars(S,L).
 
tree_to_list(nil,[]).
tree_to_list(t(X,nil,nil),[X]) :- !.
tree_to_list(t(X,L,R),[X,'('|List]) :- 
   tree_to_list(L,LsL),
   tree_to_list(R,LsR),
   append(LsL,[','],List1),
   append(List1,LsR,List2),
   append(List2,[')'],List).
 
string_to_tree(S,T) :- atom_chars(S,L), list_to_tree(L,T).
 
list_to_tree([],nil).
list_to_tree([X],t(X,nil,nil)) :- char_type(X,alpha).
list_to_tree([X,'('|List],t(X,Left,Right)) :- char_type(X,alpha),
   append(List1,[')'],List),
   append(LeftList,[','|RightList],List1),
   list_to_tree(LeftList,Left),
   list_to_tree(RightList,Right).

p4_16b.pl

p4_16b.pl
% 4.16b (**) A string representation of binary trees
 
% Most elegant solution using difference lists.
 
tree_string(T,S) :- nonvar(T), tree_dlist(T,L-[]), !, atom_chars(S,L). 
tree_string(T,S) :- nonvar(S), atom_chars(S,L), tree_dlist(T,L-[]).
 
% tree_dlist/2 does the trick in both directions!
 
tree_dlist(nil,L-L).
tree_dlist(t(X,nil,nil),L1-L2) :- 
   letter(X,L1-L2).
tree_dlist(t(X,Left,Right),L1-L7) :- 
   letter(X,L1-L2), 
   symbol('(',L2-L3),
   tree_dlist(Left,L3-L4),
   symbol(',',L4-L5),
   tree_dlist(Right,L5-L6),
   symbol(')',L6-L7).
 
symbol(X,[X|Xs]-Xs).
 
letter(X,L1-L2) :- symbol(X,L1-L2), char_type(X,alpha).

p4_17a.pl

p4_17a.pl
% 4.17a (**) Preorder and inorder sequences of binary trees
 
% We consider binary trees with nodes that are identified by
% single lower-case letters.
 
% a) Given a binary tree, construct its preorder sequence
 
preorder(T,S) :- preorder_tl(T,L), atom_chars(S,L).
 
preorder_tl(nil,[]).
preorder_tl(t(X,Left,Right),[X|List]) :-
   preorder_tl(Left,ListLeft),
   preorder_tl(Right,ListRight),
   append(ListLeft,ListRight,List).
 
inorder(T,S) :- inorder_tl(T,L), atom_chars(S,L).
 
inorder_tl(nil,[]).
inorder_tl(t(X,Left,Right),List) :-
   inorder_tl(Left,ListLeft),
   inorder_tl(Right,ListRight),
   append(ListLeft,[X|ListRight],List).

p4_17b.pl

p4_17b.pl
% 4.17b (**) Preorder and inorder sequences of binary trees
 
% b) Make preorder/2 and inorder/2 reversible.
 
% Similar to the solution p4_17a.pl. However, for the flow pattern (-,+) 
% we have to modify the order of the subgoals in the second clauses 
% of preorder_l/2 and inorder_l/2
 
% preorder(T,S) :- S is the preorder tre traversal sequence of the
%    nodes of the binary tree T. (tree,atom) (+,?) or (?,+)
 
preorder(T,S) :- nonvar(T), !, preorder_tl(T,L), atom_chars(S,L). 
preorder(T,S) :- atom(S), atom_chars(S,L), preorder_lt(T,L).
 
preorder_tl(nil,[]).
preorder_tl(t(X,Left,Right),[X|List]) :-
   preorder_tl(Left,ListLeft),
   preorder_tl(Right,ListRight),
   append(ListLeft,ListRight,List).
 
preorder_lt(nil,[]).
preorder_lt(t(X,Left,Right),[X|List]) :-
   append(ListLeft,ListRight,List),
   preorder_lt(Left,ListLeft),
   preorder_lt(Right,ListRight).
 
% inorder(T,S) :- S is the inorder tre traversal sequence of the
%    nodes of the binary tree T. (tree,atom) (+,?) or (?,+)
 
inorder(T,S) :- nonvar(T), !, inorder_tl(T,L), atom_chars(S,L). 
inorder(T,S) :- atom(S), atom_chars(S,L), inorder_lt(T,L).
 
inorder_tl(nil,[]).
inorder_tl(t(X,Left,Right),List) :-
   inorder_tl(Left,ListLeft),
   inorder_tl(Right,ListRight),
   append(ListLeft,[X|ListRight],List).
 
inorder_lt(nil,[]).
inorder_lt(t(X,Left,Right),List) :-
   append(ListLeft,[X|ListRight],List),
   inorder_lt(Left,ListLeft),
   inorder_lt(Right,ListRight).

p4_17c.pl

p4_17c.pl
% 4.17c (**) Preorder and inorder sequences of binary trees
 
% If both the preorder sequence and the inorder sequence of
% the nodes of a binary tree are given, then the tree is determined
% unambiguously. 
 
:- ensure_loaded(p4_17b).
 
% pre_in_tree(P,I,T) :- T is the binary tree that has the preorder
%   sequence P and inorder sequence I.
%   (atom,atom,tree) (+,+,?)
 
pre_in_tree(P,I,T) :- preorder(T,P), inorder(T,I).
 
% This is a nice application of the generate-and-test method.
 
 
% We can push the tester inside the generator in order to get
% a (much) better performance.
 
pre_in_tree_push(P,I,T) :- 
   atom_chars(P,PL), atom_chars(I,IL), pre_in_tree_pu(PL,IL,T).
 
pre_in_tree_pu([],[],nil).
pre_in_tree_pu([X|PL],IL,t(X,Left,Right)) :- 
   append(ILeft,[X|IRight],IL),
   append(PLeft,PRight,PL),
   pre_in_tree_pu(PLeft,ILeft,Left),
   pre_in_tree_pu(PRight,IRight,Right).
 
% Nice. But there is a still better solution. See problem d)!

p4_17d.pl

p4_17d.pl
% 4.17d (**) Preorder and inorder sequences of binary trees
 
% Work with difference lists
 
% pre_in_tree_d(P,I,T) :- T is the binary tree that has the preorder
%   sequence P and inorder sequence I.
%   (atom,atom,tree) (+,+,?)
 
pre_in_tree_d(P,I,T) :-  
   atom_chars(P,PL), atom_chars(I,IL), pre_in_tree_dl(PL-[],IL-[],T).
 
pre_in_tree_dl(P-P,I-I,nil).
pre_in_tree_dl(P1-P4,I1-I4,t(X,Left,Right)) :-
   symbol(X,P1-P2), symbol(X,I2-I3),
   pre_in_tree_dl(P2-P3,I1-I2,Left),
   pre_in_tree_dl(P3-P4,I3-I4,Right).
 
symbol(X,[X|Xs]-Xs).
 
 
% Isn't it cool? But the best of it is the performance!
 
% With the generate-and-test solution (p4_17c):
% ?- time(pre_in_tree(abdecfg,dbeacgf,_)).
% 9,048 inferences in 0.01 seconds (904800 Lips)  
 
% With the "pushed" generate-and-test solution (p4_17c):
% ?- time(pre_in_tree_push(abdecfg,dbeacgf,_)).
% 67 inferences in 0.00 seconds (Infinite Lips)
 
% With the difference list solution (p4_17d):
% ?- time(pre_in_tree_d(abdecfg,dbeacgf,_)).
% 32 inferences in 0.00 seconds (Infinite Lips)                     
 
% Note that the predicate pre_in_tree_dl/3 runs in almost any
% flow pattern. Try it out!

p4_18.pl

p4_18.pl
%  4.18 (**) Dotstring representation of binary trees</B>
 
% The syntax of the dotstring representation is super simple:
%
% <tree> ::= . | <letter> <tree> <tree>
 
tree_dotstring(T,S) :- nonvar(T), !, tree_dots_dl(T,L-[]), atom_chars(S,L). 
tree_dotstring(T,S) :- atom(S), atom_chars(S,L), tree_dots_dl(T,L-[]).
 
tree_dots_dl(nil,L1-L2) :- symbol('.',L1-L2).
tree_dots_dl(t(X,Left,Right),L1-L4) :- 
   letter(X,L1-L2),
   tree_dots_dl(Left,L2-L3),
   tree_dots_dl(Right,L3-L4).
 
symbol(X,[X|Xs]-Xs).
 
letter(X,L1-L2) :- symbol(X,L1-L2), char_type(X,alpha).

p5_01.pl

p5_01.pl
% 5.01 Write a predicate istree/1 which succeeds if and only if its argument
%       is a Prolog term representing a multiway tree.
%
% istree(T) :- T is a term representing a multiway tree (i), (o)
 
% the following is a test case:
tree(1,t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])).
 
istree(t(_,F)) :- isforest(F).
 
isforest([]).
isforest([T|Ts]) :- istree(T), isforest(Ts).

p5_02.pl

p5_02.pl
% 5.02 Write a predicate nnodes/2 to count the nodes of a multiway tree.
%
% nnodes(T,N) :- the multiway tree T has N nodes (i,o))
 
% the following is a test case:
tree(1,t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])).
 
nnodes(t(_,F),N) :- nnodes(F,NF), N is NF+1.
 
nnodes([],0).
nnodes([T|Ts],N) :- nnodes(T,NT), nnodes(Ts,NTs), N is NT+NTs.
 
% Note that nnodes is called for trees and for forests. An early
% form of polymorphism!
 
% For the flow pattern (o,i) we can write:
 
nnodes2(t(_,F),N) :- N > 0, NF is N-1, nnodes2F(F,NF).
 
nnodes2F([],0).
nnodes2F([T|Ts],N) :- N > 0, 
   between(1,N,NT), nnodes2(T,NT), 
   NTs is N-NT, nnodes2F(Ts,NTs).

p5_03.pl

p5_03.pl
% 5.03 (**) Multiway tree construction from a node string
 
% We suppose that the nodes of a multiway tree contain single
% characters. In the depth-first order sequence of its nodes, a
% special character ^ has been inserted whenever, during the
% tree traversal, the move is a backtrack to the previous level.
 
% Define the syntax of the string and write a predicate tree(String,Tree)
% to construct the Tree when the String is given. Work with atoms (instead
% of strings). Make your predicate work in both directions.
%
 
% Syntax in BNF:
 
% <tree> ::= <letter> <forest> '^'
 
% <forest> ::= | <tree> <forest> 
 
 
% First a nice solution using difference lists
 
tree(TS,T) :- atom(TS), !, atom_chars(TS,TL), tree_d(TL-[],T). % (+,?)
tree(TS,T) :- nonvar(T), tree_d(TL-[],T), atom_chars(TS,TL).   % (?,+)
 
tree_d([X|F1]-T, t(X,F)) :- forest_d(F1-['^'|T],F).
 
forest_d(F-F,[]).
forest_d(F1-F3,[T|F]) :- tree_d(F1-F2,T), forest_d(F2-F3,F).
 
 
% Another solution, not as elegant as the previous one.
 
tree_2(TS,T) :- atom(TS), !, atom_chars(TS,TL), tree_a(TL,T). % (+,?)
tree_2(TS,T) :- nonvar(T), tree_a(TL,T), atom_chars(TS,TL).   % (?,+)
 
tree_a(TL,t(X,F)) :- 
   append([X],FL,L1), append(L1,['^'],TL), forest_a(FL,F).
 
forest_a([],[]).
forest_a(FL,[T|Ts]) :- append(TL,TsL,FL), 
   tree_a(TL,T), forest_a(TsL,Ts).

p5_04.pl

p5_04.pl
% 5.04 (*) Determine the internal path length of a tree
 
% We define the internal path length of a multiway tree as the
% total sum of the path lengths from the root to all nodes of the tree.
 
% ipl(Tree,L) :- L is the internal path length of the tree Tree
%    (multiway-tree, integer) (+,?)
 
ipl(T,L) :- ipl(T,0,L).
 
ipl(t(_,F),D,L) :- D1 is D+1, ipl(F,D1,LF), L is LF+D.
 
ipl([],_,0).
ipl([T1|Ts],D,L) :- ipl(T1,D,L1), ipl(Ts,D,Ls), L is L1+Ls.
 
% Notice the polymorphism: ipl is called with trees and with forests
% as first argument.

p5_05.pl

p5_05.pl
% 5.05 (*) Construct the bottom-up order sequence of the tree nodes
 
% bottom_up(Tree,Seq) :- Seq is the bottom-up sequence of the nodes of
%    the multiway tree Tree. (+,?)
 
bottom_up_f(t(X,F),Seq) :- 
	bottom_up_f(F,SeqF), append(SeqF,[X],Seq).
 
bottom_up_f([],[]).
bottom_up_f([T|Ts],Seq):-
	bottom_up_f(T,SeqT), bottom_up_f(Ts,SeqTs), append(SeqT,SeqTs,Seq).
 
% The predicate bottom_up/2 produces a stack overflow when called
% in the (-,+) flow pattern. There are two problems with that.
% First, the polymorphism does not work properly, because during
% decomposing the string, the program cannot guess whether it should
% construct a tree or a forest next. We can fix this using two
% separate predicates bottom_up_tree/2 and bottom_up_forset/2.
% Secondly, if we maintain the order of the subgoals, then
% the interpreter falls into an endless loop after finding the
% first solution. We can fix this by changing the order of the
% goals as follows:
 
bottom_up_tree(t(X,F),Seq) :-                        % (?,+)
	append(SeqF,[X],Seq), bottom_up_forest(F,SeqF).
 
bottom_up_forest([],[]).
bottom_up_forest([T|Ts],Seq):-
	append(SeqT,SeqTs,Seq),
	bottom_up_tree(T,SeqT), bottom_up_forest(Ts,SeqTs).
 
% Unfortunately, this version doesn't run in both directions either.
 
% In order to have a predicate which runs forward and backward, we
% have to determine the flow pattern and then call one of the above
% predicates, as follows:
 
bottom_up(T,Seq) :- nonvar(T), !, bottom_up_f(T,Seq).
bottom_up(T,Seq) :- nonvar(Seq), bottom_up_tree(T,Seq).
 
% This is not very elegant, I agree.

p5_06a.pl

p5_06a.pl
% P73 (**)  Lisp-like tree representation
 
% This is a simple solution for the conversion of trees
% into "lispy token lists"  (i,o)
 
% tree_ltl(T,L) :- L is the "lispy token list" of the multiway tree T
% (i,o)
 
tree_ltl(t(X,[]),[X]).
tree_ltl(t(X,[T|Ts],L) :- 
   tree_ltl(T,L1), 
   append(['(',X],L1,L2)
   rest_ltl(Ts,L3),
   append(L2,L3,L).
 
rest_ltl([],[')']).
rest_ltl([T|Ts],L) :- 
   tree_ltl(T,L1), 
   rest_ltl(Ts,L2), 
   append(L1,L2,L).
 
 
% some auxiliary predicates
 
write_ltl([]) :- nl.
write_ltl([X|Xs]) :- write(X), write(' '), write_ltl(Xs).
 
dotest(T) :- write(T), nl, tree_ltl(T,L),
   write_ltl(L), tree_ltl(T1,L), write(T1), nl.
 
test(1) :- T = t(a,[t(b,[]),t(c,[])]), dotest(T).
test(2) :- T = t(a,[t(b,[t(c,[])])]), dotest(T).
test(3) :- T = t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])]), 
   dotest(T).

p5_06b.pl

p5_06b.pl
% 5.06 (**)  Lisp-like tree representation
 
% Here is my most elegant solution: a single predicate for both flow 
% patterns (i,o) and (o,i)
 
% tree_ltl(T,L) :- L is the "lispy token list" of the multiway tree T
 
tree_ltl(T,L) :- tree_ltl_d(T,L-[]).
 
% using difference lists
 
tree_ltl_d(t(X,[]),[X|L]-L) :- X \= '('.
tree_ltl_d(t(X,[T|Ts]),['(',X|L]-R) :- forest_ltl_d([T|Ts],L-[')'|R]).
 
forest_ltl_d([],L-L).
forest_ltl_d([T|Ts],L-R) :- tree_ltl_d(T,L-M), forest_ltl_d(Ts,M-R).
 
% some auxiliary predicates
 
write_ltl([]) :- nl.
write_ltl([X|Xs]) :- write(X), write(' '), write_ltl(Xs).
 
dotest(T) :- write(T), nl, tree_ltl(T,L),
   write_ltl(L), tree_ltl(T1,L), write(T1), nl.
 
test(1) :- T = t(a,[t(b,[]),t(c,[])]), dotest(T).
test(2) :- T = t(a,[t(b,[t(c,[])])]), dotest(T).
test(3) :- T = t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])]), 
   dotest(T).

p6_01.pl

p6_01.pl
% 6.01 (**) Conversions between graph representations
 
% We use the following notation:
%
% adjacency-list (alist): [n(b,[c,g,h]), n(c,[b,d,f,h]), n(d,[c,f]), ...]
%
% graph-term (gterm)  graph([b,c,d,f,g,h,k],[e(b,c),e(b,g),e(b,h), ...]) or
%                     digraph([r,s,t,u],[a(r,s),a(r,t),a(s,t), ...])
%
% edge-clause (ecl):  edge(b,g).  (in program database)
% arc-clause (acl):   arc(r,s).   (in program database)
%
% human-friendly (hf): [a-b,c,g-h,d-e]  or [a>b,h>g,c,b>a]
%
% The main conversion predicates are: alist_gterm/3 and human_gterm/2 which
% both (hopefully) work in either direction and for graphs as well as
% for digraphs, labelled or not.
 
% alist_gterm(Type,AL,GT) :- convert between adjacency-list and graph-term
%    representation. Type is either 'graph' or 'digraph'.
%    (atom,alist,gterm)  (+,+,?) or (?,?,+)
 
alist_gterm(Type,AL,GT):- nonvar(GT), !, gterm_to_alist(GT,Type,AL).
alist_gterm(Type,AL,GT):- atom(Type), nonvar(AL), alist_to_gterm(Type,AL,GT).
 
gterm_to_alist(graph(Ns,Es),graph,AL) :- memberchk(e(_,_,_),Es), ! ,
   lgt_al(Ns,Es,AL).
gterm_to_alist(graph(Ns,Es),graph,AL) :- !, 
   gt_al(Ns,Es,AL).
gterm_to_alist(digraph(Ns,As),digraph,AL) :- memberchk(a(_,_,_),As), !,
   ldt_al(Ns,As,AL).
gterm_to_alist(digraph(Ns,As),digraph,AL) :- 
   dt_al(Ns,As,AL).
 
% labelled graph
lgt_al([],_,[]).
lgt_al([V|Vs],Es,[n(V,L)|Ns]) :-
   findall(T,((member(e(X,V,I),Es) ; member(e(V,X,I),Es)),T = X/I),L),
   lgt_al(Vs,Es,Ns).
 
% unlabelled graph
gt_al([],_,[]).
gt_al([V|Vs],Es,[n(V,L)|Ns]) :-
   findall(X,(member(e(X,V),Es) ; member(e(V,X),Es)),L), gt_al(Vs,Es,Ns).
 
% labelled digraph
ldt_al([],_,[]).
ldt_al([V|Vs],As,[n(V,L)|Ns]) :-
   findall(T,(member(a(V,X,I),As), T=X/I),L), ldt_al(Vs,As,Ns).
 
% unlabelled digraph
dt_al([],_,[]).
dt_al([V|Vs],As,[n(V,L)|Ns]) :-
   findall(X,member(a(V,X),As),L), dt_al(Vs,As,Ns).
 
 
alist_to_gterm(graph,AL,graph(Ns,Es)) :- !, al_gt(AL,Ns,EsU,[]), sort(EsU,Es).
alist_to_gterm(digraph,AL,digraph(Ns,As)) :- al_dt(AL,Ns,AsU,[]), sort(AsU,As).
 
al_gt([],[],Es,Es).
al_gt([n(V,Xs)|Ns],[V|Vs],Es,Acc) :- 
   add_edges(V,Xs,Acc1,Acc), al_gt(Ns,Vs,Es,Acc1). 
 
add_edges(_,[],Es,Es).
add_edges(V,[X/_|Xs],Es,Acc) :- V @> X, !, add_edges(V,Xs,Es,Acc).
add_edges(V,[X|Xs],Es,Acc) :- V @> X, !, add_edges(V,Xs,Es,Acc).
add_edges(V,[X/I|Xs],Es,Acc) :- V @=< X, !, add_edges(V,Xs,Es,[e(V,X,I)|Acc]).
add_edges(V,[X|Xs],Es,Acc) :- V @=< X, add_edges(V,Xs,Es,[e(V,X)|Acc]).
 
al_dt([],[],As,As).
al_dt([n(V,Xs)|Ns],[V|Vs],As,Acc) :- 
   add_arcs(V,Xs,Acc1,Acc), al_dt(Ns,Vs,As,Acc1). 
 
add_arcs(_,[],As,As).
add_arcs(V,[X/I|Xs],As,Acc) :- !, add_arcs(V,Xs,As,[a(V,X,I)|Acc]).
add_arcs(V,[X|Xs],As,Acc) :- add_arcs(V,Xs,As,[a(V,X)|Acc]).
 
% ---------------------------------------------------------------------------
 
% ecl_to_gterm(GT) :- construct a graph-term from edge/2 facts in the
%    program database.
 
ecl_to_gterm(GT) :-
   findall(E,(edge(X,Y),E=X-Y),Es), human_gterm(Es,GT).
 
% acl_to_gterm(GT) :- construct a graph-term from arc/2 facts in the
%    program database.
 
acl_to_gterm(GT) :-
   findall(A,(arc(X,Y),A= >(X,Y)),As), human_gterm(As,GT).
 
% ---------------------------------------------------------------------------
 
% human_gterm(HF,GT) :- convert between human-friendly and graph-term
%    representation.
%    (list,gterm) (+,?) or (?,+)
 
human_gterm(HF,GT):- nonvar(GT), !, gterm_to_human(GT,HF).
human_gterm(HF,GT):- nonvar(HF), human_to_gterm(HF,GT).
 
gterm_to_human(graph(Ns,Es),HF) :-  memberchk(e(_,_,_),Es), !, 
   lgt_hf(Ns,Es,HF).
gterm_to_human(graph(Ns,Es),HF) :-  !, 
   gt_hf(Ns,Es,HF).
gterm_to_human(digraph(Ns,As),HF) :- memberchk(a(_,_,_),As), !, 
   ldt_hf(Ns,As,HF).
gterm_to_human(digraph(Ns,As),HF) :- 
   dt_hf(Ns,As,HF).
 
% labelled graph
lgt_hf(Ns,[],Ns).
lgt_hf(Ns,[e(X,Y,I)|Es],[X-Y/I|Hs]) :-
   delete(Ns,X,Ns1),
   delete(Ns1,Y,Ns2),
   lgt_hf(Ns2,Es,Hs).
 
% unlabelled graph
gt_hf(Ns,[],Ns).
gt_hf(Ns,[e(X,Y)|Es],[X-Y|Hs]) :-
   delete(Ns,X,Ns1),
   delete(Ns1,Y,Ns2),
   gt_hf(Ns2,Es,Hs).
 
% labelled digraph
ldt_hf(Ns,[],Ns).
ldt_hf(Ns,[a(X,Y,I)|As],[X>Y/I|Hs]) :-
   delete(Ns,X,Ns1),
   delete(Ns1,Y,Ns2),
   ldt_hf(Ns2,As,Hs).
 
% unlabelled digraph
dt_hf(Ns,[],Ns).
dt_hf(Ns,[a(X,Y)|As],[X>Y|Hs]) :-
   delete(Ns,X,Ns1),
   delete(Ns1,Y,Ns2),
   dt_hf(Ns2,As,Hs).
 
% we guess that if there is a '>' term then it's a digraph, else a graph
human_to_gterm(HF,digraph(Ns,As)) :- memberchk(_>_,HF), !, 
   hf_dt(HF,Ns1,As1), sort(Ns1,Ns), sort(As1,As).
human_to_gterm(HF,graph(Ns,Es)) :- 
   hf_gt(HF,Ns1,Es1), sort(Ns1,Ns), sort(Es1,Es).
% remember: sort/2 removes duplicates!
 
hf_gt([],[],[]).
hf_gt([X-Y/I|Hs],[X,Y|Ns],[e(U,V,I)|Es]) :- !, 
   sort0([X,Y],[U,V]), hf_gt(Hs,Ns,Es).
hf_gt([X-Y|Hs],[X,Y|Ns],[e(U,V)|Es]) :- !,
   sort0([X,Y],[U,V]), hf_gt(Hs,Ns,Es).
hf_gt([H|Hs],[H|Ns],Es) :- hf_gt(Hs,Ns,Es).
 
hf_dt([],[],[]).
hf_dt([X>Y/I|Hs],[X,Y|Ns],[a(X,Y,I)|As]) :- !, 
   hf_dt(Hs,Ns,As).
hf_dt([X>Y|Hs],[X,Y|Ns],[a(X,Y)|As]) :- !,
   hf_dt(Hs,Ns,As).
hf_dt([H|Hs],[H|Ns],As) :-  hf_dt(Hs,Ns,As).
 
sort0([X,Y],[X,Y]) :- X @=< Y, !.
sort0([X,Y],[Y,X]) :- X @> Y.
 
% tests ------------------------------------------------------------------
 
testdata([b-c, f-c, g-h, d, f-b, k-f, h-g]).
testdata([s > r, t, u > r, s > u, u > s, v > u]).
testdata([b-c/5, f-c/9, g-h/12, d, f-b/13, k-f/3, h-g/7]).
testdata([p>q/9, m>q/7, k, p>m/5]).
testdata([a,b(4711),c]).
testdata([a-b]).
testdata([]).
 
test :- 
   testdata(H1),
   write(H1), nl,
   human_gterm(H1,G1),
   alist_gterm(Type,AL,G1), 
   alist_gterm(Type,AL,G2),
   human_gterm(H2,G2),
   human_gterm(H2,G1),
   write(G1), nl, nl,
   fail.
test.

p6_02.pl

p6_02.pl
% 6.02 (**) Path from one node to another one
 
% path(G,A,B,P) :- P is a (acyclic) path from node A to node B in the graph G.
%   G is given in graph-term form.
%   (+,+,+,?)
 
:- ensure_loaded(p6_01).  % conversions
 
path(G,A,B,P) :- path1(G,A,[B],P).
 
path1(_,A,[A|P1],[A|P1]).
path1(G,A,[Y|P1],P) :- 
   adjacent(X,Y,G), \+ memberchk(X,[Y|P1]), path1(G,A,[X,Y|P1],P).
 
% A useful predicate: adjacent/3
 
adjacent(X,Y,graph(_,Es)) :- member(e(X,Y),Es).
adjacent(X,Y,graph(_,Es)) :- member(e(Y,X),Es).
adjacent(X,Y,graph(_,Es)) :- member(e(X,Y,_),Es).
adjacent(X,Y,graph(_,Es)) :- member(e(Y,X,_),Es).
adjacent(X,Y,digraph(_,As)) :- member(a(X,Y),As).
adjacent(X,Y,digraph(_,As)) :- member(a(X,Y,_),As).

p6_03.pl

p6_03.pl
% 6.03 (*) Cycle from a given node
 
% cycle(G,A,P) :- P is a closed path starting at node A in the graph G.
%    G is given in graph-term form.
%    (+,+,?)
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_02).  % adjacent/3 and path/4
 
cycle(G,A,P) :- 
   adjacent(B,A,G), path(G,A,B,P1), length(P1,L), L > 2, append(P1,[A],P).

p6_04.dat

p6_04.dat
graph([a, b, c, d, e, f, g, h], [e(a, b), e(a, d), e(b, c), e(b, e), e(c, e), e(d, e), e(d, f), e(d, g), e(e, h), e(f, g), e(g, h)]).

p6_04.pl

p6_04.pl
% 6.04 (**) Construct all spanning trees 
 
% s_tree(G,T) :- T is a spanning tree of the graph G
%    (graph-term graph-term) (+,?)
 
:- ensure_loaded(p6_01).  % conversions
 
s_tree(graph([N|Ns],GraphEdges),graph([N|Ns],TreeEdges)) :- 
   transfer(Ns,GraphEdges,TreeEdgesUnsorted),
   sort(TreeEdgesUnsorted,TreeEdges).
 
% transfer(Ns,GEs,TEs) :- transfer edges from GEs (graph edges)
%    to TEs (tree edges) until the list NS of still unconnected tree nodes
%    becomes empty. An edge is accepted if and only if one end-point is 
%    already connected to the tree and the other is not.
 
transfer([],_,[]).
transfer(Ns,GEs,[GE|TEs]) :- 
   select(GE,GEs,GEs1),        % modified 15-May-2001
   incident(GE,X,Y),
   acceptable(X,Y,Ns),
   delete(Ns,X,Ns1),
   delete(Ns1,Y,Ns2),
   transfer(Ns2,GEs1,TEs).
 
incident(e(X,Y),X,Y).
incident(e(X,Y,_),X,Y).
 
acceptable(X,Y,Ns) :- memberchk(X,Ns), \+ memberchk(Y,Ns), !.
acceptable(X,Y,Ns) :- memberchk(Y,Ns), \+ memberchk(X,Ns).
 
% An almost trivial use of the predicate s_tree/2 is the following
% tree tester predicate:
 
% is_tree(G) :- the graph G is a tree
is_tree(G) :- s_tree(G,G), !.
 
 
% Another use is the following connectivity tester:
 
% is_connected(G) :- the graph G is connected
is_connected(G) :- s_tree(G,_), !.
 
% Example graph p6_04.dat
 
test :-  
   see('p6_04.dat'), read(G), seen,
   human_gterm(H,G),
   write(H), nl, 
   setof(T,s_tree(G,T),Ts), length(Ts,N),
   write(N).

p6_05.dat

p6_05.dat
graph([a, b, c, d, e, f, g, h], [e(a, b, 5), e(a, d, 3), e(b, c, 2), e(b, e, 4), e(c, e, 6), e(d, e, 7), e(d, f, 4), e(d, g, 3), e(e, h, 5), e(f, g, 4), e(g, h, 1)]).

p6_05.pl

p6_05.pl
% 6.05 (**) Construct the minimal spanning tree of a labelled graph 
 
% ms_tree(G,T,S) :- T is a minimal spanning tree of the graph G.
%    S is the sum of the edge values. Prim's algorithm.
%    (graph-term graph-term) (+,?)
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_04).  % transfer/3, incident/3, and accept/3
 
ms_tree(graph([N|Ns],GraphEdges),graph([N|Ns],TreeEdges),Sum) :- 
   predsort(compare_edge_values,GraphEdges,GraphEdgesSorted),
   transfer(Ns,GraphEdgesSorted,TreeEdgesUnsorted),
   sort(TreeEdgesUnsorted,TreeEdges),
   edge_sum(TreeEdges,Sum).
 
compare_edge_values(Order,e(X1,Y1,V1),e(X2,Y2,V2)) :- 
	compare(Order,V1+X1+Y1,V2+X2+Y2).
 
edge_sum([],0).
edge_sum([e(_,_,V)|Es],S) :- edge_sum(Es,S1), S is S1 + V. 
 
% Example graph p6_05.dat
 
test :-  
   see('p6_05.dat'), read(G), seen,
   human_gterm(H,G),
   write(H), nl, 
   ms_tree(G,T,S),
   human_gterm(TH,T),
   write(S), nl,
   write(TH).

p6_06.pl

p6_06.pl
% 6.06 (**) Graph isomorphism
 
:- ensure_loaded(p6_01).  % conversions
 
% This is a solution for graphs only. It is not difficult to write the 
% corresponding predicates for digraphs.
 
% isomorphic(G1,G2) :- the graphs G1 and G2 are isomorphic.
 
isomorphic(G1,G2) :- isomorphic(G1,G2,_). 
 
% isomorphic(G1,G2,Iso) :- the graphs G1 and G2 are isomorphic. 
%    Iso is a list representing the bijection between the node 
%    sets of the graphs. It is an open-ended list and contains 
%    a term i(X,Y) for each pair of corresponding nodes
 
isomorphic(graph(Ns1,Es1),graph(Ns2,Es2),Iso) :-
   append(Es1,Ns1,List1),
   append(Es2,Ns2,List2),
   isomo(List1,List2,Iso).
 
% isomo(List1,List2,Iso) :- the graphs represented by List1 and 
%    List2 are isomorphic. 
 
isomo([],[],_) :- !.
isomo([X|Xrest],Ys,Iso) :- 
   select(Ys,Y,Yrest),
   iso(X,Y,Iso),
   isomo(Xrest,Yrest,Iso).
 
% iso(E1,E2,Iso) :- the edge E1 in one graph corresponds 
%    to the edge E2 in the other. Note that edges are undirected.
% iso(N1,N2,Iso) :- matches isolated vertices.
 
iso(E1,E2,Iso) :- 
   edge(E1,X1,Y1), edge(E2,X2,Y2), 
   bind(X1,X2,Iso), bind(Y1,Y2,Iso).
iso(E1,E2,Iso) :- 
   edge(E1,X1,Y1), edge(E2,X2,Y2), 
   bind(X1,Y2,Iso), bind(Y1,X2,Iso).
iso(N1,N2,Iso) :-
   \+ edge(N1,_,_),\+ edge(N2,_,_),     % isolated vertices
   bind(N1,N2,Iso).
 
edge(e(X,Y),X,Y).
edge(e(X,Y,_),X,Y).
 
% bind(X,Y,Iso) :- it is possible to "bind X to Y" as part of the
%    bijection Iso; i.e. a term i(X,Y) is already in the list Iso,
%    or it can be added to it without violating the rules. Note that
%    bind(X,Y,Iso) makes sure that both X and Y are really "new"
%    if i(X,Y) is added to Iso.
 
bind(X,Y,Iso) :- memberchk(i(X,Y0),Iso), nonvar(Y0), !, Y = Y0.
bind(X,Y,Iso) :- memberchk(i(X0,Y),Iso), X = X0.
 
% ----------------------------------------------------------------------
 
test(1) :-
   human_gterm([f-e,e-d,e-g,c-e,c-b,a-b,c-d,beta],G1),
   human_gterm([6-3,6-4,3-4,alfa,4-5,7-4,6-2,1-2],G2),
   isomorphic(G1,G2,Iso), write(Iso).
test(2) :-
   human_gterm([f-e,e-d,e-g,c-e,c-b,a-b,c-d,beta],G1),
   human_gterm([6-3,6-4,3-4,4-5,7-4,6-2,1],G2),
   isomorphic(G1,G2,Iso), write(Iso).
test(3) :-
   human_gterm([a-b,c-d,e,d-f],G1),
   human_gterm([1-2,1-3,5,4-6],G2),
   isomorphic(G1,G2,Iso), write(Iso).

p6_07.pl

p6_07.pl
% 6.07 (**) Node degree and graph coloration
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_02).  % adjacent/3
 
% a) Write a predicate degree(Graph,Node,Deg) that determines the degree 
% of a given node. 
 
% degree(Graph,Node,Deg) :- Deg is the degree of the node Node in the
%    graph Graph.
%    (graph-term, node, integer), (+,+,?).
 
degree(graph(Ns,Es),Node,Deg) :- 
   alist_gterm(graph,AList,graph(Ns,Es)),
   member(n(Node,AdjList),AList), !,
   length(AdjList,Deg).
 
% --------------------------------------------------------------------------
 
% b) Write a predicate that generates a list of all nodes of a graph 
% sorted according to decreasing degree.
 
% degree_sorted_nodes(Graph,Nodes) :- Nodes is the list of the nodes
%    of the graph Graph, sorted according to decreasing degree.
 
degree_sorted_nodes(graph(Ns,Es),DSNodes) :- 
   alist_gterm(graph,AList,graph(Ns,Es)),  
   predsort(compare_degree,AList,AListDegreeSorted),
   reduce(AListDegreeSorted,DSNodes).
 
compare_degree(Order,n(N1,AL1),n(N2,AL2)) :-
   length(AL1,D1), length(AL2,D2),
   compare(Order,D2+N1,D1+N2).
 
% Note: compare(Order,D2+N1,D1+N2) sorts the nodes according to 
% decreasing degree, but alphabetically if the degrees are equal. Cool!
 
reduce([],[]).
reduce([n(N,_)|Ns],[N|NsR]) :- reduce(Ns,NsR).
 
% --------------------------------------------------------------------------
 
% c) Use Welch-Powell's algorithm to paint the nodes of a graph in such 
% a way that adjacent nodes have different colors.
 
% Use Welch-Powell's algorithm to paint the nodes of a graph
% in such a way that adjacent nodes have different colors.
 
paint(Graph,ColoredNodes) :-
   degree_sorted_nodes(Graph,DSNs),
   paint_nodes(Graph,DSNs,[],1,ColoredNodes).
 
% paint_nodes(Graph,Ns,AccNodes,Color,ColoNodes) :- paint the remaining
%    nodes Ns with a color number Color or higher. AccNodes is the set
%    of nodes already colored. Return the result in ColoNodes.
%    (graph-term,node-list,c-node-list,integer,c-node-list)
%    (+,+,+,+,-) 
paint_nodes(_,[],ColoNodes,_,ColoNodes) :- !.
paint_nodes(Graph,Ns,AccNodes,Color,ColoNodes) :-
   paint_nodes(Graph,Ns,Ns,AccNodes,Color,ColoNodes).
 
% paint_nodes(Graph,DSNs,Ns,AccNodes,Color,ColoNodes) :- paint the
%    nodes in Ns with a fixed color number Color, if possible.
%    If Ns is empty, continue with the next color number.
%    AccNodes is the set of nodes already colored. 
%    Return the result in ColoNodes.
%    (graph-term,node-list,c-node-list,c-node-list,integer,c-node-list)
%    (+,+,+,+,+,-) 
paint_nodes(Graph,Ns,[],AccNodes,Color,ColoNodes) :- !,
   Color1 is Color+1,
   paint_nodes(Graph,Ns,AccNodes,Color1,ColoNodes).
paint_nodes(Graph,DSNs,[N|Ns],AccNodes,Color,ColoNodes) :- 
   \+ has_neighbor(Graph,N,Color,AccNodes), !,
   delete(DSNs,N,DSNs1),
   paint_nodes(Graph,DSNs1,Ns,[c(N,Color)|AccNodes],Color,ColoNodes).
paint_nodes(Graph,DSNs,[_|Ns],AccNodes,Color,ColoNodes) :- 
   paint_nodes(Graph,DSNs,Ns,AccNodes,Color,ColoNodes).
 
has_neighbor(Graph,N,Color,AccNodes) :- 
   adjacent(N,X,Graph),
   memberchk(c(X,Color),AccNodes).

p6_08.pl

p6_08.pl
% 6.08 (**) Depth-first order graph traversal
 
% Write a predicate that generates a depth-first order graph
% traversal sequence. The starting point should be specified,
% and the output should be a list of nodes that are reachable from
% this starting point (in depth-first order).
 
% The main problem is that if we traverse the graph recursively,
% we must store the encountered nodes in such a way that they
% do not disappear during the backtrack step.
 
% In this solution we use the "recorded database" which is a
% more efficient alternative to the well-known assert/retract 
% mechanism. See the SWI-Prolog manuals for details.
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_02).  % adjacent/3
 
depth_first_order(Graph,Start,Seq) :- 
   (Graph = graph(Ns,_), !; Graph = digraph(Ns,_)),
   memberchk(Start,Ns),
   clear_rdb(dfo),
   recorda(dfo,Start),
   (dfo(Graph,Start); true),
   bagof(X,recorded(dfo,X),Seq).
 
dfo(Graph,X) :-
   adjacent(X,Y,Graph), 
   \+ recorded(dfo,Y),
   recordz(dfo,Y),
   dfo(Graph,Y).
 
clear_rdb(Key) :-
   recorded(Key,_,Ref), erase(Ref), fail.
clear_rdb(_).

p6_08a.pl

p6_08a.pl
% 6.08 (**) Depth-first order graph traversal (alternative solution)
 
% Write a predicate that generates a depth-first order graph
% traversal sequence. The starting point should be specified,
% and the output should be a list of nodes that are reachable from
% this starting point (in depth-first order).
 
% The main problem is that if we traverse the graph recursively,
% we must store the encountered nodes in such a way that they
% do not disappear during the backtrack step.
 
% In this solution we use the "recorded database" which is a
% more efficient alternative to the well-known assert/retract 
% mechanism. See the SWI-Prolog manuals for details.
 
% Alternative solution using acjacency list
 
:- ensure_loaded(p6_01).  % conversions
 
depth_first_order(Graph,Start,Seq) :- 
   alist_gterm(_,Alist,Graph),
   clear_rdb(dfo),
   dfo(Alist,Start),
   bagof(X,recorded(dfo,X),Seq).
 
dfo(_,X) :- recorded(dfo,X).
dfo(Alist,X) :-
   \+ recorded(dfo,X),
   recordz(dfo,X),
   memberchk(n(X,AdjNodes),Alist),
   Pred =.. [dfo,Alist],        % see remark below
   checklist(Pred,AdjNodes).
 
clear_rdb(Key) :-
   recorded(Key,_,Ref), erase(Ref), fail.
clear_rdb(_).
 
% The construction of the predicate Pred and the use of the checklist/2
% predefined predicate may seem strange at first. It is equivalent to 
% the following construction:
%
% dfo(_,X) :- recorded(dfo,X).
% dfo(Alist,X) :-
%    \+ recorded(dfo,X),
%    recordz(dfo,X),
%    memberchk(n(X,AdjNodes),Alist),
%    dfo_list(Alist,AdjNodes).
%
% dfo_list(_,[]).
% dfo_list(Alist,[A|As]) :- dfo(Alist,A), dfo_list(Alist,As).

p6_09.pl

p6_09.pl
% 6.09 (**) Connected components
 
%  Write a predicate that splits a graph into its connected components.
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_02).  % path/4
 
% connected_components(G,Gs) :- Gs is the list of the connected components
%    of the graph G (only for graphs, not for digraphs!)
%    (gterm, list-of-gterms), (+,-)
 
connected_components(graph([],[]),[]) :- !.
connected_components(graph(Ns,Es),[graph(Ns1,Es1)|Gs]) :-
   Ns = [N|_],
   component(graph(Ns,Es),N,graph(Ns1,Es1)),
   subtract(Ns,Ns1,NsR),
   subgraph(graph(Ns,Es),graph(NsR,EsR)),
   connected_components(graph(NsR,EsR),Gs).
 
component(graph(Ns,Es),N,graph(Ns1,Es1)) :-
   Pred =..[is_path,graph(Ns,Es),N],
   sublist(Pred,Ns,Ns1),
   subgraph(graph(Ns,Es),graph(Ns1,Es1)).
 
is_path(Graph,A,B) :- path(Graph,A,B,_).
 
% subgraph(G,G1) :- G1 is a subgraph of G
subgraph(graph(Ns,Es),graph(Ns1,Es1)) :-
   subset(Ns1,Ns),
   Pred =.. [edge_is_compatible,Ns1],
   sublist(Pred,Es,Es1).
 
edge_is_compatible(Ns1,Z) :- 
   (Z = e(X,Y),!; Z = e(X,Y,_)),
   memberchk(X,Ns1), 
   memberchk(Y,Ns1). 

p6_09a.pl

p6_09a.pl
% 6.09 (**) Connected components (alternative solution)
 
%  Write a predicate that splits a graph into its connected components.
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_08).  % depth_first_order/3
 
% connected_components(G,Gs) :- Gs is the list of the connected components
%    of the graph G (only for graphs, not for digraphs!)
%    (gterm, list-of-gterms), (+,-)
 
connected_components(graph([],[]),[]) :- !.
connected_components(graph(Ns,Es),[graph(Ns1,Es1)|Gs]) :-
   Ns = [N|_],
   component(graph(Ns,Es),N,graph(Ns1,Es1)),
   subtract(Ns,Ns1,NsR),
   subgraph(graph(Ns,Es),graph(NsR,EsR)),
   connected_components(graph(NsR,EsR),Gs).
 
component(graph(Ns,Es),N,graph(Ns1,Es1)) :-
   depth_first_order(graph(Ns,Es),N,Seq),
   sort(Seq,Ns1),
   subgraph(graph(Ns,Es),graph(Ns1,Es1)).
 
% subgraph(G,G1) :- G1 is a subgraph of G
subgraph(graph(Ns,Es),graph(Ns1,Es1)) :-
   subset(Ns1,Ns),
   Pred =.. [edge_is_compatible,Ns1],
   sublist(Pred,Es,Es1).
 
edge_is_compatible(Ns1,Z) :- 
   (Z = e(X,Y),!; Z = e(X,Y,_)),
   memberchk(X,Ns1), 
   memberchk(Y,Ns1). 

p6_10.pl

p6_10.pl
% 6.10 (**) Bipartite graphs
 
%  Write a predicate that finds out whether a given graph is bipartite.
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_09).  % connected_components/2
 
% is_bipartite(G) :- the graph G is bipartite
 
is_bipartite(G) :- 
   connected_components(G,Gs),
   checklist(is_bi,Gs).
 
is_bi(graph(Ns,Es)) :- Ns = [N|_], 
   alist_gterm(_,Alist,graph(Ns,Es)),
   paint(Alist,[],red,N).
 
% paint(Alist,ColoredNodes,Color,ActualNode)
% (+,+,+,+)
 
paint(_,CNs,Color,N) :-  
   memberchk(c(N,Color),CNs), !.
paint(Alist,CNs,Color,N) :- 
   \+ memberchk(c(N,_),CNs),
   other_color(Color,OtherColor),
   memberchk(n(N,AdjNodes),Alist),
   Pred =.. [paint,Alist,[c(N,Color)|CNs],OtherColor],
   checklist(Pred,AdjNodes).
 
other_color(red,blue).
other_color(blue,red).

p6_11.pl

p6_11.pl
% 6.11 (**) Generate K-regular simple graphs with N nodes. 
% 
% In a K-regular graph all nodes have a degree of K.
 
% k_regular(K,N,Graph) :- Graph is a K-regular simple graph with N nodes.
% The graph is in graph-term form. The nodes are identified by numbers 1..N.
% All solutions can be generated via backtracking. 
% (+,+,?)  (int,int,graph(nodes,edges))
%
% Note: The predicate generates the Nodes list and a list of terms u(V,F)
% which indicates, for each node V, the number F of unused (or free) edges. 
% For example: with N=5, K=3 the algorithm starts with Nodes=[1,2,3,4,5]
% and UList=[u(1,3),u(2,3),u(3,3),u(4,3),u(5,3)].
 
k_regular(K,N,graph(Nodes,Edges)) :-
   range(1,N,Nodes),                         % generate Nodes list
   maplist(mku(K),Nodes,UList),              % generate initial UList
   k_reg(UList,0,Edges).
 
mku(K,V,u(V,K)).
 
% k_reg(UList,MinY,Edges) :- Edges is a list of e(X,Y) terms where u(X,UX)
% is the first element in UList and u(Y,UY) is another element of UList,
% with Y > MinY. Both UX and UY, which indicate the number of free edges
% of X and Y, respectively, must be greater than 0. They are both reduced
% by 1 for the recursion if the edge e(X,Y) is chosen. 
% (+,+,-) (ulist,int,elist)
 
k_reg([],_,[]). 
k_reg([u(_,0)|Us],_,Edges) :- !, k_reg(Us,0,Edges).   % no more unused edges
k_reg([u(1,UX)|Us],MinY,[e(1,Y)|Edges]) :- UX > 0,    % special case X = 1
   pick(Us,Y,MinY,Us1), !,                    % pick a Y
   UX1 is UX - 1,                             % reduce number of unused edges
   k_reg([u(1,UX1)|Us1],Y,Edges).
k_reg([u(X,UX)|Us],MinY,[e(X,Y)|Edges]) :- X > 1, UX > 0,
   pick(Us,Y,MinY,Us1),                       % pick a Y
   UX1 is UX - 1,                             % reduce number of unused edges
   k_reg([u(X,UX1)|Us1],Y,Edges).
 
% pick(UList_in,Y,MinY,UList_out) :- there is an element u(Y,UY) in UList_in,
% Y is greater than MinY, and UY > 0. UList_out is obtained from UList_in
% by reducing UY by 1 in the term u(Y,_). This predicate delivers all
% possible values of Y via backtracking.
% (+,-,+,-) (ulist,int,int,ulist)
 
pick([u(Y,UY)|Us],Y,MinY,[u(Y,UY1)|Us]) :- Y > MinY, UY > 0, UY1 is UY - 1.
pick([U|Us],Y,MinY,[U|Us1]) :- pick(Us,Y,MinY,Us1).
 
% range(X,Y,Ls) :- Ls is the list of the integer numbers from X to Y.
% (+,+,?) (int,int,int_list)
 
range(B,B,[B]).
range(A,B,[A|L]) :- A < B, A1 is A + 1, range(A1,B,L).
 
:- dynamic solution/1.
 
% all_k_regular(K,N,Gs) :- Gs is the list of all (non-isomorphic)
% K-regular graphs with N nodes.
% (+,+,-) (int,int,list_of_graphs)
% Note: The predicate prints each new solution as a progress report.
% Use tell('/dev/null') to switch off the printing if you don't like it.
 
all_k_regular(K,N,_) :-
   retractall(solution(_)),
   k_regular(K,N,Graph),
   no_iso_solution(Graph),
   write(Graph), nl,
   assert(solution(Graph)),
   fail.
all_k_regular(_,_,Graphs) :- findall(G,solution(G),Graphs).
 
:- ensure_loaded(p6_06).  % load isomorphic/2
 
% no_iso_solution(Graph) :- there is no graph G in the solution/1 data base
% predicate which is isomorphic to Graph
 
no_iso_solution(Graph) :-
   solution(G), isomorphic(Graph,G), !, fail.
no_iso_solution(_).
 
% The rest of this program constructs a table of K-regular simple graphs
% with N nodes for N up to a maximum N and sensible values of K.
% Example:  ?- table(6).
 
table(Max) :-  
   nl, write('K-regular simple graphs with N nodes'), nl,
   table(3,Max).
 
table(N,Max) :- N =< Max, !,
   table(2,N,Max),
   N1 is N + 1,
   table(N1,Max).
table(_,_) :- nl. 
 
table(K,N,Max) :- K < N, !,
   tell('/dev/null'),
   statistics(inferences,I1),
   all_k_regular(K,N,Gs),
   length(Gs,NSol),    
   statistics(inferences,I2),
   NInf is I2 - I1,
   told,
   plural(NSol,Pl),
   writef('\nN = %w  K = %w   %w solution%w  (%w inferences)\n',[N,K,NSol,Pl,NInf]),
   checklist(print_graph,Gs),
   K1 is K + 1,
   table(K1,N,Max).
table(_,_,_) :- nl.
 
plural(X,' ') :- X < 2, !.
plural(_,'s').
 
:- ensure_loaded(p6_01).  % conversion human_gterm/2
 
print_graph(G) :- human_gterm(HF,G), write(HF), nl.
 

p6_11.txt

p6_11.txt
K-regular simple graphs with N nodes
 
N = 3  K = 2   1 solution   (69 inferences)
[1-2, 1-3, 2-3]
 
 
N = 4  K = 2   1 solution   (95 inferences)
[1-2, 1-3, 2-4, 3-4]
 
N = 4  K = 3   1 solution   (124 inferences)
[1-2, 1-3, 1-4, 2-3, 2-4, 3-4]
 
 
N = 5  K = 2   1 solution   (339 inferences)
[1-2, 1-3, 2-4, 3-5, 4-5]
 
N = 5  K = 3   0 solution   (261 inferences)
 
N = 5  K = 4   1 solution   (251 inferences)
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-5, 3-4, 3-5, 4-5]
 
 
N = 6  K = 2   2 solutions  (21198 inferences)
[1-2, 1-3, 2-3, 4-5, 4-6, 5-6]
[1-2, 1-3, 2-4, 3-5, 4-6, 5-6]
 
N = 6  K = 3   2 solutions  (38662 inferences)
[1-2, 1-3, 1-4, 2-3, 2-5, 3-6, 4-5, 4-6, 5-6]
[1-2, 1-3, 1-4, 2-5, 2-6, 3-5, 3-6, 4-5, 4-6]
 
N = 6  K = 4   1 solution   (4698 inferences)
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-6, 3-5, 3-6, 4-5, 4-6, 5-6]
 
N = 6  K = 5   1 solution   (546 inferences)
[1-2, 1-3, 1-4, 1-5, 1-6, 2-3, 2-4, 2-5, 2-6, 3-4, 3-5, 3-6, 4-5, 4-6, 5-6]
 
 
N = 7  K = 2   2 solutions  (150137 inferences)
[1-2, 1-3, 2-3, 4-5, 4-6, 5-7, 6-7]
[1-2, 1-3, 2-4, 3-5, 4-6, 5-7, 6-7]
 
N = 7  K = 3   0 solution   (7693 inferences)
 
N = 7  K = 4   2 solutions  (4088301 inferences)
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-5, 3-6, 3-7, 4-6, 4-7, 5-6, 5-7, 6-7]
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-6, 3-5, 3-7, 4-6, 4-7, 5-6, 5-7, 6-7]
 
N = 7  K = 5   0 solution   (4849 inferences)
 
N = 7  K = 6   1 solution   (1225 inferences)
[1-2, 1-3, 1-4, 1-5, 1-6, 1-7, 2-3, 2-4, 2-5, 2-6, 2-7, 3-4, 3-5, 3-6, 3-7, 4-5, 
4-6, 4-7, 5-6, 5-7, 6-7]
 
 
N = 8  K = 2   3 solutions  (2762047 inferences)
[1-2, 1-3, 2-3, 4-5, 4-6, 5-7, 6-8, 7-8]
[1-2, 1-3, 2-4, 3-4, 5-6, 5-7, 6-8, 7-8]
[1-2, 1-3, 2-4, 3-5, 4-6, 5-7, 6-8, 7-8]
 
N = 8  K = 3   6 solutions  (67636365 inferences)
[1-2, 1-3, 1-4, 2-3, 2-4, 3-4, 5-6, 5-7, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 2-3, 2-4, 3-5, 4-6, 5-7, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 2-3, 2-5, 3-6, 4-5, 4-7, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 2-3, 2-5, 3-6, 4-7, 4-8, 5-7, 5-8, 6-7, 6-8]
[1-2, 1-3, 1-4, 2-5, 2-6, 3-5, 3-7, 4-6, 4-7, 5-8, 6-8, 7-8]
[1-2, 1-3, 1-4, 2-5, 2-6, 3-5, 3-7, 4-6, 4-8, 5-8, 6-7, 7-8]
 
N = 8  K = 4   6 solutions  (338976076 inferences)
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-5, 3-6, 3-7, 4-6, 4-8, 5-7, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-6, 3-4, 3-7, 4-8, 5-6, 5-7, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-6, 3-5, 3-7, 4-6, 4-8, 5-7, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-6, 3-5, 3-7, 4-7, 4-8, 5-6, 5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 1-5, 2-3, 2-4, 2-6, 3-7, 3-8, 4-7, 4-8, 5-6, 5-7, 5-8, 6-7, 6-8]
[1-2, 1-3, 1-4, 1-5, 2-6, 2-7, 2-8, 3-6, 3-7, 3-8, 4-6, 4-7, 4-8, 5-6, 5-7, 5-8]
 
N = 8  K = 5   3 solutions  (259887137 inferences)
[1-2, 1-3, 1-4, 1-5, 1-6, 2-3, 2-4, 2-5, 2-6, 3-4, 3-7, 3-8, 4-7, 4-8, 5-6, 5-7, 
5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 1-5, 1-6, 2-3, 2-4, 2-5, 2-7, 3-4, 3-6, 3-8, 4-7, 4-8, 5-6, 5-7, 
5-8, 6-7, 6-8, 7-8]
[1-2, 1-3, 1-4, 1-5, 1-6, 2-3, 2-4, 2-5, 2-7, 3-6, 3-7, 3-8, 4-6, 4-7, 4-8, 5-6, 
5-7, 5-8, 6-8, 7-8]
 
N = 8  K = 6   1 solution   (742954 inferences)
[1-2, 1-3, 1-4, 1-5, 1-6, 1-7, 2-3, 2-4, 2-5, 2-6, 2-8, 3-4, 3-5, 3-7, 3-8, 4-6, 
4-7, 4-8, 5-6, 5-7, 5-8, 6-7, 6-8, 7-8]
 
N = 8  K = 7   1 solution   (2768 inferences)
[1-2, 1-3, 1-4, 1-5, 1-6, 1-7, 1-8, 2-3, 2-4, 2-5, 2-6, 2-7, 2-8, 3-4, 3-5, 3-6, 
3-7, 3-8, 4-5, 4-6, 4-7, 4-8, 5-6, 5-7, 5-8, 6-7, 6-8, 7-8]
 
 
N = 9  K = 2   4 solutions  (54627139 inferences)
[1-2, 1-3, 2-3, 4-5, 4-6, 5-6, 7-8, 7-9, 8-9]
[1-2, 1-3, 2-3, 4-5, 4-6, 5-7, 6-8, 7-9, 8-9]
[1-2, 1-3, 2-4, 3-4, 5-6, 5-7, 6-8, 7-9, 8-9]
[1-2, 1-3, 2-4, 3-5, 4-6, 5-7, 6-8, 7-9, 8-9]

p7_01.pl

p7_01.pl
% 7.01 (**) Eight queens problem
 
% This is a classical problem in computer science. The objective is to
% place eight queens on a chessboard so that no two queens are attacking 
% each other; i.e., no two queens are in the same row, the same column, 
% or on the same diagonal. We generalize this original problem by 
% allowing for an arbitrary dimension N of the chessboard. 
 
% We represent the positions of the queens as a list of numbers 1..N.
% Example: [4,2,7,3,6,8,5,1] means that the queen in the first column
% is in row 4, the queen in the second column is in row 2, etc.
% By using the permutations of the numbers 1..N we guarantee that
% no two queens are in the same row. The only test that remains
% to be made is the diagonal test. A queen placed at column X and 
% row Y occupies two diagonals: one of them, with number C = X-Y, goes
% from bottom-left to top-right, the other one, numbered D = X+Y, goes
% from top-left to bottom-right. In the test predicate we keep track
% of the already occupied diagonals in Cs and Ds.   
 
% The first version is a simple generate-and-test solution.
 
% queens_1(N,Qs) :- Qs is a solution of the N-queens problem
 
queens_1(N,Qs) :- range(1,N,Rs), permu(Rs,Qs), test(Qs).
 
% range(A,B,L) :- L is the list of numbers A..B
 
range(A,A,[A]).
range(A,B,[A|L]) :- A < B, A1 is A+1, range(A1,B,L).
 
% permu(Xs,Zs) :- the list Zs is a permutation of the list Xs
 
permu([],[]).
permu(Qs,[Y|Ys]) :- del(Y,Qs,Rs), permu(Rs,Ys).
 
del(X,[X|Xs],Xs).
del(X,[Y|Ys],[Y|Zs]) :- del(X,Ys,Zs).
 
% test(Qs) :- the list Qs represents a non-attacking queens solution
 
test(Qs) :- test(Qs,1,[],[]).
 
% test(Qs,X,Cs,Ds) :- the queens in Qs, representing columns X to N,
% are not in conflict with the diagonals Cs and Ds
 
test([],_,_,_).
test([Y|Ys],X,Cs,Ds) :- 
	C is X-Y, \+ memberchk(C,Cs),
	D is X+Y, \+ memberchk(D,Ds),
	X1 is X + 1,
	test(Ys,X1,[C|Cs],[D|Ds]).
 
%--------------------------------------------------------------
 
% Now, in version 2, the tester is pushed completely inside the
% generator permu.
 
queens_2(N,Qs) :- range(1,N,Rs), permu_test(Rs,Qs,1,[],[]).
 
permu_test([],[],_,_,_).
permu_test(Qs,[Y|Ys],X,Cs,Ds) :- 
	del(Y,Qs,Rs), 
	C is X-Y, \+ memberchk(C,Cs),
	D is X+Y, \+ memberchk(D,Ds),
	X1 is X+1,
	permu_test(Rs,Ys,X1,[C|Cs],[D|Ds]).

p7_02.pl

p7_02.pl
% 7.02 (**) Knight's tour
% Another famous problem is this one: How can a knight jump on an
% NxN chessboard in such a way that it visits every square exactly once?
 
% knights(N,Knights) :- Knights is a knight's tour on a NxN chessboard 
 
knights(N,Knights) :- M is N*N-1,  knights(N,M,[1/1],Knights).
 
% closed_knights(N,Knights) :- Knights is a knight's tour on a NxN 
% chessboard which ends at the same square where it begun.
 
closed_knights(N,Knights) :- 
   knights(N,Knights), Knights = [X/Y|_], jump(N,X/Y,1/1). 
 
% knights(N,M,Visited,Knights) :- the list of squares Visited must be
% extended by M further squares to give the solution Knights of the
% NxN chessboard knight's tour problem. 
 
knights(_,0,Knights,Knights).
knights(N,M,Visited,Knights) :-
   Visited = [X/Y|_],
   jump(N,X/Y,U/V),
   \+ memberchk(U/V,Visited),
   M1 is M-1,
   knights(N,M1,[U/V|Visited],Knights).
 
% jumps on an NxN chessboard from square A/B to C/D
jump(N,A/B,C/D) :- 
   jump_dist(X,Y), 
   C is A+X, C > 0, C =< N,
   D is B+Y, D > 0, D =< N.
 
% jump distances
jump_dist(1,2).
jump_dist(2,1).
jump_dist(2,-1).
jump_dist(1,-2).
jump_dist(-1,-2).
jump_dist(-2,-1).
jump_dist(-2,1).
jump_dist(-1,2).
 
 
% A more user-friendly presentation of the results ------------------------
 
show_knights(N) :- 
   get_time(Time), convert_time(Time,Tstr),
   write('Start: '), write(Tstr), nl, nl,
   knights(N,Knights), nl, show(N,Knights).
 
show(N,Knights) :-
   get_time(Time), convert_time(Time,Tstr),
   write(Tstr), nl, nl,
   length(Chessboard,N),
   Pred =.. [invlength,N],
   checklist(Pred,Chessboard),
   fill_chessboard(Knights,Chessboard,1),
   checklist(show_row,Chessboard),
   nl, fail.
 
invlength(N,L) :- length(L,N).
 
show_row([]) :- nl.
show_row([S|Ss]) :- writef('%3r',[S]), show_row(Ss). 
 
fill_chessboard([],_,_).
fill_chessboard([X/Y|Ks],Chessboard,K) :-
   nth1(Y,Chessboard,Row),
   nth1(X,Row,K),
   K1 is K+1,
   fill_chessboard(Ks,Chessboard,K1).
 
% --------------------------------------------------------------------------

p7_03.pl

p7_03.pl
% 7.03 (***) Von Koch's conjecture
 
% Von Koch's Conjecture: Given a tree with N nodes (and hence N-1 edges).
% Find a way to enumerate the nodes from 1 to n and, accordingly, the
% edges from 1 to N-1 in such a way, that for each edge K the difference
% of its node numbers equals to K. The conjecture is that this is always
% possible.
 
% Example:      *      Solution:     4    Note that the node number 
%              /                    /     differences of adjacent nodes
%        * -- *               3 -- 1      are just the numbers 1,2,3,4
%        |     \              |     \     which can be used to enumerate
%        *      *             2      5    the edges.
 
:- ensure_loaded(p6_01).  % conversions
:- ensure_loaded(p6_04).  % is_tree
 
% vonkoch(G,Enum) :- the nodes of the graph G can be enumerated
%    as described in Enum. Enum is a list of pairs X/K, where X
%    is a node and K the corresponding number. 
 
vonkoch(Graph,Enum) :- 
   is_tree(Graph),            % check before doing too much work!
   Graph = graph(Ns,_),
   length(Ns,N),
   human_gterm(Hs,Graph),
   vonkoch(Hs,N,Enum).
 
vonkoch([IsolatedNode],1,[IsolatedNode/1|_]).  % special case
vonkoch(EdgeList,N,Enum) :-
   range(1,N,NodeNumberList), 
   N1 is N-1,range(1,N1,EdgeNumberList),
   bind(EdgeList,NodeNumberList,EdgeNumberList,Enum).
 
% The tree is given as an edge list; e.g. [d-a,a-g,b-c,e-f,b-e,a-b].
% Our problem is to find a bijection between the nodes (a,b,c,...) and
% the integer numbers 1..N which is compatible with the condition
% cited above. In order to construct this bijection, we use an open-
% ended list Enum; and we scan the given edge list.
 
bind([],_,_,_) :- !.
bind([V1-V2|Es],NodeNumbers,EdgeNumbers,Enum) :-
   bind_node(V1,K1,NodeNumbers,NodeNumbers1,Enum), 
   bind_node(V2,K2,NodeNumbers1,NodeNumbers2,Enum), 
   D is abs(K1-K2), select(D,EdgeNumbers,EdgeNumbers1), % modif 15-May-2001
   bind(Es,NodeNumbers2,EdgeNumbers1,Enum).
 
% bind_node(V,K,NodeNumsIn,NodeNumsOut,Enum) :-  
% V/K is an element of the list Enum, and there is no V1 \= V 
% such that V1/K is in Enum, and there is no K1 \= K such that 
% V =:= K1 is in Enum. In the case V gets a new number, it is
% selected from the set NodeNumsIn; what remains is NodeNumsOut.
% (node,integer,integer-list,integer-list,enumeration)  (+,?,+,-,?)
 
bind_node(V,K,NodeNumbers,NodeNumbers,Enum) :- 
   memberchk(V/K1,Enum), number(K1), !, K = K1.
bind_node(V,K,NodeNumbers,NodeNumbers1,Enum) :- 
   select(K,NodeNumbers,NodeNumbers1), memberchk(V/K,Enum).
 
% range(A,B,L) :- L is the list of numbers A..B
 
range(B,B,[B]) :- !.
range(A,B,[A|L]) :- A < B, A1 is A+1, range(A1,B,L).
 
% test suite ------------------------------------------------------------
 
test(K) :-
   test_tree(K,TH),
   write(TH), nl,  
   human_gterm(TH,T),
   vonkoch(T,Enum),
   write(Enum).
 
test_tree(1,[a-b,b-c,c-d,c-e]).
test_tree(2,[d-a,a-g,b-c,e-f,b-e,a-b]).
test_tree(3,[g-a,i-a,a-h,b-a,k-d,c-d,m-q,p-n,q-n,e-q,e-c,f-c,c-a]).
test_tree(4,[a]).
 
% Solution for the tree given in the problem statement:
%
% ?- test(3).
% [g-a, i-a, a-h, b-a, k-d, c-d, m-q, p-n, q-n, e-q, e-c, f-c, c-a]
% [a/1, b/2, c/12, g/11, h/13, i/14, d/3, e/4, f/5, k/8, q/10, m/6, n/7, p/9|_]
%
% Remark: In most cases, there are many different solutions.

p7_04.pl

p7_04.pl
% 7.04 (***)  Arithmetic puzzle: Given a list of integer numbers, 
% find a correct way of inserting arithmetic signs such that 
% the result is a correct equation. The idea to the problem
% is from Roland Beuret. Thanx.
 
% Example: With the list of  numbers [2,3,5,7,11] we can form the
% equations  2-3+5+7 = 11  or  2 = (3*5+7)/11 (and ten others!).
 
% equation(L,LT,RT) :- L is the list of numbers which are the leaves
%    in the arithmetic terms LT and RT - from left to right. The 
%    arithmetic evaluation yields the same result for LT and RT.
 
equation(L,LT,RT) :-
   split(L,LL,RL),              % decompose the list L
   term(LL,LT),                 % construct the left term
   term(RL,RT),                 % construct the right term
   LT =:= RT.                   % evaluate and compare the terms
 
% term(L,T) :- L is the list of numbers which are the leaves in
%    the arithmetic term T - from left to right.
 
term([X],X).                    % a number is a term in itself
% term([X],-X).                   % unary minus
term(L,T) :-                    % general case: binary term
   split(L,LL,RL),              % decompose the list L
   term(LL,LT),                 % construct the left term
   term(RL,RT),                 % construct the right term
   binterm(LT,RT,T).            % construct combined binary term
 
% binterm(LT,RT,T) :- T is a combined binary term constructed from
%    left-hand term LT and right-hand term RT
 
binterm(LT,RT,LT+RT).
binterm(LT,RT,LT-RT).
binterm(LT,RT,LT*RT).
binterm(LT,RT,LT/RT) :- RT =\= 0.   % avoid division by zero
 
% split(L,L1,L2) :- split the list L into non-empty parts L1 and L2
%    such that their concatenation is L
 
split(L,L1,L2) :- append(L1,L2,L), L1 = [_|_], L2 = [_|_].
 
% do(L) :- find all solutions to the problem as given by the list of
%    numbers L, and print them out, one solution per line.
 
do(L) :- 
   equation(L,LT,RT),
      writef('%w = %w\n',[LT,RT]),
   fail.
do(_).
 
 
% Try the following goal:   ?- do([2,3,5,7,11]).

p7_05.pl

p7_05.pl
% 7.05 (**) English number words
% On financial documents, like cheques, numbers must sometimes be 
% written in full words. Example: 175 must be written as one-seven-five.
% Write a predicate full_words/1 to print (non-negative) integer numbers
% in full words.
 
% full_words(N) :- print the number N in full words (English)
% (non-negative integer) (+)
 
full_words(0) :- !, write(zero), nl.
full_words(N) :- integer(N), N > 0, full_words1(N), nl.
 
full_words1(0) :- !.
full_words1(N) :- N > 0,
   Q is N // 10, R is N mod 10,
   full_words1(Q), numberword(R,RW), hyphen(Q), write(RW).
 
hyphen(0) :- !.
hyphen(Q) :- Q > 0, write('-'). 
 
numberword(0,zero).
numberword(1,one).
numberword(2,two).
numberword(3,three).
numberword(4,four).
numberword(5,five).
numberword(6,six).
numberword(7,seven).
numberword(8,eight).
numberword(9,nine).

p7_06.pl

p7_06.pl
% 7.06 (**) Syntax checker for Ada identifiers
 
% A purely recursive syntax is:
%
% <identifier> ::= <letter> <rest>
%
% <rest> ::=  | <optional_underscore> <letter_or_digit> <rest>
%
% <optional_underscore> ::=  | '_'
%
% <letter_or_digit> ::= <letter> | <digit>
 
% identifier(Str) :- Str is a legal Ada identifier
%    (atom) (+)
 
identifier(S) :- atom(S), atom_chars(S,L), identifier(L).
 
identifier([X|L]) :- char_type(X,alpha), rest(L).
 
rest([]) :- !.
rest(['_',X|L]) :- !, letter_or_digit(X), rest(L).
rest([X|L]) :- letter_or_digit(X), rest(L).
 
letter_or_digit(X) :- char_type(X,alpha), !.
letter_or_digit(X) :- char_type(X,digit).
 
% Try also a solution with difference lists!
% See p7_06a.pl

p7_06a.pl

p7_06a.pl
% 7.06 (**) Syntax checker for Ada identifiers (Difference lists)
 
% A purely recursive syntax is:
%
% <identifier> ::= <letter> <rest>
%
% <rest> ::=  | <optional_underscore> <letter_or_digit> <rest>
%
% <optional_underscore> ::=  | '_'
%
% <letter_or_digit> ::= <letter> | <digit>
 
% identifier(Str) :- Str is a legal Ada identifier
%    (atom) (+)
 
identifier(S) :- atom(S), atom_chars(S,L), identifier(L-[]).
 
identifier([X|L]-R) :- char_type(X,alpha), rest(L-R).
 
rest(T-T) :- !.
rest(L-R) :- 
   optional_underscore(L-L1),
   letter_or_digit(L1-L2),
   rest(L2-R).
 
optional_underscore(['_'|R]-R) :- !.
optional_underscore(T-T).
 
letter_or_digit([X|R]-R) :- char_type(X,alpha), !.
letter_or_digit([X|R]-R) :- char_type(X,digit).
 
% This solution with difference lists is not more elegant as the 
% simple solution with ordinary lists (see p7_06.pl), because the
% parsing is done by always removing just one or two characters
% from the head of the list. Take this as an easy exercise!

p7_07.pl

p7_07.pl
%  7.07 (**) Sudoku
%  
%  Sudoku puzzles go like this:  
 
%   Problem statement                Solution
 
%    .  .  4 | 8  .  . | .  1  7     9  3  4 | 8  2  5 | 6  1  7	     
%            |         |                     |         |
%    6  7  . | 9  .  . | .  .  .     6  7  2 | 9  1  4 | 8  5  3
%            |         |                     |         |
%    5  .  8 | .  3  . | .  .  4     5  1  8 | 6  3  7 | 9  2  4
%    --------+---------+--------     --------+---------+--------
%    3  .  . | 7  4  . | 1  .  .     3  2  5 | 7  4  8 | 1  6  9
%            |         |                     |         |
%    .  6  9 | .  .  . | 7  8  .     4  6  9 | 1  5  3 | 7  8  2
%            |         |                     |         |
%    .  .  1 | .  6  9 | .  .  5     7  8  1 | 2  6  9 | 4  3  5
%    --------+---------+--------     --------+---------+--------
%    1  .  . | .  8  . | 3  .  6     1  9  7 | 5  8  2 | 3  4  6
%            |         |                     |         |
%    .  .  . | .  .  6 | .  9  1     8  5  3 | 4  7  6 | 2  9  1
%            |         |                     |         |
%    2  4  . | .  .  1 | 5  .  .     2  4  6 | 3  9  1 | 5  7  8
 
% Every spot in the puzzle belongs to a (horizontal) row and a (vertical)
% column, as well as to one single 3x3 square (which we call "square" 
% for short). At the beginning, some of the spots carry a single-digit
% number between 1 and 9. The problem is to fill the missing spots with
% digits in such a way that every number between 1 and 9 appears exactly
% once in each row, in each column, and in each square.
 
% We represent the Sudoku puzzle as a simple list of 81 digits. At
% the beginning, the list is partially instantiated. During the 
% process, all the elememts of the list get instantiated with digits.
 
% We are going to treat each spot as a Prolog term spot(X,R,C,S) where
% X is the number to put into the field, R is the row, C the column, and
% S the square the field belongs to. R, C, and S are lists which represent
% the respective number sets.
 
% --------------------------------------------------------------------------
 
% sudoku(Puzzle) :- solve the given Sudoku puzzle and print the
%    problem statement as well as the solution to the standard output
%   (list-of-integers, partially instantiated)
 
sudoku(Puzzle) :- 
   printPuzzle(Puzzle), nl, 
   connect(Spots),
   flag(counter,_,0),
   init(Puzzle,Spots),
   solve(Spots),
   printPuzzle(Puzzle),
   flag(counter,N,N+1),
   fail.
sudoku(_) :- 
   flag(counter,N,N), nl, 
   printCounter(N).
 
% ---------------------------------------------------------------
 
% The most difficult part of the problem solution is to prepare 
% the list of spot/4 terms representing the spots in the puzzle.
% We have to make sure that every spot "knows" its row, column,
% and square. In other words, all the spots in a row access the
% same list in order to check whether a new number can be placed
% in the row. The same is true for the columns and the squares. 
 
% connect(Spots) :- Spots = [spot(_,R1,C1,S1),spot(_,R1,C2,S1),.....].
 
connect(Spots) :- 
   length(Spots,81),
   connectRows(Spots), 
   connectCols(Spots), 
   connectSquares(Spots).
 
% connectRows(Spots) :- connect the spots of all rows in the list Spot
 
connectRows([]).
connectRows(Spots) :- 
   connectRow(Spots,_,9),
   skip(Spots,9,Spots1), 
   connectRows(Spots1).
 
% connectRow(Spots,R,K) :- the first K elements of Spot
% are in the same row R
 
connectRow(_,_,0).
connectRow([spot(_,R,_,_)|Spots],R,K) :- K > 0,
   K1 is K-1, connectRow(Spots,R,K1).
 
% connectCols(Spots) :- connect the spots of the same column
 
connectCols(Spots) :- connectCols(Spots,9).
 
% connectCols(Spots,K) :- connect K more columns columns
 
connectCols(_,0) :- !.
connectCols(Spots,K) :- K > 0,
   connectCol(Spots,_),
   skip(Spots,1,Spots1), 
   K1 is K-1, connectCols(Spots1,K1).
 
% connectCol(Spots,C) :- connect the first spot in Spots with
% the other spots in its column C
 
connectCol([],_).
connectCol([spot(_,_,C,_)|Spots],C) :-
   skip(Spots,8,Spots1),
   connectCol(Spots1,C).
 
% connectSquares(Spots) :- connect all three bands
% The nine squares are arranged in three horizontal bands,
% three squares in each band. 
 
connectSquares(Spots) :- 
   connectBand(Spots),
   skip(Spots,27,Spots1),
   connectBand(Spots1),
   skip(Spots1,27,Spots2),
   connectBand(Spots2).
 
% connectBand(Spots) :- connect the next band (of three squares
 
connectBand(Spots) :- 
   connectSq(Spots,_),
   skip(Spots,3,Spots1),
   connectSq(Spots1,_),
   skip(Spots1,3,Spots2),
   connectSq(Spots2,_).
 
% connectSq(Spots,S) :- connect the spots of square S. In the Spots
%    list each square is composed of three spot-triplets which 
%    are separated by 6 spots. 
 
connectSq([],_).
connectSq(Spots,S) :- 
  connectTriplet(Spots,S),
  skip(Spots,9,Spots1),
  connectTriplet(Spots1,S),
  skip(Spots1,9,Spots2),
  connectTriplet(Spots2,S).
 
% connectTriplet(Spots,S) :- connect the next three spots in the Spots
%    list with the square S
 
connectTriplet([spot(_,_,_,S),spot(_,_,_,S),spot(_,_,_,S)|_],S).
 
% skip(List,N,List1) :- skip the first N elements from a List
%    and return the rest of the list in List1. If the List is
%    too short, then succeed and return [] as rest.
 
skip([],_,[]) :- !.
skip(Xs,0,Xs) :- !.
skip([_|Xs],K,Zs) :- K > 0, K1 is K-1, skip(Xs,K1,Zs). 
 
% -----------------------------------------------------------
 
% init(Puzzle,Spots) :- initialize the Spots list on the
%    basis of the problem statement (Puzzle) and link the
%    Puzzle list to the Spots list 
 
init([],[]).
init([X|Xs],[Sp|Spots]) :- initSpot(X,Sp), init(Xs,Spots).
 
% If X is not instantiated in the given puzzle, create a link
% between the variable in the puzzle and the corresponding 
% variable in the spot. Otherwise copy the given number from 
% the puzzle into the spot and insert it into the spot's 
% correct row, column, and square, if this is legal.
 
initSpot(X,spot(X,_,_,_)) :- var(X), !.
initSpot(X,spot(X,R,C,S)) :- integer(X),
   insert(X,R),
   insert(X,C),
   insert(X,S).
 
% ----------------------------------------------------------
 
% solve(Spots) :- solve the problem using backtrack
 
solve([]).
solve([Spot|Spots]) :- bind(Spot), solve(Spots).
 
% bind(Spot) :- bind the data field in Spot to an 
% available non-conflicting digit.
 
bind(spot(X,_,_,_)) :- nonvar(X), !.
bind(spot(X,R,C,S)) :- var(X),
   between(1,9,X),  % try a digit
   insert(X,R),
   insert(X,C),
   insert(X,S).
 
% ---------------------------------------------------------
 
% insert(X,L) :- X can be inserted into the list without 
% conflict, i.e. X is not yet in the list, when insert/2
% is called. Otherwise the predicate fails.
 
insert(X,L) :- var(L), !, L = [X|_].
insert(X,[Y|Ys]) :- X \= Y, insert(X,Ys).
 
% ---------------------------------------------------------
 
printPuzzle([]).
printPuzzle(Xs) :- nl,
   printBand(Xs,Xs1),
   write('--------+---------+--------'), nl,
   printBand(Xs1,Xs2),
   write('--------+---------+--------'), nl,
   printBand(Xs2,_).
 
printBand(Xs,Xs3) :- 
   printRow(Xs,Xs1), nl,
   write('        |         |'), nl, 
   printRow(Xs1,Xs2), nl,
   write('        |         |'), nl, 
   printRow(Xs2,Xs3), nl.
 
printRow(Xs,Xs3) :-
   printTriplet(Xs,Xs1), write(' | '),
   printTriplet(Xs1,Xs2), write(' | '),
   printTriplet(Xs2,Xs3).
 
printTriplet(Xs,Xs3) :-
   printElement(Xs,Xs1), write('  '),
   printElement(Xs1,Xs2), write('  '),
   printElement(Xs2,Xs3).
 
printElement([X|Xs],Xs) :- var(X), !, write('.').
printElement([X|Xs],Xs) :- write(X).
 
printCounter(0) :- !, write('No solution'), nl.
printCounter(1) :- !, write('1 solution'), nl.
printCounter(K) :- write(K), write(' solutions'), nl.
 
% ---------------------------------------------------------
 
test(N) :- puzzle(N,P), sudoku(P).
 
puzzle(1,P) :- 
   P = [_,_,4,8,_,_,_,1,7, 6,7,_,9,_,_,_,_,_, 5,_,8,_,3,_,_,_,4,
        3,_,_,7,4,_,1,_,_, _,6,9,_,_,_,7,8,_, _,_,1,_,6,9,_,_,5,
	1,_,_,_,8,_,3,_,6, _,_,_,_,_,6,_,9,1, 2,4,_,_,_,1,5,_,_].
 
puzzle(2,P) :- 
   P = [3,_,_,_,7,1,_,_,_, _,5,_,_,_,_,1,8,_, _,4,_,8,_,_,_,_,_,
	_,_,6,2,_,_,3,_,_, _,_,1,_,5,_,8,_,_, _,_,3,_,_,8,2,_,_,
        _,_,_,_,_,3,_,4,_, _,6,4,_,_,_,_,7,_, _,_,_,9,6,_,_,_,1].
 
puzzle(3,P) :-
   P = [1,7,_,_,_,9,_,_,4, _,_,_,_,_,_,7,_,_, 5,_,_,3,_,_,2,_,_,
        _,8,_,_,_,_,5,3,6, _,_,_,_,8,_,_,_,_, 6,9,1,_,_,_,_,8,_,
        _,_,7,_,_,4,_,_,2, _,_,2,_,_,_,_,_,_, 3,_,_,5,_,_,_,7,1].
 
% an example with many solutions
 
puzzle(4,P) :-
   P = [1,_,_,_,_,9,_,_,4, _,_,_,_,_,_,7,_,_, 5,_,_,3,_,_,2,_,_,
        _,8,_,_,_,_,5,_,6, _,_,_,_,8,_,_,_,_, 6,9,1,_,_,_,_,8,_,
        _,_,7,_,_,4,_,_,2, _,_,2,_,_,_,_,_,_, 3,_,_,5,_,_,_,7,1].
 
puzzle(5,P) :- 
   P = [_,6,5,_,_,_,7,2,_, 3,_,7,_,_,_,1,_,8, 2,9,_,_,1,_,_,3,4,
        _,_,_,5,_,7,_,_,_, _,_,1,_,_,_,8,_,_, _,_,_,2,_,1,_,_,_,
        8,1,_,_,2,_,_,5,7, 7,_,2,_,_,_,9,_,1, _,5,4,_,_,_,6,8,_].
 
puzzle(6,P) :- 
   P = [5,_,2,_,_,3,_,_,_, 4,6,_,_,7,_,9,_,_, _,_,3,4,_,_,_,_,_,
        9,5,_,_,6,_,_,_,_, _,4,_,_,_,_,_,9,_, _,_,_,_,9,_,_,1,7,
        _,_,_,_,_,7,2,_,_, _,_,9,_,4,_,_,3,5, _,_,_,3,_,_,7,_,6].
 
% an example with an error in the problem statement (5 appears
% twice in the top left square)
 
puzzle(e1,P) :- 
   P = [5,_,2,_,_,3,_,_,_, 4,6,5,_,7,_,9,_,_, _,_,3,4,_,_,_,_,_,
        9,5,_,_,6,_,_,_,_, _,4,_,_,_,_,_,9,_, _,_,_,_,9,_,_,1,7,
        _,_,_,_,_,7,2,_,_, _,_,9,_,4,_,_,3,5, _,_,_,3,_,_,7,_,6].
 
% another example with an error in the problem statement (garbage
% in the first row
 
puzzle(e2,P) :- 
   P = [x,_,2,_,_,3,_,_,_, 4,6,_,_,7,_,9,_,_, _,_,3,4,_,_,_,_,_,
        9,5,_,_,6,_,_,_,_, _,4,_,_,_,_,_,9,_, _,_,_,_,9,_,_,1,7,
        _,_,_,_,_,7,2,_,_, _,_,9,_,4,_,_,3,5, _,_,_,3,_,_,7,_,6].
 
% some more examples from the Sonntagszeitung
 
puzzle(8,P) :- 
   P = [4,8,_,_,7,_,_,_,_, _,_,9,6,8,_,3,_,7, 3,_,7,4,_,_,_,5,_,
        _,_,_,3,_,_,_,2,_, 9,5,_,7,2,1,_,6,8, _,1,_,_,_,4,_,_,_,
        _,4,_,_,_,2,7,_,1, 8,_,2,_,4,7,5,_,_, _,_,_,_,5,_,_,8,4].
 
puzzle(9,P) :- 
   P = [_,1,_,_,_,_,_,2,4, 5,_,_,_,4,_,_,8,6, 6,_,4,1,_,_,_,_,_,
        _,_,_,8,_,6,9,_,_, 8,_,_,_,_,_,_,_,2, _,_,6,4,_,3,_,_,_,
        _,_,_,_,_,7,2,_,8, 1,6,_,_,9,_,_,_,5, 7,4,_,_,_,_,_,9,_].
 
puzzle(10,P) :-
   P = [_,9,7,_,_,5,_,_,4, _,_,_,_,_,9,_,_,_, _,_,5,_,4,_,2,_,7,
        _,8,6,_,_,3,_,_,_, _,_,_,_,2,_,_,_,_, _,_,_,5,_,_,3,4,_,
        5,_,3,_,7,_,6,_,_, _,_,_,6,_,_,_,_,_, 9,_,_,8,_,_,1,7,_].
 
% a puzzle rated "not fun" by 
% http://dingo.sbs.arizona.edu/~sandiway/sudoku/examples.html 
 
puzzle(11,P) :-
   P = [_,2,_,_,_,_,_,_,_, _,_,_,6,_,_,_,_,3, _,7,4,_,8,_,_,_,_,
	_,_,_,_,_,3,_,_,2, _,8,_,_,4,_,_,1,_, 6,_,_,5,_,_,_,_,_,
        _,_,_,_,1,_,7,8,_, 5,_,_,_,_,9,_,_,_, _,_,_,_,_,_,_,4,_].
 
% a "super hard puzzle" by
% http://www.menneske.no/sudoku/eng/showpuzzle.html?number=2155141
 
puzzle(12,P) :-
   P = [_,_,_,6,_,_,4,_,_, 7,_,_,_,_,3,6,_,_, _,_,_,_,9,1,_,8,_,
        _,_,_,_,_,_,_,_,_, _,5,_,1,8,_,_,_,3, _,_,_,3,_,6,_,4,5,
        _,4,_,2,_,_,_,6,_, 9,_,3,_,_,_,_,_,_, _,2,_,_,_,_,1,_,_].
 
% some puzzles from Spektrum der Wissenschaft 3/2006, p.100
 
% leicht
puzzle(13,P) :-
   P = [_,2,6,4,5,8,3,_,_, 1,7,_,_,_,_,_,4,_, _,8,_,_,_,_,_,_,_,
	_,_,_,_,_,_,9,8,_, _,_,_,5,9,_,1,_,4, 7,_,_,2,_,1,_,5,_,
	_,_,_,_,4,_,_,3,_, _,_,_,8,_,_,5,_,_, 6,_,_,_,_,7,_,9,1].
 
% mittel
puzzle(14,P) :-
   P = [9,_,_,6,3,_,_,_,4, _,1,_,2,5,8,_,_,_, _,_,_,7,_,_,_,_,8,
        6,4,_,_,2,_,5,_,_, _,_,_,_,_,_,_,_,_, 8,2,_,5,_,_,_,9,_,
	_,_,_,_,_,_,8,7,_, 3,_,_,_,_,5,_,4,_, _,_,1,_,7,6,_,_,_].
 
% schwer
puzzle(15,P) :-
   P = [_,_,_,_,_,_,_,_,7, _,_,_,_,_,_,6,3,4, _,_,_,9,4,_,_,2,_,
        5,_,1,7,_,_,8,6,_, _,_,9,_,_,_,_,_,3, _,_,_,_,8,_,_,_,_,
	4,3,_,5,_,_,_,_,_, _,1,_,_,6,8,_,_,_, _,_,_,_,_,3,1,_,9].
 
% hoellisch (!)
puzzle(16,P) :-
   P = [_,_,_,_,3,_,_,_,_, _,1,5,_,_,_,6,_,_, 6,_,_,2,_,_,3,4,_,
        _,_,_,6,_,_,_,8,_, _,3,9,_,_,_,5,_,_, 5,_,_,_,_,_,9,_,2,
	_,_,_,_,_,_,_,_,_, _,_,_,9,7,_,2,5,_, 1,_,_,_,5,_,_,7,_].
 
% Spektrum der Wissenschaft 3/2006 Preisraetsel (angeblich hoellisch !)
 
puzzle(17,P) :-
   P = [_,1,_,_,6,5,4,_,_, _,_,_,_,8,4,1,_,_, 4,_,_,_,_,_,_,7,_,
        _,5,_,1,9,_,_,_,_, _,_,3,_,_,_,7,_,_, _,_,_,_,3,7,_,5,_,
        _,8,_,_,_,_,_,_,3, _,_,2,6,5,_,_,_,_, _,_,9,8,1,_,_,2,_].
 
% the (almost) empty grid
 
puzzle(99,P) :- 
   P = [1,2,3,4,5,6,7,8,9, _,_,_,_,_,_,_,_,_, _,_,_,_,_,_,_,_,_,
        _,_,_,_,_,_,_,_,_, _,_,_,_,_,_,_,_,_, _,_,_,_,_,_,_,_,_,
        _,_,_,_,_,_,_,_,_, _,_,_,_,_,_,_,_,_, _,_,_,_,_,_,_,_,_].

p7_08.pl

p7_08.pl
%  7.08 (***) Nonograms
 
%   Around 1994, a certain kind of puzzles was very popular in England.
%   The "Sunday Telegraph" newspaper wrote: "Nonograms are puzzles from 
%   Japan and are currently published each week only in The Sunday 
%   Telegraph.  Simply use your logic and skill to complete the grid 
%   and reveal a picture or diagram." As a Prolog programmer, you are in 
%   a better situation: you can have your computer do the work! Just write
%   a little program ;-).
%   The puzzle goes like this: Essentially, each row and column of a 
%   rectangular bitmap is annotated with the respective lengths of 
%   its distinct strings of occupied cells. The person who solves the puzzle 
%   must complete the bitmap given only these lengths.
 
%          Problem statement:          Solution:
 
%          |_|_|_|_|_|_|_|_| 3         |_|X|X|X|_|_|_|_| 3           
%          |_|_|_|_|_|_|_|_| 2 1       |X|X|_|X|_|_|_|_| 2 1         
%          |_|_|_|_|_|_|_|_| 3 2       |_|X|X|X|_|_|X|X| 3 2         
%          |_|_|_|_|_|_|_|_| 2 2       |_|_|X|X|_|_|X|X| 2 2         
%          |_|_|_|_|_|_|_|_| 6         |_|_|X|X|X|X|X|X| 6           
%          |_|_|_|_|_|_|_|_| 1 5       |X|_|X|X|X|X|X|_| 1 5         
%          |_|_|_|_|_|_|_|_| 6         |X|X|X|X|X|X|_|_| 6           
%          |_|_|_|_|_|_|_|_| 1         |_|_|_|_|X|_|_|_| 1           
%          |_|_|_|_|_|_|_|_| 2         |_|_|_|X|X|_|_|_| 2           
%           1 3 1 7 5 3 4 3             1 3 1 7 5 3 4 3              
%           2 1 5 1                     2 1 5 1                      
 
%   For the example above, the problem can be stated as the two lists
%   [[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]] and 
%   [[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]] which give the
%   "solid" lengths of the rows and columns, top-to-bottom and
%   left-to-right, respectively. (Published puzzles are larger than this
%   example, e.g. 25 x 20, and apparently always have unique solutions.)
 
% Basic ideas  -------------------------------------------------------------
 
% (1) Every square belongs to a (horizontal) row and a (vertical) column.
%     We are going to treat each square as a variable that can be accessed
%     via its row or via its column. The objective is to instantiate each
%     square with either an 'x' or a space character.
 
% (2) Rows and columns should be processed in a similar way. We are going
%     to collectively call them "lines", and we call the strings of
%     successive 'x's "runs". For every given line, there are, in 
%     general, several possibilities to put 'x's into the squares. 
%     For example, if we have to put a run of length 3 into a line 
%     of length 8 then there are 6 ways to do so.
 
% (3) In principle, all these possibilities have to be explored for all
%     lines. However, because we are only interested in a single solution,
%     not in all of them, it may be advantageous to first try the lines 
%     with few possibilities.
 
% --------------------------------------------------------------------------
 
% nonogram(RowNums,ColNums,Solution,Opt) :- given the specifications for
%    the rows and columns in RowNums and ColNums, respectively, the puzzle
%    is solved by Solution, which is a row-by-row representation of
%    the filled puzzle grid. Opt = 0 is without optimization, Opt = 1
%    optimizes the order of the line tasks (see below). 
%    (list-of-int-lists,list-of-int-lists,list-char-lists)    (+,+,-)
 
nonogram(RowNums,ColNums,Solution,Opt) :-
   length(RowNums,NRows),
   length(ColNums,NCols),
   make_rectangle(NRows,NCols,Rows,Cols),
   append(Rows,Cols,Lines),
   append(RowNums,ColNums,LineNums),
   maplist(make_runs,LineNums,LineRuns),
   combine(Lines,LineRuns,LineTasks),
   optimize(Opt,LineTasks,OptimizedLineTasks),
   solve(OptimizedLineTasks),
   Solution = Rows.
 
combine([],[],[]).
combine([L1|Ls],[N1|Ns],[task(L1,N1)|Ts]) :- combine(Ls,Ns,Ts).
 
solve([]).
solve([task(Line,LineRuns)|Tasks]) :- 
   place_runs(LineRuns,Line),
   solve(Tasks).
 
 
% (1) The first basic idea is implemented as follows. ----------------------
 
% make_rectangle(NRows,NCols,Rows,Cols) :- a rectangular array of variables
%    with NRows rows and NCols columns is generated. The variables can
%    be accessed via the Rows or via the Cols list. I.e the variable in 
%    row 1 and column 2 can be addressed in the Rows list as [[_,X|_]|_]
%    or in the Cols list as [_,[X|_]|_]. Cool!
%    (integer,integer,list-of-char-list,list-of-char-list)    (+,+,_,_)
 
make_rectangle(NRows,NCols,Rows,Cols) :-
   NRows > 0, NCols > 0,
   length(Rows,NRows),
   Pred1 =.. [inv_length, NCols],
   checklist(Pred1,Rows),
   length(Cols,NCols),
   Pred2 =.. [inv_length, NRows],
   checklist(Pred2,Cols),
   unify_rectangle(Rows,Cols).
 
inv_length(Len,List) :- length(List,Len).
 
% unify_rectangle([[]|_],[]).
unify_rectangle(_,[]).
unify_rectangle([],_).
unify_rectangle([[X|Row1]|Rows],[[X|Col1]|Cols]) :-
   unify_row(Row1,Cols,ColsR), 
   unify_rectangle(Rows,[Col1|ColsR]).   
 
unify_row([],[],[]).
unify_row([X|Row],[[X|Col1]|Cols],[Col1|ColsR]) :- unify_row(Row,Cols,ColsR).
 
 
% (2) The second basic idea is implemented as follows -----------------------
 
% make_runs(RunLens,Runs) :- Runs is a list of character-lists that
%    correspond to the given run lengths RunLens. Actually, each run
%    is a difference list; e.g ['x','x'|T]-T.
%    (integer-list,list-of-runs) (+,-)
 
make_runs([],[]) :- !.
make_runs([Len1|Lens],[Run1-T|Runs]) :- 
   put_x(Len1,Run1,T),
   make_runs2(Lens,Runs).
 
% make_runs2(RunLens,Runs) :- same as make_runs, except that the runs
%    start with a space character.
make_runs2([],[]).
make_runs2([Len1|Lens],[[' '|Run1]-T|Runs]) :- 
   put_x(Len1,Run1,T),
   make_runs2(Lens,Runs).
 
put_x(0,T,T) :- !.
put_x(N,['x'|Xs],T) :- N > 0, N1 is N-1, put_x(N1,Xs,T).
 
% place_runs(Runs,Line) :- Runs is a list of runs, each of them being
%    a difference list of characters. Line is a list of characters.
%    The runs are placed into the Line, optionally separated by
%    additional space characters. Via backtracking, all possibilities
%    are generated.
%   (run-list,square-list)  (+,?)
 
place_runs([],[]).
place_runs([Line-Rest|Runs],Line) :- place_runs(Runs,Rest).
place_runs(Runs,[' '|Rest]) :- place_runs(Runs,Rest).
 
% In order to understand what the predicates make_runs/2 make_runs2/2
% put_x/3, and place_runs/2, try the following goal:
 
% ?-  make_runs([3,1],Runs), Line = [_,_,_,_,_,_,_], place_runs(Runs,Line).
 
% (3) The third idea is an optimization. It is performed by ordering
%     the line tasks in an advantageous way. This is done by the 
%     predicate optimize.
 
% optimize(LineTasks,LineTasksOpt)
 
optimize(0,LineTasks,LineTasks).     
 
optimize(1,LineTasks,OptimizedLineTasks) :- 
   label(LineTasks,LabelledLineTasks),
   sort(LabelledLineTasks,SortedLineTasks),
	unlabel(SortedLineTasks,OptimizedLineTasks).
 
label([],[]).
label([task(Line,LineRuns)|Tasks],[task(Count,Line,LineRuns)|LTasks]) :- 
   length(Line,N),   
   findall(L,(length(L,N), place_runs(LineRuns,L)),Ls),
   length(Ls,Count),
   label(Tasks,LTasks).
 
unlabel([],[]).
unlabel([task(_,Line,LineRuns)|LTasks],[task(Line,LineRuns)|Tasks]) :- 
   unlabel(LTasks,Tasks).
 
% Printing the solution ----------------------------------------------------
 
% print_nonogram(RowNums,ColNums,Solution) :-
 
print_nonogram([],ColNums,[]) :- print_colnums(ColNums).
print_nonogram([RowNums1|RowNums],ColNums,[Row1|Rows]) :-
   print_row(Row1),
   print_rownums(RowNums1),
   print_nonogram(RowNums,ColNums,Rows).
 
print_row([]) :- write('  ').
print_row([X|Xs]) :- print_replace(X,Y), write(' '), write(Y), print_row(Xs).
 
print_replace(' ',' ') :- !.
print_replace(x,'*').
 
print_rownums([]) :- nl.
print_rownums([N|Ns]) :- write(N), write(' '), print_rownums(Ns).
 
print_colnums(ColNums) :-
   maxlength(ColNums,M,0),
	print_colnums(ColNums,ColNums,1,M).
 
maxlength([],M,M).
maxlength([L|Ls],M,A) :- length(L,N), B is max(A,N), maxlength(Ls,M,B). 
 
print_colnums(_,[],M,M) :- !, nl.
print_colnums(ColNums,[],K,M) :- K < M, !, nl,
   K1 is K+1, print_colnums(ColNums,ColNums,K1,M).
print_colnums(ColNums,[Col1|Cols],K,M) :- K =< M, 
   write_kth(K,Col1), print_colnums(ColNums,Cols,K,M).
 
write_kth(K,List) :- nth1(K,List,X), !, writef('%2r',[X]).
write_kth(_,_) :- write('  ').
 
% --------------------------------------------------------------------------
 
% Test with some "real" puzzles from the Sunday Telegraph:
 
test(Name,Opt) :- 
   specimen_nonogram(Name,Rs,Cs),
   nonogram(Rs,Cs,Solution,Opt), nl,
   print_nonogram(Rs,Cs,Solution).
 
% Results for the nonogram 'Hen':
 
% ?- time(test('Hen',0)).     - without optimization
% 16,803,498 inferences in 39.30 seconds (427570 Lips)  
 
% ?- time(test('Hen',1)).     - with optimization
% 5,428 inferences in 0.02 seconds (271400 Lips)
 
% specimen_nonogram( Title, Rows, Cols) :-
%	NB  Rows, Cols and the "solid" lengths are enlisted
%	top-to-bottom or left-to-right as appropriate
 
specimen_nonogram(
	'Hen',
	[[3], [2,1], [3,2], [2,2], [6], [1,5], [6], [1], [2]],
	[[1,2], [3,1], [1,5], [7,1], [5], [3], [4], [3]]
	).
 
specimen_nonogram(
	'Jack & The Beanstalk',
	[[3,1], [2,4,1], [1,3,3], [2,4], [3,3,1,3], [3,2,2,1,3],
	 [2,2,2,2,2], [2,1,1,2,1,1], [1,2,1,4], [1,1,2,2], [2,2,8],
	 [2,2,2,4], [1,2,2,1,1,1], [3,3,5,1], [1,1,3,1,1,2],
	 [2,3,1,3,3], [1,3,2,8], [4,3,8], [1,4,2,5], [1,4,2,2],
	 [4,2,5], [5,3,5], [4,1,1], [4,2], [3,3]],
	[[2,3], [3,1,3], [3,2,1,2], [2,4,4], [3,4,2,4,5], [2,5,2,4,6],
	 [1,4,3,4,6,1], [4,3,3,6,2], [4,2,3,6,3], [1,2,4,2,1], [2,2,6],
	 [1,1,6], [2,1,4,2], [4,2,6], [1,1,1,1,4], [2,4,7], [3,5,6],
	 [3,2,4,2], [2,2,2], [6,3]]
	).
 
specimen_nonogram(
	'WATER BUFFALO',
	[[5], [2,3,2], [2,5,1], [2,8], [2,5,11], [1,1,2,1,6], [1,2,1,3],
	 [2,1,1], [2,6,2], [15,4], [10,8], [2,1,4,3,6], [17], [17],
	 [18], [1,14], [1,1,14], [5,9], [8], [7]],
	[[5], [3,2], [2,1,2], [1,1,1], [1,1,1], [1,3], [2,2], [1,3,3],
	 [1,3,3,1], [1,7,2], [1,9,1], [1,10], [1,10], [1,3,5], [1,8],
	 [2,1,6], [3,1,7], [4,1,7], [6,1,8], [6,10], [7,10], [1,4,11],
	 [1,2,11], [2,12], [3,13]]
	).
 
% Thanks to ------------------------------------------------------------
%  __   __    Paul Singleton (Dr)           JANET: [email protected]
% |__) (__    Computer Science Dept.        other: [email protected]
% |  .  __).  Keele University, Newcastle,    tel: +44 (0)782 583477
%             Staffs ST5 5BG, ENGLAND         fax: +44 (0)782 713082
% for the idea and the examples ----------------------------------------

p7_09-readfile.pl

p7_09-readfile.pl
% readfile.pl   [email protected]  
% Time-stamp: <8-Oct-2000 15:25 hew>
 
% Auxiliary predicate for reading a text file and splitting the text 
% into lines. Cope with the different end-of-line conventions.
% Should work with UNIX, DOS/Windows, and Mac file system.
 
 
% read_lines(File,Lines) :- read the text file File and split the text
% into lines. Lines is a list of char-lists, each of them being a text line.
% (+,-) (atom, list-of-charlists)  
 
read_lines(File,Lines) :-
   seeing(Old), see(File), 
   get_char(X), read_file(X,CharList),  % read the whole file into a charlist
   parse_charlist(CharList-[],Lines),   % parse lines using difference lists
   see(Old).
 
read_file(end_of_file,[]) :- !.
read_file(X,[X|Xs]) :- get_char(Y), read_file(Y,Xs).
 
parse_charlist(T-T,[]) :- !.
parse_charlist(X1-X4,[L|Ls]) :- 
   parse_line(X1-X2,L), 
   parse_eol(X2-X3), !,
   parse_charlist(X3-X4,Ls).
 
parse_eol([]-[]) :- !.           % no end-of-line at end-of-file
parse_eol(['\r','\n'|R]-R) :- !. % DOS/Windows
parse_eol(['\n','\r'|R]-R) :- !. % Mac (?)
parse_eol(['\r'|R]-R) :- !.      % Mac (?)
parse_eol(['\n'|R]-R).           % UNIX
 
parse_line([]-[],[]) :- !.       % no end-of-line at end-of-file
parse_line([X|X1]-[X|X1],[]) :- eol_char(X), !.
parse_line([X|X1]-X2,[X|Xs]) :- \+ eol_char(X), parse_line(X1-X2,Xs).
 
eol_char('\r').
eol_char('\n').

p7_09.pl

p7_09.pl
% 7.09 (***) Crossword puzzle
%
% Given an empty (or almost empty) framework of a crossword puzzle and 
% a set of words. The problem is to place the words into the framework.
%
% [email protected]     Time-stamp: <8-Oct-2000 14:46 hew>
% modified argument order in select/3 predicate (SWI 3.3 -> 3.4) 
% 15-May-2001 hew
%
% The particular crossword puzzle is specified in a text file which
% first lists the words (one word per line) in an arbitrary order. Then,
% after an empty line, the crossword framework is defined. In this 
% framework specification, an empty character location is represented
% by a dot (.). In order to make the solution easier, character locations 
% can also contain predefined character values. (See example files p7_09*.dat;
% note that p7_09c.dat does not have a solution).
%
% Words are strings (character lists) of at least two characters. 
% A horizontal or vertical sequence of character places in the 
% crossword framework is called a site. Our problem is to find a 
% compatible way of placing words onto sites.
 
:- ensure_loaded('p7_09-readfile.pl').  % used to read the data file
 
% main program section -----------------------------------------------------
 
crossword :-
   write('usage: crossword(File)'), nl,
   write('or     crossword(File,Opt)         with Opt one of 0,1, or 2'), nl,
   write('or     crossword(File,Opt,debug)   for extra output'), nl.
 
:- crossword.
 
% crossword/1 runs without optimization (not recommended for large files)
crossword(FileName) :- crossword(FileName,0).
 
% crossword/2 runs with a given optimization and no debug output
crossword(FileName,Opt) :- crossword(FileName,Opt,nodebug).
 
% crossword/3 runs with a given optimization and a given debugging modus
crossword(FileName,Opt,Debug) :-
   read_lines(FileName,Lines),  % from file p99-readfile.pl
                                % read_lines returns a list of character-lists
   separate(Lines,Words,FrameLines),
   length(Words,NWords), 
   construct_squares(FrameLines,Squares,MaxRow,MaxCol),
   debug_write(Debug,Squares),
   construct_sites(Squares,MaxRow,MaxCol,Sites),
	length(Sites,NSites),
   check_lengths(NWords,NSites), 
   solve(Words,Sites,Opt,Debug), % do the real work
   show_result(Squares,MaxRow,MaxCol).
 
debug_write(debug,X) :- !, write(X), nl, nl.
debug_write(_,_).
 
check_lengths(N,N) :- !.
check_lengths(NW,NS) :- NW \= NS, 
	write('Number of words does not correspond to number of sites.'), nl,
   fail.
 
% input preparation ----------------------------------------------------
 
% parse the data file and separate the word list from the framework 
% description
separate(Lines,Words,FrameLines) :-
   trim_lines(Lines,LinesT),
   parse_non_empty_lines(LinesT-L1,Words),  % difference lists!
   parse_empty_lines(L1-L2),
	parse_non_empty_lines(L2-L3,FrameLines),
   parse_empty_lines(L3-[]).
 
% remove white space at the end of the lines
trim_lines([],[]).
trim_lines([L|Ls],[LT|LTs]) :- trim_line(L,LT), trim_lines(Ls,LTs).
 
trim_line(L,LT) :- reverse(L,RL), rm_white_space(RL,RLT), reverse(RLT,LT).
 
rm_white_space([X|Xs],L) :- char_type(X,white), !, rm_white_space(Xs,L).
rm_white_space(L,L).      
 
% separate the word lines from the frame lines
parse_non_empty_lines([L|L1]-L2,[L|Ls]) :- L \= [], !, 
   parse_non_empty_lines(L1-L2,Ls).
parse_non_empty_lines(L-L,[]).
 
parse_empty_lines([[]|L1]-L2) :- !, parse_empty_lines(L1-L2).
parse_empty_lines(L-L).
 
% A square is a position for a single character. As Prolog term a square
% has the form sq(Row,Col,X), where X denotes the character and Row and
% Col define the position within the puzzle frame. Squares is simply
% the list of all sq/3 terms.
 
construct_squares(FrameLines,Squares,MaxRow,MaxCol) :-   % (+,-,+,+)
   construct_squares(FrameLines,SquaresList,1),
   flatten(SquaresList,Squares),
   maxima(Squares,0,0,MaxRow,MaxCol).
 
construct_squares([],[],_).                              % (+,-,+)
construct_squares([FL|FLs],[SL|SLs],Row) :- 
   construct_squares_row(FL,SL,Row,1),
   Row1 is Row+1,
   construct_squares(FLs,SLs,Row1).
 
construct_squares_row([],[],_,_).                        % (+,-,+,+)
construct_squares_row(['.'|Ps],[sq(Row,Col,_)|Sqs],Row,Col) :- !, 
   Col1 is Col+1, construct_squares_row(Ps,Sqs,Row,Col1).
construct_squares_row([X|Ps],[sq(Row,Col,X)|Sqs],Row,Col) :- 
   char_type(X,alpha), !, 
   Col1 is Col+1, construct_squares_row(Ps,Sqs,Row,Col1).
construct_squares_row([_|Ps],Sqs,Row,Col) :-  
   Col1 is Col+1, construct_squares_row(Ps,Sqs,Row,Col1).
 
% maxima(Squares,0,0,MaxRow,MaxCol) :- determine maximum dimensions
 
maxima([],MaxRow,MaxCol,MaxRow,MaxCol).
maxima([sq(Row,Col,_)|Sqs],AccRow,AccCol,MaxRow,MaxCol) :-
   AccRow1 is max(AccRow,Row),
   AccCol1 is max(AccCol,Col),
   maxima(Sqs,AccRow1,AccCol1,MaxRow,MaxCol).
 
% construction of sites -----------------------------------------------
 
% construct_sites/4 traverses the framework twice in order to
% collect all the sites in the list Sites
 
construct_sites(Squares,MaxRow,MaxCol,Sites) :-             % (+,+,+,-)
	construct_sites_h(Squares,MaxRow,MaxCol,1,SitesH,[]),    % horizontal
	construct_sites_v(Squares,MaxRow,MaxCol,1,Sites,SitesH). % vertical
 
% horizontal sites
 
construct_sites_h(_,MaxRow,_,Row,Sites,Sites) :- Row > MaxRow, !.
construct_sites_h(Squares,MaxRow,MaxCol,Row,Sites,AccSites) :-
   construct_sites_h(Squares,MaxRow,MaxCol,Row,1,AccSites1,AccSites),
   Row1 is Row+1,
	construct_sites_h(Squares,MaxRow,MaxCol,Row1,Sites,AccSites1).
 
construct_sites_h(_,_,MaxCol,_,Col,Sites,Sites) :- Col > MaxCol, !.
construct_sites_h(Squares,MaxRow,MaxCol,Row,Col,Sites,AccSites) :-
   construct_site_h(Squares,Row,Col,Site,Incr), !,
   Col1 is Col+Incr, 
   AccSites1 = [Site|AccSites],
   construct_sites_h(Squares,MaxRow,MaxCol,Row,Col1,Sites,AccSites1).
construct_sites_h(Squares,MaxRow,MaxCol,Row,Col,Sites,AccSites) :-
   Col1 is Col+1,
   construct_sites_h(Squares,MaxRow,MaxCol,Row,Col1,Sites,AccSites).
 
construct_site_h(Squares,Row,Col,[X,Y|Cs],Incr) :-
   memberchk(sq(Row,Col,X),Squares),
   Col1 is Col+1,
   memberchk(sq(Row,Col1,Y),Squares),
   Col2 is Col1+1,
   continue_site_h(Squares,Row,Col2,Cs,3,Incr).
 
continue_site_h(Squares,Row,Col,[X|Cs],Acc,Incr) :-
   memberchk(sq(Row,Col,X),Squares), !,
   Acc1 is Acc+1,
   Col1 is Col+1,
   continue_site_h(Squares,Row,Col1,Cs,Acc1,Incr).
continue_site_h(_,_,_,[],Incr,Incr).
 
% vertical sites
 
construct_sites_v(_,_,MaxCol,Col,Sites,Sites) :- Col > MaxCol, !.
construct_sites_v(Squares,MaxRow,MaxCol,Col,Sites,AccSites) :-
   construct_sites_v(Squares,MaxRow,MaxCol,1,Col,AccSites1,AccSites),
   Col1 is Col+1,
	construct_sites_v(Squares,MaxRow,MaxCol,Col1,Sites,AccSites1).
 
construct_sites_v(_,MaxRow,_,Row,_,Sites,Sites) :- Row > MaxRow, !.
construct_sites_v(Squares,MaxRow,MaxCol,Row,Col,Sites,AccSites) :-
   construct_site_v(Squares,Row,Col,Site,Incr), !,
   Row1 is Row+Incr,
   AccSites1 = [Site|AccSites],
   construct_sites_v(Squares,MaxRow,MaxCol,Row1,Col,Sites,AccSites1).
construct_sites_v(Squares,MaxRow,MaxCol,Row,Col,Sites,AccSites) :-
   Row1 is Row+1,
   construct_sites_v(Squares,MaxRow,MaxCol,Row1,Col,Sites,AccSites).
 
construct_site_v(Squares,Row,Col,[X,Y|Cs],Incr) :-
   memberchk(sq(Row,Col,X),Squares),
   Row1 is Row+1,
   memberchk(sq(Row1,Col,Y),Squares),
   Row2 is Row1+1,
   continue_site_v(Squares,Row2,Col,Cs,3,Incr).
 
continue_site_v(Squares,Row,Col,[X|Cs],Acc,Incr) :-
   memberchk(sq(Row,Col,X),Squares), !,
   Acc1 is Acc+1,
   Row1 is Row+1,
   continue_site_v(Squares,Row1,Col,Cs,Acc1,Incr).
continue_site_v(_,_,_,[],Incr,Incr).
 
% --------------------------------------------------------------------------
 
:- ensure_loaded('p1_28.pl').  % lsort and lfsort
 
% solve/4 does the optimization of the word and site lists
 
solve(Words,Sites,0,Debug) :- !,   % unsorted 
	solve(Words,Sites,Debug).
solve(Words,Sites,1,Debug) :- !,   % length sorted
	lsort(Words,Words1,desc),
   lsort(Sites,Sites1,desc),
	solve(Words1,Sites1,Debug).
solve(Words,Sites,2,Debug) :-      % length frequency sorted 
	lfsort(Words,Words1),
   lfsort(Sites,Sites1),
	solve(Words1,Sites1,Debug).
 
% solve/3 does the debug_write of the prepared Words and Sites
% and then calls solve/2 to do the real work
 
solve(Words,Sites,Debug) :-  
   debug_write(Debug,Words), 
   debug_write(Debug,Sites),
   solve(Words,Sites).        
 
% solve/2 does the real work: find the right site for every word
 
solve([],[]).
solve([W|Words],Sites) :- 
	select(W,Sites,SitesR),
	solve(Words,SitesR).
 
% --------------------------------------------------------------------------
 
show_result(Squares,MaxRow,MaxCol) :-
   show_result(Squares,MaxRow,MaxCol,1), nl.
 
show_result(_,MaxRow,_,Row) :- Row > MaxRow, !.
show_result(Squares,MaxRow,MaxCol,Row) :- 
   show_result(Squares,MaxRow,MaxCol,Row,1), nl,
   Row1 is Row+1, show_result(Squares,MaxRow,MaxCol,Row1).
 
show_result(_,_,MaxCol,_,Col) :- Col > MaxCol, !. 
show_result(Squares,MaxRow,MaxCol,Row,Col) :- 
   (memberchk(sq(Row,Col,X),Squares), !, write(X); write(' ')),
   Col1 is Col+1, show_result(Squares,MaxRow,MaxCol,Row,Col1).  
 
% -------------------------------------------------------------------------
 
% Benchmark results <8-Oct-2000 14:45 hew>
 
% On a 330 MHz Pentium II the following results have been measured
% with SWI-Prolog version 3.3.10 for i686-linux under SuSE Linux 6.3
 
% ?- time(crossword('p7_09b.dat',0)).
% 439,743,691 inferences in 1975.34 seconds (222617 Lips)
 
% ?- time(crossword('p7_09b.dat',1)).
% 19,644,100 inferences in 76.37 seconds (257223 Lips) 
 
% ?- time(crossword('p7_09b.dat',2)).
% 152,880 inferences in 0.94 seconds (162638 Lips)   

p7_09a.dat

p7_09a.dat
LINUX
PROLOG
PERL
ONLINE
GNU
XML
NFS
SQL
EMACS
WEB
MAC
 
......  .
. .  .  .
. ..... .
. . . ...
  . ... .
 ...

p7_09b.dat

p7_09b.dat
AAL
DER
TAL
TAT
ISEL
TELL
ZANK
ZEUS
ALSEN
BLASE
EOSIN
ETTAL
KARRE
LIANE
NEEFS
NONNE
OSTEN
STUHL
TIARA
ANKARA
EGERIA
GRANAT
HIRTEN
MISERE
SAMPAN
TILSIT
WAGGON
FORTUNA
ITALIEN
MADONNA
MELASSE
REAUMUR
RIVIERA
SEKUNDE
SERBIEN
SKELETT
SKRUPEL
STETTIN
STOIKER
HANNIBAL
REGISTER
RELIGION
STANNIOL
TRUEFFEL
UNTERTAN
USAMBARA
VENDETTA
TUEBINGEN
TURKMENEN
ALLENSTEIN
ATTRAKTION
BRIEFTAUBE
TATTERSALL
PROTEKTORAT
TEMPERAMENT
KRANKENKASSE
CHRONOGRAPHIE
TRAUBENZUCKER
WALZER
 
. ......... .............
. .       . .         . .  
. ...........   ....... .
. .       .       .   . . 
...... .... . ......  . .
. .         . .   .   . .
. . ......  ..... .......
. . .  .  ... .   .   .  
........  .   .   . .....
. . .  .  .   . .   . .  
.   .     . ....... . .  
 ......   .   . .  ..... 
  .     . .     .   .   .
  .  ......... ........ .
  . . . . .     .     . .
 .... . .  . .......  . .
. . . . .  .   .    ... .
. . . . . ..........  . .
..... . .  .   .    . . .
.     .    . ... .  . . .
. ..........  .  .  . . .
. .    .      .  .  . . .
.....  ........ ....... .
  .    .      .  .  .   .
........   .......  .....

p7_09c.dat

p7_09c.dat
AAL
DER
TAL
TAT
ISEL
TELL
ZANK
ZEUS
ALSEN
BLASE
EOSIN
ETTAL
KARREN
LIANE
NEEFS
NONNE
OSTEN
STUHL
TIARA
ANKARA
EGERIA
GRANAT
HIRTEN
MISERE
SAMPAN
TILSIT
WAGGON
FORTUNA
ITALIEN
MADONNA
MELASSE
REAUMUR
RIVIERA
SEKUNDE
SERBIEN
SKELETT
SKRUPEL
STETTIN
STOIKER
HANNIBAL
REGISTER
RELIGION
STANNIOL
TRUEFFEL
UNTERTAN
USAMBARA
VENDETTA
TUEBINGEN
TURKMENEN
ALLENSTEIN
ATTRAKTION
BRIEFTAUBE
TATTERSALL
PROTEKTORAT
TEMPERAMENT
KRANKENKASSE
CHRONOGRAPHIE
TRAUBENZUCKER
WALZER
 
. ......... .............
. .       . .         . .  
. ...........   ....... .
. .       .       .   . . 
...... .... . ......  . .
. .         . .   .   . .
. . ......  ..... .......
. . .  .  ... .   .   .  
........  .   .   . .....
. . .  .  .   . .   . .  
.   .     . ....... . .  
 ......   .   . .  ..... 
  .     . .     .   .   .
  .  ......... ........ .
  . . . . .     .     . .
 .... . .  . .......  . .
. . . . .  .   .    ... .
. . . . . ..........  . .
..... . .  .   .    . . .
.     .    . ... .  . . .
. ..........  .  .  . . .
. .    .      .  .  . . .
.....  ........ ....... .
  .    .      .  .  .   .
........   .......  .....

p7_09d.dat

p7_09d.dat
BANI
HAUS
NETZ
LENA
ANKER
ARIEL
GASSE
INNEN
ORADE
SESAM
SIGEL
ANGOLA
AZETAT
EKARTE
NATTER
NENNER
NESSEL
RITTER
SOMMER
TAUNUS
TRANIG
AGENTUR
ERRATEN
ERREGER
GELEISE
HAENDEL
KAROSSE
MANAGER
OSTEREI
SIDERIT
TERRIER
ANATOMIE
ANPASSEN
BARKASSE
BEDANKEN
DEKADENT
EINLADEN
ERLASSEN
FRAGMENT
GARANTIE
KRAWATTE
MEISTERN
REAKTION
TENTAKEL
TRIANGEL
UEBERALL
VERGEBEN
AFRIKANER
BESTELLEN
BULLAUGEN
SANTANDER
VERBERGEN
ALLENSTEIN
AUSTRALIEN
BETEILIGEN
NATALITAET
OBERHAUSEN
UNTERSTAND
LEUMUND
 
........ ........ .......
.   .    .   .    . .   .
. . . ..........  . .   .
.......  .   . . ........
. . . .  . . . .  . . . .
. . . . ...... .    . . .
. . . .    . ........ .  
. . ...... . . . .  . . .
. .  .  .  .   . .    . .
......  ...... . . ......
     .  .  . . . . .  . .
....... .  . . .......  .
.    .  .    .     .    .
. .  ....... ........   .
. .     .    .    .     .
...... . ....... ........
. .    . .        . .   .
. . .........   . . .    
. .    . .  .   . . .....
  .    .  ....... . .   .
..........  .   .    .  .
. .    .  .  .........  .
.  ......... .  .    .  .
.      .  .  .  .    .  .
........  ......... .....
/var/www/wiki/data/pages/pitel/flp/99pl.txt · Poslední úprava: 30. 12. 2022, 14.43:01 autor: 127.0.0.1