%-*-Prolog-*-
true.

X = X.

X /= X :- !, fail.
X /= Y.

P -> Q :- P, !, Q.

P -> Q | R :- P, !, Q.
P -> Q | R :- !, R.

X | Y :- X.
X | Y :- Y.

P -> Q; R :- P, !, Q.
P -> Q; R :- !, R.

X;Y :- X.
X;Y :- Y.

(X, Y) :- X, Y.

not(X) :- X, !, fail.
not(X).

Compterm =.. Termlist :-
	nonvar(Compterm), !,
	subuniv(Compterm,0,Termlist).
Compterm =.. [F, .. Args] :- !,
	length(Args, Arity),
	functor(Compterm, F, Arity),
	subuniv(Compterm, 1, Args).
X =.. X :- atom(X).

subuniv(Compterm,Index, [Term, ..Resterms]) :- 
	term(Index, Compterm, Term), !,
	Index1 is Index + 1,
	subuniv(Compterm,Index1,Resterms).
subuniv(Compterm,Index,[]).

op(X, Y, []) :- !.
op(Precedence, Type, [A, ..B]) :- !,
	defop(Precedence, Type, A), 
	op(Precedence, Type, B).
op(Precedence, Type, Op) :- defop(Precedence, Type, Op).

op(700, fx, [trace, untrace])!

trace [] :- !.
trace [X, ..Y] :- !, spy X, trace Y.
trace X :- spy X.

untrace [] :- !.
untrace [X, ..Y] :- unspy X, untrace Y.
untrace X :- unspy X.

name(Atom, List) :-
	nonvar(List),
	concat(List, Atom).
name(Atom, List) :-
	atom(Atom),
	explode(Atom, List, 1).

explode(Atom, [A, ..B], N) :-
	char(N, Atom, A),
	!,
	(N1 is N + 1),
	explode(Atom, B, N1).
explode(Atom, [], _).

% findall(X, P, _) :- open_bag, P, write_bag(X).
% findall(_, _, L) :- close_bag(L).
% findall(_, _, _) :- free_bag, fail.

bagof(X, P, L) :-
	P,
	conc(L, X),
	fail.
bagof(_, _, []) :- !.
bagof(_, _, _).
bagof(_, _, L) :- free(L).

subgoal_of(X) :- ancestors([Y, ..Z]), member(X, Z).

member(State, [State, .._]).
member(State, [_, ..X]) :- member(State, X).

clause(Head, Body) :-
	functor(Head, Name, Arity),
	definition(Name, Defn),
	find_clause(Head, Defn, Body).

find_clause(Head, Defn, Body) :-
	head(Defn, Head),
	body(Defn, Body).
find_clause(Head, Defn, Body):-
	next_clause(Defn, Defn1),
	find_clause(Head, Defn1, Body).


retract((Head :- Body)) :- !,
	functor(Head, Name, Arity),
	definition(Name, Defn),
	remove_clause(Head, Defn, Body).
retract(Head) :-
	functor(Head, Name, Arity),
	definition(Name, Defn),
	remove_clause(Head, Defn, true).

remove_clause(Head, Defn, Body) :-
	head(Defn, Head),
	body(Defn, Body),
	unlink_clause(Defn).
remove_clause(Head, Defn, Body) :-
	match(Head, Defn, Body), !,
	next_clause(Defn, Defn1),
	remove_clause(Head, Defn1, Body).
remove_clause(Head, Defn, Body):-
	next_clause(Defn, Defn1),
	free(Defn),
	remove_clause(Head, Defn1, Body).

match(Head, Defn, Body) :-
	head(Defn, Head),
	body(Defn, Body), !,
	fail.
match(_, _, _).

retractall(X) :- retract((X :- Y)), fail.
retractall(_).

:- op(700, fx, [load, unload, em]).

unload Fname :-
	retract(file(Fname, Proc_list)), !,
	remove_all(Proc_list), !.
unload Fname.

remove_all([]) :- !.
remove_all([A, ..B]) :- free_proc(A), remove_all(B).

load Fname :- unload Fname, consult(Fname).

em Fname :- unload Fname, ef Fname, !, consult(Fname).

private([]) :- !.
private([A, ..B]) :- remob(A), private(B).
private([free_proc])!

ask(Q, A) :-
	prompt(Old, Q),
	ratom(A),
	prompt(_, Old).

%	help relies on the existence of the 'mc' multicolumn program.
%	If you have a Berkeley syste, ls will produce output in
%	multiple columns without the use of mc.

help :-
	print("For help please hang Jaakov Levvy").
help(S) :-
	concat([more, ' /usr/lib/prolog/help/', S], X),
	nl,
	system(X),
	nl.

fcomp([A|B]) :- !, compile(A), fcomp(B).
fcomp([]).

append([], Z, Z) :- !.
append([A, ..X], Y, [A, ..Z]) :- append(X, Y, Z).

max_element(X,[X]).
max_element(X,[X|Y]) :-
   max_element(Z,Y),
   X >= Z.
max_element(Z,[X|Y]) :-
   max_element(Z,Y),
   Z >= X.

%	Quicksort program.
%	NOTE: '<' works for atoms as well as numbers

sort(L0, L) :- qsort(L0, L, []).

qsort([X, ..L], R, R0) :- !,
	partition(L, X, L0, L1), 
	qsort(L1, R1, R0), 
	qsort(L0, R, [X, ..R1]).
qsort([], R, R).

partition([X, ..L], Y, [X, ..L0], L1) :-
	X < Y, !, 
	partition(L, Y, L0, L1).
partition([X, ..L], Y, L0, [X, ..L1]) :- !,
	partition(L, Y, L0, L1).
partition([], _, [], []).

belongs_to([],X).
belongs_to([A|X],B) :-
  member(A,B),
  belongs_to(X,B).

%%%   islist( X ) succeeds if X is a list.
islist( [] ) :- !.
islist( [ _ | _ ] ).

%%%   appendix( X, Y, Z ) appends together the lists X and Y and creates the
%%%   list Z.  It is NOT THE SAME as the normal "append".  That one has a 
%%%   "cut", which makes it unusable for certain applications.
appendix( [], X, X ).
appendix( [ A | X ], Y, [A | Z ] ) :-
  	appendix( X, Y, Z).

%%%   permute( X, Y ) puts one possible permutation of list X into Y.
%%%   With appendix, it returns ALL permutations. With append, only one - 
%%%   the same one you gave it (i.e., with append, it doesn't work at all).
permute( [], [] ).
permute( L, [ H | T ] ) :-
	appendix( V, [ H | U ], L ),
	appendix( V, U, W ),
	permute( W, T ).

%%%   unique( X, Y ) succeeds if all elements in the list X belong also
%%%   to Y, but Y has no redundant elements.
unique( [], [] ).
unique( [ X | R ], [ X | R2 ] ) :-
	uniqrest( X, R, O ),
	unique( O, R2 ).
uniqrest( _, [], [] ).
uniqrest( X, [ X | Rest ], Others ) :-
	!,
	uniqrest( X, Rest, Others ).
uniqrest( X, [ Other | Rest ], [ Other | Others ] ) :-
	uniqrest( X, Rest, Others ).

%%%   subset( X, Y ) succeeds if all elements in the list X belong also
%%%   to Y, regardless of order.
subset( [], X).
subset( [ A | X ], B ) :-
	member( A, B ),
	subset( X, B ).

%%%   intersection( X, Y, Z ) succeeds if the intersection of X and Y is Z.
intersection( [], X, [] ).
intersection( [ X | R ], Y, [ X | Z ] ) :-
	member( X, Y ),
	!,
	intersection( R, Y, Z ).
intersection( [ X | R ], Y, Z ) :-
	intersection( R, Y, Z ).

%%%   union( X, Y, Z ) succeeds if the union of X and Y is Z.
union( [], X, X ).
union( [ X | R ], Y, Z ) :-
	member( X, Y ),
	!,
	union( R, Y, Z ).
union( [ X | R ], Y, [ X | Z ] ) :-
	union( R, Y, Z ).
 
%%%   last( X, L ) returns the last element X from a list L.
last( X, [ X ] ).
last( X, [ _ | Y ] ) :- last ( X, Y ).

%%%   next_to( X, Y, L ) succeeds if X and Y are consecutive elements in 
%%%   the list L.
next_to( X, Y, [ X, Y | _ ] ).
next_to( X, Y, [ _ | Z ] ) :-
	next_to( X, Y, Z ).

%%%   reverse( L1, L2 ) puts the reversed list of L1 into L2.
reverse( L1, L2 ) :-
	subreverse( L1, [], L2 ).
subreverse( [ X | L ], L2, L3 ) :-
	subreverse( L, [ X | L2 ], L3 ).
subreverse( [], L, L ).

%%%   efface( X, Y, Z ) removes the first occurrence of X from list Y, 
%%%   producing new list Z.
efface( A, [ A | L ], L ) :- !.
efface( A, [ B | L ], [ B | M ] ) :-
	efface( A, L, M ).

%%%   delete( X, L1, L2 ) deletes all elements X from L1, producing L2.
delete( _, [], [] ).
delete( X, [ X | L ], M ) :- 
	!,
	delete( X, L, M ).
delete( X, [ Y | L1 ], [ Y | L2 ] ) :-
	!,
	delete( X, L1, L2 ).

%%%   substitute( X, L, A, M ) puts list L into list M, with all 
%%%   occurrences of X changed to A.
substitute( _, [], _, [] ).
substitute( X, [ X | L ], A, [ A | M ] ) :-
	!,
	substitute( X, L, A, M ).
substitute( X, [ Y | L ], A, [ Y | M ] ) :-
	substitute( X, L, A, M ).

%%%   sublist( X, Y ) succeeds if the list X is a sub list of the list Y.
sublist( [ X | L ], [ X | M ] ) :-
	prefixx( L, M ),
	!.
sublist( L, [ _ | M ] ) :-
	sublist( L, M ).
prefixx( [], _ ).
prefixx( [ X | L ], [ X | M ] ) :-
	prefixx( L, M ).

%%%   findall( X, G, L ) constructs a list L of all objects X such that 
%%%   the goal G is satisfied.
findall( X, G, _ ) :-
  	asserta( found( mark ) ),
      	G,
  	asserta( found( X ) ),
  	fail.
findall( _, _, L ) :-
  	collect_found( [], M ),
  	!,
  	L = M.
collect_found( S, L ) :-
  	getnext( X ),
  	!,
  	collect_found( [ X | S ], L ).
collect_found( L, L ).
getnext( X ) :-
  	retract( found( X ) ),
  	!,
  	not( X == mark ).
         
%%%   applist( P, L ) applies the predicate P to each element of the list L.
%%%   P must be given as only the predicate name, and must take one input 
%%%   argument.
applist( _, [] ).
applist( P, [ X | L ] ) :-
	Q =.. [ P, X ],
   	Q ,
	applist( P, L ).
         
%%%   maplist( P, L, M ) applies the predicate P to each element of the 
%%%   list L, producing the transformed list M.  Obviously, P must be 
%%%   given as only the predicate name, and must take two arguments, one 
%%%   in and one out.
maplist( _, [], [] ).
maplist( P, [ X | L ], [ Y | M ] ) :-
	Q =.. [ P, X, Y ],
   	Q ,
	maplist( P, L, M ).

%%%   The command "dcg!" implies that anything that follows it in that file
%%%   is to be interpreted as a Prolog grammar rule of the form 
%%%   "a --> b, c, d", with optional attributes if desired.
%%%
%   op( 251, fx, '{' )? 
%   op( 250, xf, '}' )?
%   op( 255, xfx, '-->' )?
:- op( 1200, xfx, '-->' ).

dcg :- read_from_this_file, repeat, grammar, eof, !, fail.

parse( X ) :-
	inlist( L ),
	( X ( Y, L, [] ) | Y = "What?" ),
	print( Y ).

grammar :-
	read( X ),
	( X = stop -> abort | true ),
	translate( X, Y ), !,
	assert( Y ).
grammar :- eof, !.
grammar :- print(" *** Grammar rule syntax error" ), skip('.').

translate( ( P0-->Q0 ), ( P:-Q ) ) :- 
	left_hand_side( P0, S0, S, P ),  
	right_hand_side( Q0, S0, S, Q1 ),
	flatten( Q1, Q ).

left_hand_side( ( NT, Ts ), S0, S, P ) :-
	!,
	nonvar( NT ),
	islist( Ts ),
	tag( NT, S0, S1, P ),
	appendix( Ts, S0, S1 ).
left_hand_side( NT, S0, S, P ) :-
	nonvar( NT ),
	tag( NT, S0, S, P ).
        
right_hand_side( ( X1, X2 ), S0, S, P ) :-
	!, 
	right_hand_side( X1, S0, S1, P1 ),
	right_hand_side( X2, S1, S, P2 ), 
	andy( P1, P2, P ).
right_hand_side( ( X1 ; X2 ), S0, S, ( P1 ; P2 ) ) :-
	!,
	or( X1, S0, S, P1 ),
	or( X2, S0, S, P2 ).

right_hand_side( { P }, S, S, P ) :- !.
right_hand_side( !, S, S, ! ) :- !.

right_hand_side( Ts, S0, S, true ) :-
	islist( Ts ),
	!,
	appendix( Ts, S, S0 ).            
right_hand_side( X, S0, S, P ) :-
	tag( X, S0, S, P ).

or( X, S0, S, P ) :-
	right_hand_side( X, S0a, S, Pa ),
	( var( S0a ), S0a = S, !, S0 = S0a, P=Pa ;
	P = ( S0 = S0a, Pa ) ).
	
tag( X, S0, S, P ) :-
	X =.. [ F | A ],
	appendix( A, [ S0, S ], AX ),
	P =.. [ F | AX ].

andy( true, P, P ) :- !.
andy( P, true, P ) :- !.
andy( P, Q, ( P, Q ) ).

flatten( ( P1 | P2 ), ( Q1 | Q2 ) ) :- 
	!,
	flatten( P1, Q1 ),
	flatten( P2, Q2 ).
flatten( ( ( P1, P2 ), P3 ), Q ) :-
	flatten( ( P1, ( P2, P3 ) ), Q ).
flatten( ( P1, P2 ), ( Q1, Q2 ) ) :- 
	!,
	flatten( P1, Q1 ),
	flatten( P2, Q2 ).
flatten( A, A ) :- !.

inlist( X ) :- ratom( Y ), next( Y, X ).

next('.', [] ) :- !.
next( X, [ X | Y ] ) :- inlist( Y ).

% :- private( [ grammar, translate, left_hand_side, right_hand_side, 
%               or, tag, and, islist, flatten, inlist, next ] ).
         
%%%   phrase( P, L ) succeeds if list L can be parsed as a phrase of type P.
phrase( Ptype, Words ) :-
	Ptype =.. [ Pred | Args ],
	append( Args, [ Words, [] ], Newargs ),
	Goal =.. [ Pred | Newargs ],
	Goal .