 % <pre>
 % ****************************************************************
 %
 % This file contains small extensions to the ALE system
 % Authors: Thilo G"otz and Detmar Meurers
 %          {tg,dm}@sfs.nphil.uni-tuebingen.de
 % Version: 1. June 1994
 %
 % ****************************************************************

:-op(1100,fx,rect).
:-op(1100,fx,rec_all).

 % ****************************************************************
 % I. Removing mutually subsuming entries from the lexicon
 % ****************************************************************

 % replaces .lex.pl by a file without identical entries and reloads it
redu :- ale_red_check('.lex.pl'),
        ['.lex.pl'].

 % Attention! Using this predicate will destroy a loaded lexicon.
ale_red_check(File) :-
	setof(Word,_1^_2^lex(Word,_1,_2,[]),Set),
	!,
	tell(File),
	write('% Reduced ALE lexicon'),nl,
	foreach(Set,ale_red_check1),
	nl,nl,
 %	write(':- style_check(multiple).'),nl,nl,
	told.
 %	[File].
ale_red_check(File) :-
	write('No lexical entries! File "'),
	write(File),
	write('" not created.'),
	nl.

ale_red_check1(Word) :-
	findall(Entry,lex(Word,_,Entry,_),Bag),
	add_numbers(Bag,Bag1),
	ale_red_check2(Bag1,Word).

ale_red_check2([],_).
ale_red_check2([Num-F|R],Word) :-
	ale_red_check3(R,Out,Num-F,Word),
	nl,write('lex('),
	write(Word),write(',_,'),
	lettervars_track(F),
	write(F),
	write(',[]).'),
	ale_red_check2(Out,Word).
ale_red_check3([],[],_,_).
ale_red_check3([Num1-F1|R1],Out,Num-F,Word) :-
	( subsumes_chk(F,F1) ->
	    ( subsumes_chk(F1,F) ->
		Out = Out1,
		write(user_output,' ** Entries '),
		write(user_output,Num),
		write(user_output,' and '),
		write(user_output,Num1),
		write(user_output,' of word "'),
		write(user_output,Word),
		write(user_output,'" subsume each other. Entry '),
		write(user_output,Num1),
		write(user_output,' removed!'),
		nl(user_output)
	    ;   Out = [Num1-F1|Out1],
	        write(user_output,'Entry '),
		write(user_output,Num),
		write(user_output,' of word "'),
		write(user_output,Word),
		write(user_output,'" subsumes entry '),
		write(user_output,Num1),
		write(user_output,'.'),
		nl(user_output)
	    )
	;   Out = [Num1-F1|Out1],
	    ( subsumes_chk(F1,F) ->
		write(user_output,'Entry '),
		write(user_output,Num1),
		write(user_output,' of word "'),
		write(user_output,Word),
		write(user_output,'" subsumes entry '),
		write(user_output,Num),
		write(user_output,'.'),
		nl(user_output)
	    ;   true
	    )
	),
	ale_red_check3(R1,Out1,Num-F,Word).

 % higher order PROLOG
foreach([],_).
foreach([F|R],Predicate) :-
	Instance =.. [Predicate,F],
	write(user_output,'Checking '),write(user_output,F),
	nl(user_output),
	call(Instance),
	foreach(R,Predicate).
add_numbers(S1,S2) :- add_numbers(S1,S2,1).
add_numbers([],[],_).
add_numbers([F|R1],[Num-F|R2],Num) :-
	Num1 is Num + 1,
	add_numbers(R1,R2,Num1).

 % Sicstus 2.1 has this predefined; comment out in Sicstus 0.7
 % subsumes_chk(General, Specific) :-
 %  	\+  (	numbervars(Specific, 0, _),
 % 		\+ General = Specific
 % 	    ).


 % ****************************************************************
 % II. Tool for documentation of macros
 % ****************************************************************

 % "write_macros" prints all macronames currently defined 
 % and the type of the description they abbreviate
 % to a file.
write_macros(File) :-
	tell(File),
	write_macros,
	told.

write_macros :-
          macro(Term,Def),
	functor(Term,Name,_Arity),
	get_type(Def,Type),
	write(Name), write(' '), write(Type), nl,
	fail.
write_macros.

 % hack to get type
get_type(Desc,Type) :-
	check(Desc,X),
	deref(X,_,Term),
	functor(Term,Type,_).

check(Desc,Tag):-
	(add_to(Desc,Tag,bot,[],Iqs),
	extensionalise(Tag,bot,Iqs)).


 % ****************************************************************
 % III. Tools for queries
 % ****************************************************************


 % "rec_all" parses the list of word given as argument and prints
 % all solutions in one blow.
rec_all(Words):-
  nl, write('STRING: '),
  nl, number_display(Words,0), 
  ttynl, rec(Words,Tag,SVs,Iqs),
  nl, write('CATEGORY: '),nl, 
  pp_fs(Tag-SVs,Iqs), 
  nl, fail.
rec_all(_).


 % "rect" parses the list of word given as argument and prints the
 %  number of solutions and cpu time used.
rect(Words):-
	number_display(Words,0), 
	nl,
	length(Words,Length),
	cpu_time(my_rec(Words,Flag),Time),
	( Flag = yes ->
	    bagof(Tag-IqsIn,A^SVs^B^C^edge(A,0,Length,Tag,SVs,IqsIn,B,C),Bag),
	    write('O.k.   '),
	    length(Bag,No)
	;   write(' ### No parse!!!!  '),
              No = 0
          ),
	write(' ** CPU time used (sec): '),write(Time),
          write(',  Solutions:  '),write(No),nl,
	write('*******************************************************************'),nl.


 % All following test predicates assume that a testfile containing facts 
 % of the following format has been loaded:
 %    t(1,   List_of_Words).
 %    t(..., List_of_Words).
 %    t(n,   List_of_Words).
 % For each of the examples tested the test predicate prints out the number
 % of solutions and cpu time used.

 % "test(Nr)" parses the example Nr
test(Nr) :-
	t(Nr,Words),
	write(' * '),write(Nr),write(' >> '),
	rect(Words).


 % "test(From,To)" parses examples From to To
test(From,To) :-
	From @=< To,
	Next is From + 1,
	( t(From,Words) -> 
	    write(' * '),write(From),write(' >> '),
	    rect(Words)
	;   write(' $$$ No entry '),write(From),nl
        ),
	test(Next,To).
test(_,_).


 % "test_all" parses all loaded examples
test_all :-
	t(Nr,Words),
	write(' * '),write(Nr),write(' >> '),
	rect(Words),
	fail.
test_all.


my_rec(Words,yes) :-
	rec(Words,_Tag,_SVs,_Iqs),!.
my_rec(_,no).

time(Goal) :-
	cpu_time(Goal,Time),
	nl,write(' ** Time used (sec): '),write(Time),nl,nl.

cpu_time(Goal,Time) :-
	statistics(runtime,_),
	Goal,
	statistics(runtime,[_,Duration]),
	Time1 is Duration // 100,
	Time is Time1 / 10.

 % ****************************************************************
 % III. Displaying all lexical entry for a given phonology
 % ****************************************************************

 % "all_lex" prints all lexical entries defined for phology 'Word'

all_lex(Word) :-
	lex(Word,Tag,SVs,IqsIn),
	nl, write('WORD: '), write(Word),
	nl, write('ENTRY: '),
	extensionalise(Tag,SVs,IqsIn),
	check_inequal(IqsIn,IqsOut),
	pp_fs(Tag-SVs,IqsOut), 
	nl,
	fail.
all_lex(_).

 % </pre>
