/*---------------------------------------------------------------*/
/*   Winston's incremental learning procedure for structural     */
/*   descriptions (ARCH)                                         */
/*   Copyright (c) 1990 Ivan Bratko                              */
/*   Modified and adapted for Sicstus Prolog by Zdravko Markov   */
/*---------------------------------------------------------------*/
/*   Reference: Ivan Bratko, Prolog Programming for AI (Ch.18)   */
/*              2nd edition, Addison-Wesley, 1990                */
/*                                                               */
/*   Call       lrn(-Concept)                                    */
/*---------------------------------------------------------------*/
/*   This is a restricted version of Winston's incremental       */
/*   learning procedure for structural descriptions:             */
/*    - The first example must be positive.                      */
/*    - Up to six objects can be handled.                        */
/*    - The list containing missing or extra descriptors of      */
/*      a concept can contain only 3 descriptors.                */
/*                                                               */
/*   The representation used:                                    */
/*    Object  = object(ListOfParts,ListOfRelations)              */
/*    Concept = concept(ListOfParts,MustRels,Rels,MustNotRels)   */
/*    Positive example = pos Object                              */
/*    Negative example = neg Object                              */
/*                                                               */
/*   Object parts are represented by Prolog variables.           */
/*   In the concept description they are represented by          */
/*   constants (i.e. part1, ...)                                 */
/*---------------------------------------------------------------*/
?- op(500,fx,pos).
?- op(500,fx,neg).

lrn(Concept) :-
     findall(X,example(X),L),
     lrn(L,Concept).

lrn([FirstExample|Examples],ConceptDesc) :-
     write(FirstExample),nl,
     initialize(FirstExample,InitialHypothesis),
     write(InitialHypothesis),nl,nl,
     process_examples(InitialHypothesis,Examples,ConceptDesc).

initialize(pos object(Parts,Rels), concept(Parts,[],Rels,[])) :-
     append1(Parts,_,[part1,part2,part3,part4,part5,part6]).

process_examples(ConceptDesc,[],ConceptDesc) :- !.
process_examples(CurDesc,[Example|Examples],FinDesc) :-
     write(Example),nl,
     object_type(Example,Object,Type),
     match(Object,CurDesc,Difference),
     update(Type,Difference,CurDesc,NewDesc),
     write(NewDesc),nl,nl, !,
     process_examples(NewDesc,Examples,FinDesc).

object_type(pos Object,Object,positive).
object_type(neg Object,Object,negative).

/*---------------------------------------------------------------*/
/*  Call:       match(+ObjectDesc,+ConceptDesc,-Difference)      */
/*  Arguments:  ObjectDesc  = description of an example          */
/*              ConceptDesc = current concept description        */
/*              Difference  = term of the form: Missing + Extra  */
/*---------------------------------------------------------------*/
/* Matches the description of an example against the current     */
/* concept description and determines two lists of Missing and   */
/* Extra descriptors. match performs the following:              */
/*   - the "must" lista are matched                              */
/*   - a difference template is generated                        */
/*   - parts of the object and concept descriptions are matched  */
/*   - other relations are matched                               */
/*   - test whether all MustNot relations are missing.           */
/*   - on backtracking a different template is tried.            */
/*---------------------------------------------------------------*/
match(object(OParts,ORels),concept(CParts,Musts,Rels,MustNots),
                                              Missing + Extras) :-
     list_diff(ORels,Musts,[] + RestRels),
     short_lists(Missing + Extras),
     list_diff(OParts,CParts,[] + []),
     list_diff(RestRels,Rels,Missing + Extras),
     list_diff(Extras,MustNots,MustNots + _).

/*---------------------------------------------------------------*/
/*  Call:       list_diff(+List1,+List2,-ListDiffs)              */
/*  Arguments:  List1     = list of descriptors                  */
/*              List2     = list of descriptors                  */
/*              ListDiffs = List2\List1 + List1\List2            */
/*---------------------------------------------------------------*/
list_diff(List,[],[] + List).
list_diff(List1,[X|List2],Miss + Extras) :-
     delete1(List1,List11,X,Miss11,Miss),
     list_diff(List11,List2,Miss11 + Extras).

/*---------------------------------------------------------------*/
/*  Call:      delete1(+List1,+List2,+Descriptor,-List3,-List4)  */
/*  Arguments: List1      = list of descriptors                  */
/*             List2      = list of descriptors possibly without */
/*                          Descriptor                           */
/*             Descriptor = Descriptor which should be deleted   */
/*             List3      = list of descriptors with Descriptor  */
/*                          deleted                              */
/*             List4      = list of descriptors possibly with    */
/*                          Descriptor                           */
/*---------------------------------------------------------------*/
/* If Descriptor is deleted from List1 then List4 = List1,       */
/* if not the List2 = List1 and List4 = [Descriptor|List3].      */
/* (If Descriptor is not deleted then it is missing in List.)    */
/*---------------------------------------------------------------*/
delete1([],[],X,Dels,[X|Dels]).
delete1([Y|L],L,X,Dels,Dels) :-
     X == Y, !.
delete1([Y|L],L,X,Dels,Dels) :-
     X = Y.
delete1([Y|L],[Y|L1],X,Dels,Dels1) :-
     delete1(L,L1,X,Dels,Dels1).

/*---------------------------------------------------------------*/
/*  Call:      short_lists(List1 + List2)                        */
/*  Argument:  List1  = list of descriptors                      */
/*             List2  = list of descriptors                      */
/*---------------------------------------------------------------*/
/* short_lists generates difference templates of the form:       */
/* [] + [], [] + [_], [_] + [], [] + [_,_], [_] + [_] ....       */
/* Each list can contain at most 3 elements.                     */
/*---------------------------------------------------------------*/
short_lists(L1 + L2) :-
  append1(L,_,[_,_,_]),
  append1(L1,L2,L).

append1([],L,L).
append1([H|T],L,[H|T1]) :- append1(T,L,T1).

/*---------------------------------------------------------------*/
/* Call:update(+TypeOfExample,+Difference,+CurrentDesc,-NewDesc) */
/* Arguments: TypeOfExample = classification of the example      */
/*            Difference    = determined difference              */
/*            CurrentDesc   = current concept description        */
/*            NewDesc       = modified concept description       */
/*---------------------------------------------------------------*/
/* Clause 1: An extra relation in a negative example must appear */
/*           in the MustNot list of the concept description.     */
/* Clause 2: Missing relations in a negative example must appear */
/*           in the Must list of the concept description.        */
/* Clause 3: One missing and one extra relation in a negative    */
/*           example can be handled separatly.                   */
/* Clause 4: Generalize an isa-relation by climbing a_kind_of    */
/*           (ako) taxonomy (background knowledge of the system) */
/*---------------------------------------------------------------*/
update(negative,_ + [ExtraRelation],
                concept(Parts,Musts,Rels,MustNots),
                concept(Parts,Musts,Rels,[ExtraRelation|MustNots])).
update(negative,Missing + _,concept(Parts,Musts,Rels,MustNots),
                concept(Parts,NewMusts,NewRels,MustNots)) :-
     Missing = [_|_],
     append1(Missing,Musts,NewMusts),
     list_diff(Rels,Missing,_ + NewRels).
update(negative,[MissR] + [ExtraR],CurDesc,NewDesc) :-
     update(negative,[] + [ExtraR],CurDesc,InterDesc),
     update(negative,[MissR] + [],InterDesc,FinDesc).
update(positive,[isa(Object,Class1)] + [isa(Object,Class2)],
                concept(Parts,Musts,Rels,MustNots),
                concept(Parts,Musts,NewRels,MustNots)) :-
     climb(Class1,Class),
     climb(Class2,Class),!,
     replace(isa(Object,Class1),Rels,isa(Object,Class),NewRels).

/*---------------------------------------------------------------*/
/*  Call:      replace(+Item,+List,+NewItem,-NewList)            */
/*  Arguments: Item    = descriptor                              */
/*             List    = list of descriptors                     */
/*             NewItem = replacement descriptor                  */
/*             NewList = replaced list of descriptors            */
/*---------------------------------------------------------------*/
replace(Item,List,NewItem,[NewItem|List1]) :-
     delete1(List,List1,Item,_,_).

/*---------------------------------------------------------------*/
/*  Call:      climb(+Class1,-Class2)                            */
/*  Argument:  Class1 = Subclass                                 */
/*             Class2 = Superclass                               */
/*---------------------------------------------------------------*/
climb(Class,Class).
climb(Class,SuperClass) :-
     ako(Class1,Class),
     climb(Class1,SuperClass).
