/******************************************************************/
/* AQ1.PRO                                                        */
/* Reimplementation of AQ-Prolog                                  */
/******************************************************************/
/*  impl. by    : Thomas Hoppe                                    */
/*                Mommsenstr. 50                                  */
/*                1000 Berlin 12                                  */
/*                F.R.G.                                          */
/*                E-Mail: hoppet@db0tui11.pro                     */
/*                1986                                            */
/*                                                                */
/*  reference   : AQ-PROLOG: A Prolog Implementation of an        */
/*                Attribute-Based Learning System, Becker, J.M.,  */
/*                Reports of the Intelligent Systems Group,       */
/*                Department of Computer Science, University of   */
/*                Illinois at Urbana-Champaign, Report Number     */
/*                ISG 85-1, January 1985                          */
/*                                                                */
/*                Learning from Observation: Conceptual Clustering*/
/*                Michalski, R.S., Stepp, R.E., in: Machine       */
/*                Learning, Michalski, R.S., Carbonell, J.G.,     */
/*                Mitchell, T.M. (eds.), Tioga Publishing         */
/*                Company, Palo Alto, 1983.                       */
/*                                                                */
/*                Inductive Learning, Michalski, R.S., in: Machine*/
/*                Learning, Michalski, R.S., Carbonell, J.G.,     */
/*                Mitchell, T.M. (eds.), Tioga Publishing         */
/*                Company, Palo Alto, 1983.                       */
/*                                                                */
/******************************************************************/
/* Because the program as a size about 22k, this version is       */
/* nearly undocumented, only the top-level procedures and some    */
/* very special changes against the report are documented.        */
/* For a detailed documentation consult the report.               */
/*                                                                */
/* In general the following changes are implemented:              */
/*                                                                */
/*  - The top-level Routines are modified slidely.                */
/*  - Ambique named predicates are renamed.                       */
/*  - Some special UNSW-PROLOG predicates are removed.            */
/*  - A special 'bagof' predicate was introduced (see below).     */
/*  - Dependant on the 'bagof' predicate some cut's were necessary*/
/*  - Some ambiguity concerning atom comparision was removed.     */
/*  - The unused predicat 'pos_cover_or_events' was removed.      */
/*                                                                */
/******************************************************************/
/* In the whole programm a destinction between < and @<, > and @> */
/* etc. was introduced, which originates in DEC-10 PROLOG.        */
/* The <,>,=< and >= rever to arithmetric comparisions whereas    */
/* @<,@>,@=< and @>= rever to comparisions of atoms. Dependant on */
/* you're local PROLOG system you have eventually to introduce    */
/* them.                                                          */
/******************************************************************/
 
:- op(700,xfx,'..').
 
/******************************************************************/
/*                                                                */
/*  call        : data (+FILENAME)                                */
/*                                                                */
/*  arguments   : FILENAME = dependent on you're local PROLOG     */
/*                                                                */
/*  side effects: Removes a previous loaded dataset               */
/*                                                                */
/******************************************************************/
/* Reads a dataset from the filesystem.                           */
/******************************************************************/
 
data(FILENAME) :-
     clear, nl, write('===> loading '), write(FILENAME), nl,
       see(FILENAME), repeat,
          read(X),
         (X = end_of_file, seen, asserta(dataset(FILENAME)), !;
          process(X), fail) .
 
process(domaintype(ATTR,D)) :-
     assertz(domaintype(ATTR,D)), ! .
process(valueset(ATTR,VALSET)) :-
     qsort(VALSET,VALS), assertz(valueset(ATTR,VALS)), ! .
process(range(ATTR,LOW,HIGH)) :-
     assertz(range(ATTR,LOW,HIGH)), assertz(subtyp(ATTR,integer)),
       ! .
process(order(ATTR,ORD)) :-
     length(ORD,HIGH), assertz(order(ATTR,ORD)),
       assertz(range(ATTR,1,HIGH)),
       assertz(subtyp(ATTR,symbolic)), ! .
process(structure(ATTR,STRUC)) :-
     explodestruc(ATTR,STRUC), assertz(structure(ATTR,STRUC)), ! .
process(classes(CLIST)) :-
     storeclasses(CLIST), ! .
process(events(CLASS,EVENTLIST)) :-
     encodeevents(EVENTLIST,ENCODEDEVENTS),
       storeevents(CLASS,ENCODEDEVENTS), ! .
process(X) :-
     write('===> Invalid Data: '), nl, write(X), ! .
 
storeclasses(CLIST) :-
     member(CLASSNAME,CLIST), assertz(class(CLASSNAME)), fail .
storeclasses(_) .
 
storeevents(CLASS,EVENTLIST) :-
     member(EVENT,EVENTLIST), assertz(event(CLASS,EVENT)), fail .
storeevents(_,_) .
 
/******************************************************************/
/*                                                                */
/*  call        : clear                                           */
/*                                                                */
/******************************************************************/
/* Erases the actual dataset.                                     */
/******************************************************************/
 
clear :-
     clause(dataset(X),true), abolish(domaintype,2),
       abolish(valueset,2), abolish(range,3), abolish(order,2),
       abolish(structure,2), abolish(class,1), abolish(event,2),
       abolish(subtyp,2), abolish(ancest,3), nl, write('===> Data '),
       write(X), write(' deleted.'), nl, abolish(dataset,1) .
clear .
 
/******************************************************************/
/*                                                                */
/*  call        : listdata                                        */
/*                                                                */
/******************************************************************/
/* Display's the actual dataset                                   */
/******************************************************************/
 
listdata :-
     nl, clause(dataset(DATA_SET_NAME),true),
       write('===> Datenset '), write(DATA_SET_NAME),
       write(:), nl, printdomaininfo, nl, printevents, ! .
 
printdomaininfo :-
     clause(domaintype(VAR,DTYPE),true),
       write('===> Variable '), write(VAR),
       write(' of type '), write(DTYPE), write('.'), nl,
       fail .
printdomaininfo .
 
printevents :-
     clause(class(CLASS),true), clause(event(CLASS,EVENT),true),
       printcomplex(EVENT), write(' ::> '), write(CLASS), nl,
       fail .
printevents .
 
/******************************************************************/
/*                                                                */
/*  call        : start                                           */
/*                                                                */
/******************************************************************/
/* Start is the top-level loop of AQ-PROLOG. AQ can compute in    */
/* three different modes ic: Intersecting Covers, dc: Disjoint    */
/* Covers and vl: VL mode (a sequential  one).                    */
/******************************************************************/
 
start :-
     nl,
       write('===> Maximal number of Stars in the next run ?'),
       nl, read(MAX_STAR), nl, nl, repeat,
       write('===> Which mode in the next run ?'), nl, nl,
       write('      ic: Intersecting Covers'), nl,
       write('      dc: Disjoint Covers'), nl,
       write('      vl: VL mode (sequential)'), nl,
       read(MODE), nl, abolish(cover,2), nl,
       makecovers(MODE,MAX_STAR), showcovers, nl, nl, nl,
       write('===> You wanna try a different mode (yes,no) ?'),
       nl, read(RETRY), nl, RETRY==no, write('===> OK'), nl, ! .
 
makecovers(ic,MAX_STAR) :-
     clause(class(CLASS),true), posevents(CLASS,EPOS),
       negevents(CLASS,ENEG),
       aq(EPOS,ENEG,EPOS,EPOS,MAX_STAR,[[]],COVER),
       storecover(CLASS,COVER), fail .
makecovers(ic,_) :-
     ! .
makecovers(dc,MAX_STAR) :-
     clause(class(CLASS),true), posevents(CLASS,EPOS),
       neg_cover_or_events(CLASS,ENEG),
       aq(EPOS,ENEG,EPOS,EPOS,MAX_STAR,[[]],COVER),
       storecover(CLASS,COVER), fail .
makecovers(dc,_) :-
     ! .
makecovers(vl,MAX_STAR) :-
     clause(class(CLASS),true), posevents(CLASS,EPOS),
       followingevents(CLASS,ENEG),
       aq(EPOS,ENEG,EPOS,EPOS,MAX_STAR,[[]],COVER),
       storecover(CLASS,COVER), fail .
makecovers(vl,_) :-
     ! .
makecovers(X,_) :-
     nl, write('===> ERROR - only the modes ic, dc or vl'),
       write(' are valid !'), nl, fail .
 
storecover(CLASS,COVER) :-
     member(COMPLEX,COVER), assertz(cover(CLASS,COMPLEX)), fail .
storecover(_,_) .
 
posevents(CLASS,EPOS) :-
     find_bag(EVENT,clause(event(CLASS,EVENT),true),EPOS), ! .
 
negevents(CLASS,ENEG) :-
     find_bag(EVENT,negevent(CLASS,EVENT),ENEG), ! .
 
negevent(CLASS,EVENT) :-
     clause(event(NEG_CLASS,EVENT),true), not(NEG_CLASS=CLASS) .
 
cover_or_event(CLASS,COMP) :-
     clause(cover(CLASS,COMP),true) .
cover_or_event(CLASS,COMP) :-
     clause(event(CLASS,COMP),true) .
 
/******************************************************************/
/* Against the AQ-PROLOG document the cut in neg_cover_or_events  */
/* is necessary to prevent backtracking, when the first clause of */
/* makecovers fails.                                              */
/******************************************************************/
 
neg_cover_or_events(CLASS,NEG_COMPS) :-
     find_bag(COMP,negcomp(CLASS,COMP),NEG_COMPS), ! .
 
negcomp(CLASS,COMP) :-
     cover_or_event(NEG_CLASS,COMP), not(NEG_CLASS=CLASS) .
 
/******************************************************************/
/* Watch out, this is the only occurence of 'bagof' for a correct */
/* instantiation of CLASSES to an unmodified ordering see the     */
/* discussion of 'bagof' below.                                   */
/******************************************************************/
 
followingevents(CLASS,SEVENTS) :-
     bagof(CLASS_NAME,clause(class(CLASS_NAME),true),CLASSES),
       following(CLASS,CLASSES,FCLASSES),
       find_bag(EVENT,followev(FCLASSES,EVENT),SEVENTS), ! .
 
followev(FCLASSES,EVENT) :-
     member(CLASS,FCLASSES), clause(event(CLASS,EVENT),true) .
 
aq(_,_,[],_,_,_,[]) :-
     ! .
aq(ELIST,FLIST,UN_COVERED,[],MAX_STAR,BOUND,RESULT) :-
     write('===> Please wait a moment ...'), nl, !,
       aq(ELIST,FLIST,UN_COVERED,UN_COVERED,MAX_STAR,BOUND,RESULT
           ) .
aq(ELIST,FLIST,UN_COVERED,SEED_LIST,MAX_STAR,BOUND,[BEST|COVER]) :-
     !, first(SEED_LIST,SEED),
       star(SEED,FLIST,MAX_STAR,[ELIST,UN_COVERED],BOUND,STAR),
       lef(LEF),
       selectbest(STAR,1,LEF,[ELIST,UN_COVERED],[BEST_COMP]),
       coveredbycomplex(BEST_COMP,UN_COVERED,COVERED_EVENTS),
       trim(BEST_COMP,COVERED_EVENTS,BEST),
       knockout1(BEST,UN_COVERED,NEW_UN_COVERED),
       knockout(STAR,SEED_LIST,NEW_SEED_LIST),
       aq(ELIST,FLIST,NEW_UN_COVERED,NEW_SEED_LIST,MAX_STAR,BOUND
           ,COVER), ! .
 
/******************************************************************/
/* I'am not sure if the last cut in aq is necessary, but it works */
/* correctly with it.                                             */
/******************************************************************/
 
star(_,[],_,_,PSTAR,PSTAR) :-
     ! .
star(E,[F|FTAIL],MAX_STAR,LEF_ARGS,PSTAR,NEW_PSTAR) :-
     !, extendagainst(E,F,ESTAR), multiply(PSTAR,ESTAR,F,EP_STAR),
       absorb(EP_STAR,MAX_STAR,AP_STAR),
       lef(LEF),
       selectbest(AP_STAR,MAX_STAR,LEF,LEF_ARGS,REDUCED_STAR),
       star(E,FTAIL,MAX_STAR,LEF_ARGS,REDUCED_STAR,NEW_PSTAR) .
 
multiply(COM_SET,PSTAR,NEG_EVENT,EP_STAR) :-
     find_bag(NEW_COMPS,(member(COMP,COM_SET),dis_or_mult(COMP,
         PSTAR,NEG_EVENT,NEW_COMPS)),EP_LIST),
       appendx(EP_LIST,EP_STAR), ! .
 
/******************************************************************/
/* DIS_OR_MULT was introduced, because in AQ-PROLOG the definition*/
/* of multiply is heavily dependant on UNSW-PROLOG. The definition*/
/* serves the purpose of a substitution for the '->' operator,    */
/* which seems to be the IF-THEN-ELSE definition in UNSW-PROLOG.  */
/******************************************************************/
 
dis_or_mult(COMP,_,NEG,ERG) :-
     disjointcomps(COMP,NEG), ERG=[COMP], ! .
dis_or_mult(COMP,PSTAR,_,NEW) :-
     find_bag(A,(member(P,PSTAR),product(COMP,P,A)),NEW), ! .
 
absorb(STAR,MAX_STAR,ASTAR) :-
     length(STAR,N), N>MAX_STAR, !, absourbr(STAR,[],STAR1),
       absourbr(STAR1,[],ASTAR) .
absorb(STAR,_,STAR) .
 
absourbr([],S,S) :-
     ! .
absourbr([C|S],B,AR_STAR) :-
     !, knockout1(C,S,RS), absourbr(RS,[C|B],AR_STAR) .
 
selectbest(PSTAR,MAX_SIZE,_,_,PSTAR) :-
     length(PSTAR,L), L=<MAX_SIZE, ! .
selectbest(PSTAR,MAX_SIZE,[CT|CTX],LEF_ARGS,REDUCED_STAR) :-
     !, reduce(PSTAR,CT,LEF_ARGS,RSTAR),
       selectbest(RSTAR,MAX_SIZE,CTX,LEF_ARGS,REDUCED_STAR) .
selectbest(PSTAR,MAX_SIZE,[],_,RSTAR) :-
     firstn(PSTAR,MAX_SIZE,RSTAR), ! .
 
reduce(PSTAR,[CRIT_FN,N,D],[EPLUS,UN_COV_EPLUS],RSTAR) :-
     GET_CRIT_FN=..[CRIT_FN,COMP,EPLUS,UN_COV_EPLUS,V],
       find_bag(VC,(member(COMP,PSTAR),GET_CRIT_FN,VC=[V,COMP]),
           VLIST), minmax(VLIST,MIN,MAX),
       TOL is MIN+(N*(MAX-MIN))/D,
       find_bag(C,(member([V,C],VLIST),V=<TOL),RSTAR), ! .
 
minmax([[X,_],[Y,_]|R],MIN,MAX) :-
     X=<Y, !, lohi([X,Y|R],MIN,MAX) .
minmax([[X,_],[Y,_]|R],MIN,MAX) :-
     !, lohi([Y,X|R],MIN,MAX) .
 
lohi([X,Y,[Z,_]|R],MIN,MAX) :-
     !, min([X,Z],A), max([Y,Z],B), lohi([A,B|R],MIN,MAX) .
lohi([X,Y],X,Y) :-
     ! .
 
numbercovered(COMP,_,EVENTS,N) :-
     coveredbycomplex(COMP,EVENTS,COVERED_E), length(COVERED_E,P),
       N is - P, ! .
 
numberofselectors(COMP,_,_,N) :-
     length(COMP,N), ! .
 
lef([[numbercovered,0,1],[numberofselectors,0,1]]) .
 
knockout(OUTER_COMPS,INNER_COMPS,UN_COV_COMPS) :-
     !,
       find_bag(IN_COMP,call((member(IN_COMP,INNER_COMPS),
           nonecover(OUTER_COMPS,IN_COMP))),UN_COV_COMPS) .
 
nonecover([],IN_COMP) :-
     ! .
nonecover([COMP|CX],IN_COMP) :-
     !, not(covers(COMP,IN_COMP)), nonecover(CX,IN_COMP) .
 
knockout1(OUTER_C,INNER_COMPS,UN_COV_COMPS) :-
     !,
       find_bag(IN_C,call((member(IN_C,INNER_COMPS),not(covers(
           OUTER_C,IN_C)))),UN_COV_COMPS) .
 
coveredbycomplex(COMPLEX,EVENTS,COVERED_E) :-
     find_bag(E,(member(E,EVENTS),covers(COMPLEX,E)),COVERED_E),
       ! .
 
newselector([A1=V1|T1],A1=V2,[A1=V2|T1]) :-
     ! .
newselector([A1=V1|T1],A2=V2,[A1=V1|T3]) :-
     A1@<A2, !, newselector(T1,A2=V2,T3) .
newselector([A1=V1|T1],A2=V2,[A2=V2,A1=V1|T1]) :-
     A1@>A2, ! .
newselector([],SEL,[SEL]) :-
     ! .
 
covers([A=OUT_VAL|OUT_C],[A=IN_VAL|IN_C]) :-
     !, includes(A=OUT_VAL,A=IN_VAL), covers(OUT_C,IN_C) .
covers([A1=OUT_V|OUT_C],[A2=IN_V|IN_C]) :-
     !, A2@<A1, covers([A1=OUT_V|OUT_C],IN_C) .
covers([],_) :-
     ! .
 
includes(ATTR=OUT_VALS,ATTR=IN_VALS) :-
     clause(domaintype(ATTR,nominal),true), !,
       subset(IN_VALS,OUT_VALS) .
includes(ATTR=OUT_VALS,ATTR=IN_VALS) :-
     clause(domaintype(ATTR,linear),true), !,
       includeslin(OUT_VALS,IN_VALS) .
includes(ATTR=OUT_VALS,ATTR=IN_VALS) :-
     clause(domaintype(ATTR,structured),true), !,
       supremum(ATTR,OUT_VALS,IN_VALS) .
 
disjointcomps([A=V1|T1],[A=V2|T2]) :-
     !, disjointsel(A=V1,A=V2) .
disjointcomps([_|T1],[_|T2]) :-
     !, disjointcomps(T1,T2) .
 
disjointsel(ATTR=VALS1,ATTR=VALS2) :-
     clause(domaintype(ATTR,nominal),true), !,
       disjoint(VALS1,VALS2) .
disjointsel(ATTR=VALS1,ATTR=VALS2) :-
     clause(domaintype(ATTR,linear),true), !,
       disjointlin(VALS1,VALS2) .
disjointsel(ATTR=VALS1,ATTR=VALS2) :-
     clause(domaintype(ATTR,structured),true), !,
       not(supremum(ATTR,VALS1,VALS2)),
       not(supremum(ATTR,VALS2,VALS1)) .
 
negate(COMPLEX,NEG_COMPS) :-
     find_bag(NEGC,(member(SEL,COMPLEX),negatesel(SEL,NSEL),NEGC=
         [NSEL]),NEG_COMPS), ! .
 
negatesel(ATTR=VALS,ATTR=NEG_VALS) :-
     clause(domaintype(ATTR,nominal),true), !,
       clause(valueset(ATTR,ALL_VALS),true),
       difference(ALL_VALS,VALS,NEG_VALS), not(NEG_VALS = []) .
negatesel(ATTR=VALS,ATTR=NEG_VALS) :-
     clause(domaintype(ATTR,linear),true), !,
       negatelin(ATTR,VALS,NEG_VALS), not(NEG_VALS = []) .
 
extendagainst([A=VP|P],[A=VN|N],[[A=VX]|X]) :-
     extendref(A=VP,A=VN,A=VX), !, extendagainst(P,N,X) .
extendagainst([AP=VP|P],[AN=VN|N],X) :-
     AP@<AN, !, extendagainst(P,[AN=VN|N],X) .
extendagainst([AP=VP|P],[AN=VN|N],X) :-
     !, extendagainst([AP=VP|P],N,X) .
extendagainst([],_,[]) :-
     ! .
extendagainst(_,[],[]) :-
     ! .
 
extendref(ATTR=POS_VALS,ATTR=NEG_VALS,ATTR=EXT_VALS) :-
     clause(domaintype(ATTR,nominal),true), !,
       disjoint(POS_VALS,NEG_VALS),
       negatesel(ATTR=NEG_VALS,ATTR=EXT_VALS) .
extendref(ATTR=POS_VALS,ATTR=NEG_VALS,ATTR=EXT_VALS) :-
     clause(domaintype(ATTR,linear),true), !,
       disjointlin(POS_VALS,NEG_VALS),
       negatelin(ATTR,NEG_VALS,NN_VALS),
       extendedlin(POS_VALS,NN_VALS,EXT_VALS) .
extendref(ATTR=POS_VAL,ATTR=NEG_VAL,ATTR=EXT_VAL) :-
     clause(domaintype(ATTR,structured),true), !,
       supremum(ATTR,EXT_VAL,POS_VAL),
       not(supremum(ATTR,EXT_VAL,NEG_VAL)),
       parent(ATTR,EXT_VAL,EXT_PARENT),
       supremum(ATTR,EXT_PARENT,NEG_VAL) .
 
refunion([C1,C2|T],REFU) :-
     !, refu(C1,C2,C3), refunion([C3|T],REFU) .
refunion([COMP],COMP) :-
     ! .
 
refu([A=V1|C1],[A=V2|C2],[A=VU|CU]) :-
     selunion(A=V1,A=V2,A=VU), !, refu(C1,C2,CU) .
refu([A1=V1|C1],[A2=V2|C2],U) :-
     A1@<A2, !, refu(C1,[A2=V2|C2],U) .
refu([A1=V1|C1],[A2=V2|C2],U) :-
     !, refu([A1=V1|C1],C2,U) .
refu([],_,[]) :-
     ! .
refu(_,[],[]) :-
     ! .
 
selunion(ATTR=VALS1,ATTR=VALS2,ATTR=UVALS) :-
     clause(domaintype(ATTR,nominal),true), !,
       union(VALS1,VALS2,UVALS),
       clause(valueset(ATTR,ALL_VALS),true),
       not(equals(UVALS,ALL_VALS)) .
selunion(ATTR=VALS1,ATTR=VALS2,ATTR=UVALS) :-
     clause(domaintype(ATTR,linear),true), !, low(VALS1,L1),
       low(VALS2,L2), min([L1,L2],LOW), highest(VALS1,H1),
       highest(VALS2,H2), max([H1,H2],HIGH),
       clause(range(ATTR,MIN,MAX),true), not(LOW=MIN),
       not(HIGH==MAX), UVALS==[LOW..HIGH], ! .
selunion(ATTR=VAL1,ATTR=VAL2,ATTR=UV_AL) :-
     clause(domaintype(ATTR,structured),true),
       supremum(ATTR,UV_AL,VAL1), supremum(ATTR,UV_AL,VAL2) .
 
product([A=V1|T1],[A=V2|T2],[A=V3|T3]) :-
     !, selproduct(A=V1,A=V2,A=V3), !, product(T1,T2,T3) .
product([A1=V1|T1],[A2=V2|T2],[A1=V1|T3]) :-
     A1@<A2, !, product([A2=V2|T2],T1,T3) .
product([A1=V1|T1],[A2=V2|T2],[A2=V2|T3]) :-
     !, product([A1=V1|T1],T2,T3) .
product(X,[],X) :-
     ! .
product([],X,X) :-
     ! .
 
selproduct(ATTR=VALS1,ATTR=VALS2,ATTR=PROD_VALS) :-
     clause(domaintype(ATTR,nominal),true), !,
       intersection(VALS1,VALS2,PROD_VALS), not(PROD_VALS = []) .
selproduct(ATTR=VALS1,ATTR=VALS2,ATTR=PROD_VALS) :-
     clause(domaintype(ATTR,linear),true), !,
       productlin(VALS1,VALS2,PROD_VALS), not(PROD_VALS = []) .
selproduct(ATTR=VALS1,ATTR=VALS2,ATTR=VALS1) :-
     clause(domaintype(ATTR,structured),true),
       supremum(ATTR,VALS2,VALS1), ! .
selproduct(ATTR=VALS1,ATTR=VALS2,ATTR=VALS2) :-
     clause(domaintype(ATTR,structured),true),
       supremum(ATTR,VALS1,VALS2), ! .
 
trim(COMP,COVERED_EVENTS,TRIMMED_COMP) :-
     !, refunion(COVERED_EVENTS,REFU),
       trimcomp(COMP,REFU,TRIMMED_COMP) .
 
trimcomp([A=V1|C1],[A=VU|CU],[A=VT|CT]) :-
     !, selproduct(A=V1,A=VU,A=VT), trimcomp(C1,CU,CT) .
trimcomp([A1=V1|C1],[A2=VU|CU],CT) :-
     A2@<A1, !, trimcomp([A1=V1|C1],CU,CT) .
trimcomp([A1=V1|C1],[A2=VU|CU],[A1=V1|CT]) :-
     !, trimcomp(C1,[A2=VU|CU],CT) .
trimcomp(X,[],X) :-
     ! .
trimcomp([],_,[]) :-
     ! .
 
encodeevents([],[]) :-
     ! .
encodeevents([E|REST],[EE|ENCODE_REST]) :-
     !, encodeevent(E,[],EE), encodeevents(REST,ENCODE_REST) .
 
encodeevent([],EVENT,EVENT) :-
     ! .
encodeevent([SEL|E],PARTIAL_EV,NEW_PARTIAL_EV) :-
     !, encodesel(SEL,ENCODED_SEL),
       newselector(PARTIAL_EV,ENCODED_SEL,PPEV),
       encodeevent(E,PPEV,NEW_PARTIAL_EV) .
 
encodesel([ATTR=VAL],ATTR=[VAL]) :-
     clause(domaintype(ATTR,nominal),true), ! .
encodesel([ATTR=VAL],ATTR=[VAL..VAL]) :-
     clause(domaintype(ATTR,linear),true),
       clause(subtyp(ATTR,integer),true), ! .
encodesel([ATTR=SYM],ATTR=[ORD..ORD]) :-
     clause(domaintype(ATTR,linear),true),
       clause(subtyp(ATTR,'symbolic'),true), !, ord(ATTR,SYM,ORD) .
encodesel([ATTR=VAL],ATTR=VAL) :-
     clause(domaintype(ATTR,structured),true), ! .
encodesel(S,_) :-
     write('===> ERROR - unknown selector type: '), write(S) .
 
showcovers :-
     clause(class(CLASS),true), showcover(CLASS), fail .
showcovers .
 
showcover(CLASS) :-
     nl, nl, write('===> Cover of class '), write(CLASS),
       write(':'), !, nl, clause(cover(CLASS,COVER),true),
       printcomplex(COVER), nl, fail .
showcover(_) .
 
printcomplex(COMPLEX) :-
     member(SELECTOR,COMPLEX), printselector(SELECTOR), fail .
printcomplex(_) :-
     ! .
 
printselector(ATTR=VALS) :-
     clause(domaintype(ATTR,nominal),true), !, write('['),
       write(ATTR), write(' = '), prinlist(VALS), write(']') .
printselector(ATTR=VALS) :-
     clause(domaintype(ATTR,linear),true),
       clause(subtyp(ATTR,integer),true), !, write('['),
       write(ATTR), write(' = '), prinlin(VALS), write(']') .
printselector(ATTR=VALS) :-
     clause(domaintype(ATTR,linear),true),
       clause(subtyp(ATTR,'symbolic'),true), !, write('['),
       write(ATTR), write(' = '), prinsym(ATTR,VALS), write(']') .
printselector(ATTR=VAL) :-
     clause(domaintype(ATTR,structured),true), !, write('['),
       write(ATTR), write(' = '), write(VAL), write(']') .
 
intersection([A|B],[A|C],[A|X]) :-
     !, intersection(B,C,X) .
intersection([A|B],[C|D],X) :-
     A@<C, !, intersection([C|D],B,X) .
intersection([A|B],[C|D],X) :-
     !, intersection([A|B],D,X) .
intersection(Y,[],[]) :-
     ! .
intersection([],Y,[]) :-
     ! .
 
difference([A|B],[A|C],X) :-
     !, difference(B,C,X) .
difference([A|B],[C|D],[A|X]) :-
     A@<C, !, difference(B,[C|D],X) .
difference([A|B],[C|D],[C|X]) :-
     !, difference([A|B],D,X) .
difference(Y,[],Y) :-
     ! .
difference([],Y,[]) :-
     ! .
 
union([A|B],[A|C],[A|X]) :-
     !, union(B,C,X) .
union([A|B],[C|D],[A|X]) :-
     A@<C, !, union([C|D],B,X) .
union([A|B],[C|D],[C|X]) :-
     !, union([A|B],D,X) .
union(Y,[],Y) :-
     ! .
union([],Y,Y) :-
     ! .
 
disjoint([A|B],[C|D]) :-
     A@<C, !, disjoint([C|D],B) .
disjoint([A|B],[C|D]) :-
     C@<A, !, disjoint([A|B],D) .
disjoint(_,[]) :-
     ! .
disjoint([],_) :-
     ! .
 
subset([A|B],[A|C]) :-
     !, subset(B,C) .
subset([A|B],[C|D]) :-
     A@>C, !, subset([A|B],D) .
subset([],_) :-
     ! .
 
equals(X,Y) :-
     X=Y, ! .
 
cardinality(X,N) :-
     !, length(X,N) .
 
ord(ATTR,SYM,N) :-
     clause(order(ATTR,L),true), at(SYM,L,N,1), ! .
 
at(SYM,[SYM|X],N,N) .
at(SYM,[_|X],N,I) :-
     J is I+1, at(SYM,X,N,J), ! .
at(_,_,_,_) :-
     write('===> ERROR - symbol undeclared') .
 
low([L..H|_],L) .
 
highest([L..H],H) .
highest([L..H|X],HIGH) :-
     !, highest(X,HIGH) .
 
includeslin(_,[]) .
includeslin([LO..HO|XO],[LI..HI|XI]) :-
     HO@<LI, !, includeslin(XO,[LI..HI|XI]) .
includeslin([LO..HO|XO],[LI..HI|XI]) :-
     !, LO@=<LI, HO@>=HI, includeslin([LO..HO|XO],XI) .
 
disjointlin([],_) :-
     ! .
disjointlin(_,[]) :-
     ! .
disjointlin([L1..H1|X1],[L2..H2|X2]) :-
     H1@<L2, !, disjointlin(X1,[L2..H2|X2]) .
disjointlin([L1..H1|X1],[L2..H2|X2]) :-
     H2@<L1, !, disjointlin(X2,[L1..H1|X1]) .
 
negatelin(ATTR,[LP..HP|XP],N) :-
     !, neglinlow(ATTR,LP,LOW), neglinmid([LP..HP|XP],HI,MID),
       neglinhi(ATTR,HI,HIGH), appendx([LOW,MID,HIGH],N) .
 
neglinlow(ATTR,LP,[]) :-
     clause(range(ATTR,LP,_),true), ! .
neglinlow(ATTR,LP,[LOW..H]) :-
     !, clause(range(ATTR,LOW,_),true), H is LP-1 .
 
neglinmid([L..H],H,[]) :-
     ! .
neglinmid([L1..H1,L2..H2|X],HI,[L..H,N]) :-
     L2>H1+1, !, L is H1+1, H is L2-1,
       neglinmid([L2..H2|X],HI,N) .
neglinmid([L1..H1,L2..H2|X],HI,N) :-
     !, neglinmid(X,HI,N) .
 
neglinhi(ATTR,HI,[]) :-
     clause(range(ATTR,_,HI),true), ! .
neglinhi(ATTR,HI,[L..HIGH]) :-
     !, clause(range(ATTR,_,HIGH),true), L is HI+1 .
 
extendedlin(_,[],[]) :-
     ! .
extendedlin([],_,[]) :-
     ! .
extendedlin([LP..HP|XP],[LN..HN|XN],XVALS) :-
     HN@<LP, !, extendedlin([LP..HP|XP],XN,XVALS) .
extendedlin([LP..HP|XP],[LN..HN|XN],XVALS) :-
     HP@<LN, !, extendedlin(XP,[LN..HN|XN],XVALS) .
extendedlin([LP..HP|XP],[LN..HN|XN],[LN..HN|XVALS]) :-
     !, LN@=<LP, HN@>=HP, extendedlin(XP,XN,XVALS) .
 
productlin([],_,[]) :-
     ! .
productlin(_,[],[]) :-
     ! .
productlin([L1..H1|X1],[L2..H2|X2],P) :-
     H1@<L2, !, productlin(X1,[L2..H2|X2],P) .
productlin([L1..H1|X1],[L2..H2|X2],P) :-
     H2@<L1, !, productlin(X2,[L1..H1|X1],P) .
productlin([L1..H1|X1],[L2..H2|X2],[L..H|P]) :-
     !, max([L1,L2],L), min([H1,H2],H), productlin(X1,X2,P) .
 
prinlin([A]) :-
     !, prinseg(A) .
prinlin([A,B]) :-
     !, prinseg(A), write(' v '), prinlin(B) .
prinlin([]) :-
     !, write('===> ERROR - null RHS in linear selector') .
 
prinseg(L..H) :-
     L=H, write(L), ! .
prinseg(A) :-
     write(A), ! .
 
prinsym(ATTR,[A]) :-
     !, prinsymseg(ATTR,A) .
prinsym(ATTR,[A|B]) :-
     !, prinsymseg(ATTR,A), write(','), prinsym(ATTR,B) .
prinsym(_,[]) :-
     !, write('===> ERROR - null RHS in linear selector') .
 
prinsymseg(ATTR,L..H) :-
     L=H, ord(ATTR,SYM,L), write(SYM), ! .
prinsymseg(ATTR,L..H) :-
     ord(ATTR,SYML,L), ord(ATTR,SYMH,H), write(SYML..SYMH), ! .
 
/******************************************************************/
/* In AQ-PROLOG the procedure 'predecessor' is called 'ancestor'. */
/* Because in some (I think the most) PROLOG dialects a build-in  */
/* predicate 'ancestor' exists, I preferred to rename it.         */
/******************************************************************/
 
supremum(ATTR,HI_NODE,LO_NODE) :-
     clause(ancest(ATTR,LO_NODE,ALIST),true),
       member(HI_NODE,ALIST) .
supremum(ATTR,X,X) .
 
parent(ATTR,NODE,PARENT) :-
     clause(ancest(ATTR,NODE,[P|_]),true) .
 
explodestruc(ATTR,STRUCTUR_SPEC) :-
     allnodes(STRUCTUR_SPEC,NODE_LIST), member(NODE,NODE_LIST),
       predecessorlist(NODE,STRUCTUR_SPEC,ALIST),
       assertz(ancest(ATTR,NODE,ALIST)), fail .
explodestruc(_,_) .
 
allnodes([],[]) :-
     ! .
allnodes([parent(SIBS,P)|X],NODE_LIST) :-
     !, qsort(SIBS,L1), union(L1,[P],L2), allnodes(X,L3),
       union(L2,L3,NODE_LIST) .
 
/******************************************************************/
/* In AQ-PROLOG the procedure 'predecessorlist' is called         */
/* 'ancestorlist' Because I wanna be a little bit consistend in   */
/* the naming of predicates and 'ancestor' was already renamed    */
/* I preferred to rename this predicate too.                      */
/******************************************************************/
 
predecessorlist(NODE,STRUCTUR_SPEC,[P|X]) :-
     father(NODE,STRUCTUR_SPEC,P), !,
       predecessorlist(P,STRUCTUR_SPEC,X) .
predecessorlist(_,_,[]) :-
     ! .
 
father(NODE,[parent(SIBS,P)|X],P) :-
     member(NODE,SIBS), ! .
father(NODE,[_|X],P) :-
     father(NODE,X,P), ! .
 
first([A|B],A) :-
     ! .
 
appendx(X,Y) :-
     find_bag(A,(member(B,X),member(A,B)),Y), ! .
 
firstn(_,0,[]) :-
     ! .
firstn([A|B],N,[A|C]) :-
     !, M is N-1, firstn(B,M,C) .
firstn([],_,[]) :-
     ! .
 
following(X,[X|AFTER_X],AFTER_X) :-
     ! .
following(X,[_|LIST],AFTER_X) :-
     !, following(X,LIST,AFTER_X) .
following(X,[],[]) :-
     ! .
 
qsort(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([],_,[],[]) .
 
remove(X,[],[]) :-
     ! .
remove(X,[X|B],C) :-
     !, remove(X,B,C) .
remove(X,[A|B],[A|C]) :-
     !, remove(X,B,C) .
 
prinlist([A]) :-
     write(A), ! .
prinlist([A|B]) :-
     !, write(A), write(' v '), prinlist(B) .
prinlist([]) :-
     write('===> Nothing to print'), ! .
 
min([X,Y|T],Z) :-
     X@=<Y, !, min([X|T],Z) .
min([X,Y|T],Z) :-
     !, min([Y|T],Z) .
min([X],X) :-
     ! .
 
max([X,Y|T],Z) :-
     X@>=Y, !, max([X|T],Z) .
max([X,Y|T],Z) :-
     !, max([Y|T],Z) .
max([X],X) :-
     ! .
 
/******************************************************************/
/* Here comes now the most crucial part of AQ-PROLOG. As I've     */
/* foundout their exists at least four definitions of the         */
/* Clocksin/Mellish predicat 'bagof' in different PROLOG dialects */
/*                                                                */
/*  1) The Clocksin/Mellish definition                            */
/*     which is backtrackable so that on each backtrack the bag is*/
/*     shortened by one element.                                  */
/*  2) The MPROLOG definition                                     */
/*     which is not backtrackable and delivers the bag in         */
/*     reversed order (compared with Clocksin-Mellish)            */
/*  3) A special definition (KIT-CORE-PROLOG on Symbolics)        */
/*     which is not backtrackable, but delivers the bag in        */
/*     Clocksin/Mellish order                                     */
/*  3) The TURBO-PROLOG definition                                */
/*     which is not backtrackable, but delivers the bag in        */
/*     MPROLOG order                                              */
/******************************************************************/
/* The first thing you must do, when you wanna experiment with    */
/* AQ-PROLOG is to find out, with which definition of 'bagof'     */
/* you're local PROLOG-System works. In this version of AQ-PROLOG */
/* I need two definitions of 'bagof'. The one I used in           */
/* 'followingevents' is the MPROLOG definition, for the Vl-mode   */
/* it's crucial to deliver this bag in reversed order (compared   */
/* with Clocksin-Mellish). The second definition is called        */
/* 'find_bag' and is given below. It is a modified version of the */
/* Clocksin/Mellish definition, which reverses explicitly the     */
/* order of the delivered bag. This is necessary because AQ-PROLOG*/
/* orders the attributes and generalized values of covers, stars, */
/* complexes and events ! I'm sure that the backtrackability is a */
/* necessary feature for the 'find_bag's used in AQ-PROLOG.       */
/******************************************************************/
 
find_bag(X,G,L) :-
     findbag(X,G,ZWERG), sort(ZWERG,L) .
 
/******************************************************************/
/* This is the Clocksin/Mellish definition of 'bagof', if you're  */
/* local PROLOG system has a different form of 'bagof' implemented*/
/* you can use this one. It works correctly.                      */
/* Otherwise you have only to rename 'findbag' in the definition  */
/* of 'find_bag'.                                                 */
/******************************************************************/
/* findbag(X,G,_) :-                                              */
/*      asserta(yk_found(mark)), call(G),                         */
/*        asserta(yk_found(X)), fail .                            */
/* findbag(_,_,L) :-                                              */
/*      yk_collect_found(L) .                                     */
/*                                                                */
/* yk_collect_found(X.L) :-                                       */
/*      yk_getnext(X), yk_collect_found(L) .                      */
/* yk_collect_found(nil) .                                        */
/*                                                                */
/* yk_getnext(X) :-                                               */
/*      retract(yk_found(X)), !, not (X == mark) .                */
/******************************************************************/
 
 :- nl, nl, write('===> AQ-PROLOG'), nl,
  write('===> Load data with command: data (fn)'), nl,
  write('===> Start AQ  with command: start'), nl, nl .