% ============================================================================== % ALE -- Attribute Logic Engine % ============================================================================== % Version 3.2.1 --- December, 2001 % Developed under: SICStus Prolog, Version 3.8.6 % Ported to: SWI Prolog, Version 4.0.11 % Authors: % Bob Carpenter % --------------------------- % SpeechWorks Research % 55 Broad St. % New York, NY 10004 % USA % carp@colloquial.com % % Gerald Penn % -------------------------------- % Department of Computer Science % University of Toronto % 10 King's College Rd. % Toronto M5S 3G4 % Canada % gpenn@cs.toronto.edu % % Copyright 1992-1995, Bob Carpenter and Gerald Penn % Copyright 1998,1999,2001, Gerald Penn % All Rights Reserved % ALE is distributed on the GNU Lesser GPL: http://www.gnu.org/copyleft/lesser.html % % ALE Homepage: http://www.cs.toronto.edu/~gpenn/ale.html % SWI patch code :- ensure_loaded(library(quintus)). % replaced consult/1 everywhere with: swi_consult(X) :- % style_check(-discontiguous), consult(X). ttynl :- nl(user_output). if(X,Y,Z) :- (X *-> Y ; Z). findall(Temp,Goal,NewBag,Remainder) :- findall(Temp,Goal,Bag), append(Bag,Remainder,NewBag). instance(Ref,(Head:-Body)) :- clause(Head,Body,Ref). % SWI equivalent is message_hook/3, but implementation (as of 3.2.7) is % incomplete - will not trap warnings or informational messages % :- multifile portray_message/2. % portray_message(warning,no_match(abolish(_))). % suppress abolish/1 warnings % portray_message(informational,M) :- % portray_message_inf(M). % portray_message_inf(loading(compiling,AbsFileName)) :- % ale_compiling(AbsFileName). % suppress compiler throws % portray_message_inf(loaded(compiled,AbsFileName,user,_,_)) :- % ale_compiling(AbsFileName). % :- prolog_flag(character_escapes,_,on). % :- use_module(library(terms),[subsumes_chk/2]). :- set_feature(character_escapes,true). %subsumes_chk(X,Y) :- % \+ \+ (copy_term(Y,Y2), % free_variables(Y,YFVs), % free_variables(Y2,Y2FVs), % X = Y2, % numbervars(YFVs,'$VAR',0,_), % don't use '$VAR' in a_ atoms! % YFVs = Y2FVs). % ------------------------------------------------------------------------------ % same_length(Xs:, Ys:) % ------------------------------------------------------------------------------ % checks that Xs and Ys are same length; instantiating if necessary % ------------------------------------------------------------------------------ same_length([],[]). same_length([_|Xs],[_|Ys]):- same_length(Xs,Ys). % ------------------------------------------------------------------------------ % transitive_closure(Graph:, Closure:) % ------------------------------------------------------------------------------ % Warshall's Algorithm (O'Keefe, Craft of Prolog, p. 172) % Input: Graph = [V1-Vs1,...,VN-VsN] % describes the graph G = where % * Vertices = {V1,..,VN} and % * VsI = {VJ | VI -> VJ in Edges} % Output: Closure is transitive closure of Graph in same form % ------------------------------------------------------------------------------ transitive_closure(Graph,Closure):- warshall(Graph,Graph,Closure). warshall([],Closure,Closure). warshall([V-_|G],E,Closure):- memberchk(V-Y,E), warshall(E,V,Y,NewE), warshall(G,NewE,Closure). warshall([],_,_,[]). warshall([X-Neibs|G],V,Y,[X-NewNeibs|NewG]):- memberchk(V,Neibs), !, merge(Neibs,Y,NewNeibs), warshall(G,V,Y,NewG). warshall([X-Neibs|G],V,Y,[X-Neibs|NewG]):- warshall(G,V,Y,NewG). % ------------------------------------------------------------------------------ % vars_of(Term:, VarsIn:s, VarsOut:s) % ------------------------------------------------------------------------------ % VarsOut is VarsIn appended to variables in Term % ------------------------------------------------------------------------------ vars_of(Var,VarsIn,[Var|VarsIn]):- var(Var), !. vars_of(A,VarsIn,VarsIn) :- % recommended by Jan Wielemaker atomic(A), !. vars_of(Term,VarsIn,VarsOut):- Term =.. [_|Args], vars_of_list(Args,VarsIn,VarsOut). vars_of_list([],VarsIn,VarsIn). vars_of_list([Arg|Args],VarsIn,VarsOut):- vars_of(Arg,VarsIn,VarsMid), vars_of_list(Args,VarsMid,VarsOut). term_variables(Term,Vars) :- vars_of(Term,[],Vars). % ------------------------------------------------------------------------------ % top_sort(Type:,VisIn:s,VisOut:s,TopIn:s, % TopOut:s) % ------------------------------------------------------------------------------ % Topologically sorts the types accessible by inverse feature paths from % Type. The order used is such that Type will be the first element on the % list TopOut. % ------------------------------------------------------------------------------ top_sort(Type,VisIn,VisOut,TopIn,TopOut) :- member(Type,VisIn) -> (VisOut = VisIn, TopOut = TopIn) ; (TopOut = [Type|TopMid], esetof(MT,Type^F^(approp(F,MT,Type)),MotherTypes), top_sort_list(MotherTypes,[Type|VisIn],VisOut,TopIn,TopMid)). top_sort_list([],Vis,Vis,Top,Top). top_sort_list([Type|Types],VisIn,VisOut,TopIn,TopOut) :- top_sort(Type,VisIn,VisMid,TopIn,TopMid), top_sort_list(Types,VisMid,VisOut,TopMid,TopOut). % Association lists empty_assoc([]). get_assoc(Key,Assoc,Value) :- get_assoc_act(Assoc,Key,Value). get_assoc_act([AKey-AValue|AssocRest],Key,Value) :- (AKey == Key) -> Value = AValue ; get_assoc_act(AssocRest,Key,Value). get_assoc(Key,OldAssoc,OldValue,NewAssoc,NewValue) :- get_assoc_act(OldAssoc,Key,OldValue,NewAssoc,NewValue). get_assoc_act([OAKey-OAValue|OldAssocRest],Key,OldValue,NewAssoc,NewValue) :- (OAKey == Key) -> NewAssoc = [Key-NewValue|OldAssocRest], OldValue = OAValue ; NewAssoc = [OAKey-OAValue|NewAssocRest], get_assoc_act(OldAssocRest,Key,OldValue,NewAssocRest,NewValue). put_assoc(Key,OldAssoc,Val,NewAssoc) :- put_assoc_act(OldAssoc,Key,Val,NewAssoc). put_assoc_act([],Key,Val,[Key-Val]). put_assoc_act([OAKey-OAValue|OldAssocRest],Key,Val,NewAssoc) :- (OAKey == Key) -> NewAssoc = [Key-Val|OldAssocRest] ; NewAssoc = [OAKey-OAValue|NewAssocRest], put_assoc_act(OldAssocRest,Key,Val,NewAssocRest). assoc_to_list(L,L). ord_list_to_assoc(L,L). % end SWI patch code :- dynamic no_interpreter/0. :- dynamic no_subsumption/0. :- dynamic subsume_ready/0. :- dynamic go/1. :- dynamic suppress_adderrs/0. :- dynamic parsing/0, generating/0. :- dynamic lexicon_consult/0. :- discontiguous if_h/1. :- discontiguous if_h/2. :- discontiguous if_b/2. parse :- retractall(generating), asserta(parsing), nl,write('compiler will produce code for parsing only'), nl. generate :- retractall(parsing), asserta(generating), nl,write('compiler will produce code for generation only'), nl. parse_and_gen :- asserta(parsing), asserta(generating), nl,write('compiler will produce code for parsing and generation'), nl. lex_consult :- nl,write('In SWI Prolog, ALE always consults lexicon'), nl. lex_compile :- nl,write('Not available in ALE for SWI Prolog'), nl. interp :- retractall(no_interpreter), nl, write('interpreter is active'), nl. nointerp :- asserta(no_interpreter), nl, write('interpreter is inactive'), nl. subtest :- retractall(no_subsumption), compile_subsume, nl, write('edge/empty category subsumption checking active'), nl. nosubtest :- asserta(no_subsumption), nl, write('edge/empty category subsumption checking inactive'), nl. clear :- retractall(to_rebuild(_)), retractall(edge(_,_,_,_,_,_,_,_)), retractall(parsing(_)), retractall(num(_)), % edge index retractall(go(_)). % interpreter go flag noadderrs :- asserta(suppress_adderrs), nl, write('Errors from adding descriptions will be suppressed.'), nl. adderrs :- retractall(suppress_adderrs), nl, write('Errors from adding descriptions will be displayed.'), nl. secret_noadderrs :- asserta(suppress_adderrs). secret_adderrs :- retractall(suppress_adderrs). % ============================================================================== % Operators % ============================================================================== % ------------------------------------------------------------------------------ % SRK Descriptions % ------------------------------------------------------------------------------ :-op(375,fx,a_). :-op(375,fx,@). :-op(700,xfx,=@). %:-op(700,xfx,==). :-op(775,fx,=\=). :-op(800,xfy,:). %:-op(1000,xfy,','). %:-op(1100,xfy,';'). % ------------------------------------------------------------------------------ % Signatures % ------------------------------------------------------------------------------ :- dynamic sub_def/2. :- dynamic max_def/1. :-op(800,xfx,goal). :-op(900,xfx,cons). :-op(800,xfx,intro). :-op(900,xfx,sub). :-op(900,xfx,sub_def). :-op(900,xfx,subs). % ------------------------------------------------------------------------------ % Grammars % ------------------------------------------------------------------------------ :-op(1125,xfy,then). :-op(1150,xfx,===>). :-op(1150,xfx,--->). :-op(1150,xfx,macro). :-op(1150,xfx,+++>). :-op(1150,fx,empty). :-op(1175,xfx,rule). :-op(1175,xfx,lex_rule). :-op(1160,xfx,morphs). :-op(1125,xfx,'**>'). :-op(950,xfx,when). :-op(900,xfx,becomes). :-op(1175,fx,semantics). % ------------------------------------------------------------------------------ % Definite Clauses % ------------------------------------------------------------------------------ :-op(1150,xfx,if). % ------------------------------------------------------------------------------ % Compiler % ------------------------------------------------------------------------------ :-op(800,xfx,if_h). :-op(800,xf,if_h). :-op(800,xfx,if_b). :-op(800,xf,if_b). :-op(800,xfx,if_error). :-op(800,xfx,if_warning_else_fail). :-op(800,xfx,if_warning). % ------------------------------------------------------------------------------ % I/O % ------------------------------------------------------------------------------ :-op(1125,fx,mgsat). :-op(1100,fx,macro). :-op(1100,fx,query). :-op(1100,fx,rule). :-op(1100,fx,lex_rule). :-op(1100,fx,show_clause). :-op(1100,fx,rec). :-op(1100,fx,lex). :-op(1100,fx,gen). :-op(800,fx,show_type). :-op(500,fx,no_write_type). :-op(500,fx,no_write_feat). % ============================================================================== % Type Inheritance and Unification % ============================================================================== % Type: sub Types:s intro FRs:s user % ------------------------------------------------------------------------------ % Types is set of immediate subtypes of Types and FRs is list % of appropriate features paired with restrictions on values. % When FRs is not specified, it is equivalent to '[]'. % ------------------------------------------------------------------------------ % Type: sub_def Types:s intro FRs:s % ------------------------------------------------------------------------------ % Same as sub except these are asserted by the default type preprocessors % ------------------------------------------------------------------------------ % Type: subs Types:s intro FRs:s % ------------------------------------------------------------------------------ % Subsumption predicate for use in ALE. If there is a sub_def clause with % left-hand argument Type, then subs uses that; otherwise, it uses sub % ------------------------------------------------------------------------------ T subs Ts :- var(T) -> ( T sub_def Ts ; T sub Ts, \+ T sub_def _) ; (T sub_def Ts -> true ; T sub Ts). % ------------------------------------------------------------------------------ % Type: cons Cons: goal Goal: user % ------------------------------------------------------------------------------ % Cons is the general description which must be satisfied by all structures of % type Type, and Goal is an optional procedural attachment which also must % be satisfied when present. An absent constraint is equivalent to 'bot', % and an absent goal is equivalent to 'true'. % ------------------------------------------------------------------------------ % ------------------------------------------------------------------------------ % type(Type:) eval % ------------------------------------------------------------------------------ % Type is a type % ------------------------------------------------------------------------------ type(Type):- Type subs _. type(a_ _). % ------------------------------------------------------------------------------ % immed_subtypes(Type:, SubTypes:s) eval % ------------------------------------------------------------------------------ % SubTypes is set of immediate subtypes of Type (SubTypes cover Type) % ------------------------------------------------------------------------------ immed_subtypes(Type,SubTypes):- Type subs SubTypes, \+ (SubTypes = (_ intro _)) ; Type subs SubTypes intro _. % ------------------------------------------------------------------------------ % imm_sub_type(Type:, TypeSub:) eval % ------------------------------------------------------------------------------ % TypeSub is immediate subtype of Type % ------------------------------------------------------------------------------ imm_sub_type(Type,TypeSub):- immed_subtypes(Type,TypeSubs), member(TypeSub,TypeSubs). % ------------------------------------------------------------------------------ % immed_cons(Type:,Cons:) % ------------------------------------------------------------------------------ immed_cons(Type,Cons) :- type(Type), % ALE WON'T CATCH A CONSTRAINT DEFINED FOR AN ATOM (\+current_predicate(cons,(_ cons _)) % UNTIL THE COMPILER IS RUN -> Cons = none ;(Type cons Cons goal _ -> true ; Type cons Cons)). % ------------------------------------------------------------------------------ % sub_type(Type:, TypeSub:) mh(1) % ------------------------------------------------------------------------------ % TypeSub is subtype of Type % ------------------------------------------------------------------------------ (sub_type(Type,Type) if_h) :- Type subs _. % dont want a_ atoms here - they get their own clause below (sub_type(Type,TypeSub) if_h) :- setof(Type-TypeSubs, immed_subtypes(Type,TypeSubs), Graph), transitive_closure(Graph,NewGraph), member(Type-TypeSubs,NewGraph), member(TypeSub,TypeSubs), [subtyping,cycle,at,Type] if_error TypeSub = Type. (sub_type(bot,a_ _) if_h). (sub_type(a_ X,a_ Y) if_h [subsumes_chk(X,Y)]). % ------------------------------------------------------------------------------ % unify_type(Type1:, Type2:, TypeLUB:) mh(1) % ------------------------------------------------------------------------------ % Type1 unified with Type2 is TypeLUB % ------------------------------------------------------------------------------ (unify_type(Type1,Type2,TypeLUB) if_h) :- setof(TypeUB, ( sub_type(Type1,TypeUB), \+(Type1 = a_ _), sub_type(Type2,TypeUB), \+(Type2 = a_ _)), TypeUBs), map_minimal(TypeUBs,[],TypeLUBs), [consistent,Type1,and,Type2,have,multiple,mgus,TypeLUBs] if_error ( TypeLUBs = [_,_|_], Type1 @< Type2 ), TypeLUBs = [TypeLUB]. (unify_type(bot,a_ X,a_ X) if_h). (unify_type(a_ X,bot,a_ X) if_h). (unify_type(a_ X,a_ X,a_ X) if_h). % subsumes_chk/2 unhooks the vars - need % to do it ourselves % ------------------------------------------------------------------------------ % map_minimal(Ss:, SsTemp:, SsMin:) % ------------------------------------------------------------------------------ % holds if SsMin is the list of minimal types of Ss unioned with SsTemp; % elements of SsTemp are always incomparable % ------------------------------------------------------------------------------ map_minimal([],SsMin,SsMin). map_minimal([S|Ss],SsTemp,SsMin):- insert_if_minimal(SsTemp,S,SsTempNew), map_minimal(Ss,SsTempNew,SsMin). % ------------------------------------------------------------------------------ % insert_if_minimal(Ss:s, S:, Ss2:s) % ------------------------------------------------------------------------------ % Ss2 is minimal elts of (Ss U {S}) where we know Ss are incomparable % ------------------------------------------------------------------------------ insert_if_minimal([],S,[S]). insert_if_minimal([S2|Ss2],S,[S2|Ss2]):- sub_type(S2,S), !. insert_if_minimal([S2|Ss2],S,Ss3):- sub_type(S,S2), !, insert_if_minimal(Ss2,S,Ss3). insert_if_minimal([S2|Ss2],S,[S2|Ss3]):- insert_if_minimal(Ss2,S,Ss3). % ------------------------------------------------------------------------------ % unify_types(Types:s, Type:) % ------------------------------------------------------------------------------ % Type is unification of Types % ------------------------------------------------------------------------------ unify_types([],bot). unify_types([Type|Types],TypeUnif):- unify_types(Types,Type,TypeUnif). % ------------------------------------------------------------------------------ % unify_types(Types:s, Type:, TypeUnif:) % ------------------------------------------------------------------------------ % TypeUnif is unification of set consisting of Types and Type % ------------------------------------------------------------------------------ unify_types([],Type,Type). unify_types([Type|Types],TypeIn,TypeOut):- unify_type(Type,TypeIn,TypeMid), unify_types(Types,TypeMid,TypeOut). % ------------------------------------------------------------------------------ % extensional(Sort:) % ------------------------------------------------------------------------------ % holds if $F$ is a feature mentioned somewhere in the code % ------------------------------------------------------------------------------ feature(Feat):- setof(F,Type^Subs^R^FRs^((Type subs Subs intro FRs), member(F:R,FRs)), Feats), member(Feat,Feats) ;setof(F,Type^R^FRs^((Type intro FRs), member(F:R,FRs)), Feats), member(Feat,Feats). % ------------------------------------------------------------------------------ % restricts(Type:, Feat:, TypeRestr:) eval % ------------------------------------------------------------------------------ % Type introduces the feature Feat imposing value restriction TypeRestr % ------------------------------------------------------------------------------ restricts(Type,Feat,TypeRestr):- Type subs _ intro FRs, member(Feat:TypeRestr,FRs) ;Type intro FRs, member(Feat:TypeRestr,FRs). % ------------------------------------------------------------------------------ % introduce(?Feat:, -Type:) eval % ------------------------------------------------------------------------------ % Type is the most general type appropriate for Feat % ------------------------------------------------------------------------------ introduce(Feat,Type):- setof(T,TypeRestr^restricts(T,Feat,TypeRestr),Types), map_minimal(Types,[],TypesMin), [feature,Feat,multiply,introduced,at,TypesMin] if_error (\+ TypesMin = [_]), TypesMin = [Type]. % ------------------------------------------------------------------------------ % approp(Feat:, Type:, TypeRestr:) mh(1) % ------------------------------------------------------------------------------ % approp(Feat,Type) = TypeRestr % ------------------------------------------------------------------------------ (approp(Feat,Type,ValRestr) if_h) :- setof(TypeRestr,TypeSubs^(sub_type(TypeSubs,Type), restricts(TypeSubs,Feat,TypeRestr)), TypeRestrs), [incompatible,restrictions,on,feature,Feat,at,type,Type, are,TypeRestrs] if_error (\+ unify_types(TypeRestrs,ValRestr)), unify_types(TypeRestrs,ValRestr). approp(_,_,_) if_h [fail] :- \+(_ subs _ intro _), \+(_ intro _). % ------------------------------------------------------------------------------ % approps(Type:, FRs:s) eval % ------------------------------------------------------------------------------ % FRs is list of appropriateness declarations for Type % ------------------------------------------------------------------------------ approps(Type,FRs):- type(Type), % ALE WON'T CATCH FEATURES DEFINED FOR ATOMS UNTIL COMPILER RUNS esetof(Feat:TypeRestr, approp(Feat,Type,TypeRestr), FRs). % ------------------------------------------------------------------------------ % approp_feats(Type:,Fs:s) % ------------------------------------------------------------------------------ % Fs is list of appropriate features for Type % ------------------------------------------------------------------------------ approp_feats(Type,Fs) :- type(Type), % ALE WON'T CATCH FEATURES DEFINED FOR ATOMS UNTIL COMPILER RUNS esetof(Feat,TypeRestr^approp(Feat,Type,TypeRestr),Fs). % ============================================================================== % Feature Structure Unification % ============================================================================== % ------------------------------------------------------------------------------ % ud(FS1:, FS2:, IqsIn:s, IqsOut:s) eval % ------------------------------------------------------------------------------ % unifies FS1 and FS2 (after dereferencing); % ------------------------------------------------------------------------------ ud(FS1,FS2,IqsIn,IqsOut):- deref(FS1,Ref1,SVs1), deref(FS2,Ref2,SVs2), ( (Ref1 == Ref2) -> (IqsOut = IqsIn) ; u(SVs1,SVs2,Ref1,Ref2,IqsIn,IqsOut) ). % ud(FS:,Tag:,SVs:,IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % 5-place version of ud/4 % ------------------------------------------------------------------------------ ud(FS1,Tag2,SVs2,IqsIn,IqsOut) :- deref(FS1,RefOut1,SVsOut1), deref(Tag2,SVs2,RefOut2,SVsOut2), ( (RefOut1 == RefOut2) -> (IqsOut = IqsIn) ; u(SVsOut1,SVsOut2,RefOut1,RefOut2,IqsIn,IqsOut) ). % ud(Tag1:,SVs1:,Tag2:,SVs2:,IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % 6-place version of ud/4 % ------------------------------------------------------------------------------ ud(Tag1,SVs1,Tag2,SVs2,IqsIn,IqsOut) :- deref(Tag1,SVs1,RefOut1,SVsOut1), deref(Tag2,SVs2,RefOut2,SVsOut2), ( (RefOut1 == RefOut2) -> (IqsOut = IqsIn) ; u(SVsOut1,SVsOut2,RefOut1,RefOut2,IqsIn,IqsOut) ). % ------------------------------------------------------------------------------ % deref(FSIn:, RefOut:, SVsOut:) % ------------------------------------------------------------------------------ % RefOut-SVsOut is result of dereferencing FSIn at top level % ------------------------------------------------------------------------------ deref(Ref-Vs,RefOut,VsOut):- ( var(Ref) -> (RefOut = Ref, VsOut = Vs) ; deref(Ref,RefOut,VsOut) ). % ------------------------------------------------------------------------------ % deref_list(RefsIn:s, RefsOut:s) % ------------------------------------------------------------------------------ % applies deref/4 on all elements of RefsIn to get RefsOut % ------------------------------------------------------------------------------ deref_list([],[]). deref_list([Ref-Vs|Rest],[RefOut-VsOut|RestOut]) :- deref(Ref,Vs,RefOut,VsOut), deref_list(Rest,RestOut). % ------------------------------------------------------------------------------ % deref(RefIn:,SVsIn:, RefOut:, SVsOut:) % ------------------------------------------------------------------------------ % RefOut-SVsOut is result of dereferencing FSIn at top level % ------------------------------------------------------------------------------ deref(Ref,Vs,RefOut,VsOut):- ( var(Ref) -> (RefOut = Ref, VsOut = Vs) ; deref(Ref,RefOut,VsOut) ). % ------------------------------------------------------------------------------ % fully_deref_prune(RefIn:,SVsIn:, RefOut:, SVsOut:, % IqsIn:s, IqsOut:s) % ------------------------------------------------------------------------------ % In addition to fully dereferencing the given feature structure, this % predicate checks the associated inequations both for their satisfaction, % and for their relevance, and rebuilds them in terms of the new feature % structure. An inequation is deemed relevant if both of its terms are % substructures of the given feature structure, or if one of its terms is, % and the other one is fully extensional (which means that it and each of its % substructures is of an extensional sort). Currently, full extensionality is % not actually enforced, but rather only a check that the term itself is of an % extensional sort is made. % ------------------------------------------------------------------------------ fully_deref_prune(Tag,SVs,TagOut,SVsOut,IqsIn,IqsOut) :- fully_deref(Tag,SVs,TagOut,SVsOut), prune(IqsIn,IqsOut). prune([],[]). prune([ineq(Tag1,SVs1,Tag2,SVs2,Ineqs)|IqsIn],IqsOut) :- prune_deref(Tag1,SVs1,Tag1Out,SVs1Out,InFlag1), prune_deref(Tag2,SVs2,Tag2Out,SVs2Out,InFlag2), ((InFlag1 = out) -> ((InFlag2 = out) % both are out -> prune(IqsIn,IqsOut) ; % one is out, and it is intensional (\+(SVs1 = a_ _), % structure-sharing inside atoms could cause functor(SVs1,Sort1,_), % trouble later - so keep them around \+extensional(Sort1)) -> prune(IqsIn,IqsOut) ; (check_inequal_conjunct(ineq(Tag1Out,SVs1Out,Tag2Out,SVs2Out, Ineqs), IqOut,Result), prune_act(Result,IqOut,IqsIn,IqsOut))) ; ((InFlag2 = out, \+(SVs2 = a_ _), functor(SVs2,Sort2,_), \+extensional(Sort2)) -> prune(IqsIn,IqsOut) ; (check_inequal_conjunct(ineq(Tag1Out,SVs1Out,Tag2Out,SVs2Out,Ineqs), IqOut,Result), prune_act(Result,IqOut,IqsIn,IqsOut)))). prune_act(done,done,_,_) :- % conjunct failed !,fail. prune_act(succeed,_,IqsIn,IqsOut) :- % conjunct succeeded !,prune(IqsIn,IqsOut). prune_act(_,IqOut,IqsIn,[IqOut|IqsOut]) :- % conjunct temporarily succeeded prune(IqsIn,IqsOut). prune_deref(Tag,SVs,Tag,SVsOut,out) :- var(Tag), !, ((SVs = a_ _) -> (SVsOut = SVs) ; (SVs =.. [Sort|Vs], % some substructures may still be shared prune_deref_feats(Vs,VsOut), SVsOut =.. [Sort|VsOut]) ). prune_deref(fully(TagOut,SVsOut),_,TagOut,SVsOut,in). prune_deref(Tag-SVs,_,TagOut,SVsOut,InFlag) :- prune_deref(Tag,SVs,TagOut,SVsOut,InFlag). prune_deref_feats([],[]). prune_deref_feats([Ref-SVs|Vs],[RefOut-SVsOut|VsOut]) :- prune_deref(Ref,SVs,RefOut,SVsOut,_), prune_deref_feats(Vs,VsOut). % ------------------------------------------------------------------------------ % fully_deref(RefIn:,SVsIn:, RefOut:, SVsOut:) % ------------------------------------------------------------------------------ % RefOut-SVsOut is result of recursively dereferencing FSIn; % destroys RefIn-SVsIn by overwriting Tags % ------------------------------------------------------------------------------ fully_deref(Tag,SVs,TagOut,SVsOut):- ( nonvar(Tag) -> fully_deref_act(Tag,SVs,TagOut,SVsOut) ; Tag = (fully(TagOut,SVsOut)-SVsOut), ((SVs = a_ X) -> SVsOut = a_ X ; (functor(SVs,Rel,Arity), functor(SVsOut,Rel,Arity), fully_deref_args(Arity,SVs,SVsOut)) ) ). fully_deref_act(fully(TagOut,_),SVs,TagOut,SVs). fully_deref_act(TagMid-SVsMid,_,TagOut,SVsOut):- fully_deref(TagMid,SVsMid,TagOut,SVsOut). fully_deref_args(0,_,_):-!. fully_deref_args(N,SVs,SVsOut):- arg(N,SVs,TagN-SVsN), fully_deref(TagN,SVsN,TagOutN,SVsOutN), arg(N,SVsOut,TagOutN-SVsOutN), M is N-1, fully_deref_args(M,SVs,SVsOut). % ------------------------------------------------------------------------------ % u(SVs1:,SVs2:,Ref1:,Ref2:,IqsIn:s, % IqsOut:) mh(2) % ------------------------------------------------------------------------------ % compiles typed version of the Martelli and Montanari unification % algorithm for dereferenced feature structures Ref1-SVs1 and Ref2-SVs2 % ------------------------------------------------------------------------------ u(SVs1,SVs2,Ref1,Ref2,IqsIn,IqsOut) if_h SubGoals:- unify_type(Type1,Type2,Type3), uact(Type3,SVs1,SVs2,Ref1,Ref2,Type1,Type2,IqsIn,IqsOut,SubGoals). % ------------------------------------------------------------------------------ % uact(Type3,SVs1,SVs2,Ref1,Ref2,Type1,Type2,IqsIn,IqsOut,SubGoals) % ------------------------------------------------------------------------------ % SubGoals is list of goals required to unify Ref1-SVs1 and Ref2-SVs2, % where Ref1-SVs1 is of type Type1, Ref2-SVs2 is of type Type2 and % Type1 unify Type2 = Type3 % ------------------------------------------------------------------------------ uact(a_ X,a_ X,a_ X,Ref,Ref,a_ X,a_ X,Iqs,Iqs,[]) :- !. uact(a_ X,bot,a_ X,Ref-(a_ X),Ref,bot,a_ X,Iqs,Iqs,[]) :- !. uact(a_ X,a_ X,bot,Ref,Ref-(a_ X),a_ X,bot,Iqs,Iqs,[]) :- !. uact(Type3,SVs1,SVs2,Ref1,Ref2,Type1,Type2,IqsIn,IqsOut,SubGoals):- approps(Type1,FRs1), % we know Type1, Type2, and Type3 aren't a_ atoms ( (Type1 = Type2) -> (Ref1 = Ref2, map_feats_eq(FRs1,Vs1,Vs2,IqsIn,IqsOut,SubGoals)) ; approps(Type2,FRs2), % Type1 \== Type2, ( (Type2 = Type3) -> (Ref1 = Ref2-SVs2, map_feats_subs(FRs1,FRs2,Vs1,Vs2,IqsIn,IqsOut,SubGoals)) ; ((Type1 = Type3) -> (Ref2 = Ref1-SVs1, map_feats_subs(FRs2,FRs1,Vs2,Vs1,IqsIn,IqsOut,SubGoals)) ; (Ref1 = Tag3-SVs3, Ref2 = Ref1, % Type1\==Type3,Type2 \== Type3 (((FRs2 = []),(FRs1 = [])) -> (mgsc(Type3,SVs3,Tag3,IqsIn,IqsOut,SubGoals,[]), Vs2 = [], Vs1 = []) ; (approps(Type3,FRs3), map_feats_unif(FRs1,FRs2,FRs3,Vs1,Vs2,Vs3,IqsIn,IqsMid, SubGoals,SubGoalsRest), ucons(Type3,Type2,Type1,Tag3,SVs3,IqsMid,IqsOut, SubGoalsRest), SVs3 =.. [Type3|Vs3])))) ) ), SVs1 =.. [Type1|Vs1], SVs2 =.. [Type2|Vs2]. % ------------------------------------------------------------------------------ % ucons(Type:,ExclType1:,ExclType2:,Tag:,SVs:s, % IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % Enforce the constraint for Type, and for all supersorts of Type, excluding % ExclType1 and ExclType2, on Tag-SVs % ------------------------------------------------------------------------------ ucons(Type,ET1,ET2,Tag,SVs,IqsIn,IqsOut,SubGoals) :- esetof(T,(sub_type(T,Type), % find set of types whose constraints must be \+sub_type(T,ET1), % satisfied \+sub_type(T,ET2)),ConsTypes), map_cons(ConsTypes,Tag,SVs,IqsIn,IqsOut,SubGoals,[]). % ------------------------------------------------------------------------------ % ct(Type:,Tag:,SVs:s,Goals:s,Rest:s,IqsIn:s, % IqsOut,s) % ------------------------------------------------------------------------------ % Goals, with tail Rest, are the compiled goals of the description (and % clause) attached to Type, enforced on feature structure Tag-SVs % ------------------------------------------------------------------------------ ct(_Type,_Tag,_SVs,Rest,Rest,Iqs,Iqs) if_b [] :- \+ current_predicate(cons,(_ cons _)), !. ct(Type,Tag,SVs,Goals,Rest,IqsIn,IqsOut) if_b [!] :- empty_assoc(VarsIn), Type cons Cons goal Goal, compile_desc(Cons,Tag,SVs,IqsIn,IqsMid,GoalsMid,GoalsMid2,true,VarsIn, VarsMid,FSPal,[],FSsMid), compile_body(Goal,IqsMid,IqsOut,GoalsMid2,Rest,true,VarsMid,_,FSPal,FSsMid, FSsOut), build_fs_palette(FSsOut,FSPal,Goals,GoalsMid,[]). ct(Type,Tag,SVs,Goals,Rest,IqsIn,IqsOut) if_b [!] :- empty_assoc(VarsIn), Type cons Cons, \+ (Cons = (_ goal _)), compile_desc(Cons,Tag,SVs,IqsIn,IqsOut,GoalsMid,Rest,true,VarsIn,_,FSPal,[], FSsOut), build_fs_palette(FSsOut,FSPal,Goals,GoalsMid,[]). ct(_Type,_Tag,_SVs,Rest,Rest,Iqs,Iqs) if_b []. % all other types % ------------------------------------------------------------------------------ % map_cons(Types:s,Tag:,SVs:s,IqsIn:s,IqsOut:s, % SubGoals:s,SubGoalsRest:s) % ------------------------------------------------------------------------------ % Given a set of types, strings together the goals and inequations for them. % ------------------------------------------------------------------------------ map_cons([],_,_,Iqs,Iqs,Goals,Goals). map_cons([Type|Types],Tag,SVs,IqsIn,IqsOut,SubGoals,SubGoalsRest) :- ct(Type,Tag,SVs,SubGoals,SubGoalsMid,IqsIn,IqsMid), map_cons(Types,Tag,SVs,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest). % ------------------------------------------------------------------------------ % map_feats_eq(FRs:s,Vs1:s,Vs2:s,IqsIn:s,IqsOut:s, % Goals:s) % ------------------------------------------------------------------------------ % Vs1 and Vs2 set to same length as FRs and a subgoal added to Goals % to unify value of each feature; % ------------------------------------------------------------------------------ map_feats_eq([],[],[],Iqs,Iqs,[]). map_feats_eq([_|FRs],[V1|Vs1],[V2|Vs2],IqsIn,IqsOut, [ud(V1,V2,IqsIn,IqsMid)|SubGoals]):- map_feats_eq(FRs,Vs1,Vs2,IqsMid,IqsOut,SubGoals). % ------------------------------------------------------------------------------ % map_feats_subs(FRs1:s, FRs2:s, Vs1:s, Vs2:s, % IqsIn:s, IqsOut:s, Goals:s) % ------------------------------------------------------------------------------ % Vs1 and Vs2 set to same length as FRs1 and FRs2 and a subgoal % added to Goals for each shared feature; % ------------------------------------------------------------------------------ map_feats_subs([],FRs,[],Vs,Iqs,Iqs,[]):- same_length(FRs,Vs). map_feats_subs([F:_|FRs1],FRs2,[V1|Vs1],Vs2,IqsIn,IqsOut, [ud(V1,V2,IqsIn,IqsMid)|SubGoals]):- map_feats_find(F,FRs2,V2,Vs2,FRs2Out,Vs2Out), map_feats_subs(FRs1,FRs2Out,Vs1,Vs2Out,IqsMid,IqsOut,SubGoals). % ------------------------------------------------------------------------------ % map_feats_find(F:, FRs:s, V:, Vs:s, % FRsOut:s, VsOut:s) % ------------------------------------------------------------------------------ % if F is the Nth element of FRs then V is the Nth element of Vs; % FRsOut and VsOut are the rest (after the Nth) of FRs and Vs % ------------------------------------------------------------------------------ map_feats_find(F,[F:_|FRs],V,[V|Vs],FRs,Vs):-!. map_feats_find(F,[_|FRs],V,[_|Vs],FRsOut,VsOut):- map_feats_find(F,FRs,V,Vs,FRsOut,VsOut). % ------------------------------------------------------------------------------ % map_feats_unif(FRs1:s,FRs2:s,FRs3:s,Vs1:s,Vs2:s, % Vs3:s,IqsIn:s,IqsOut:s,Goals:s, % GoalsRest:s) % ------------------------------------------------------------------------------ % Vs1, Vs2 and Vs3 set to same length as Feats1, FRs2 and FRs3; % a subgoal's added to Goals for each feature shared in FRs1 and FRs2; % feats shared in Vs1,Vs2 and Vs3 passed; new Vs3 entries are created % ------------------------------------------------------------------------------ map_feats_unif([],FRs2,FRs3,[],Vs2,Vs3,IqsIn,IqsOut,Goals,GoalsRest):- map_new_feats(FRs2,FRs3,Vs2,Vs3,IqsIn,IqsOut,Goals,GoalsRest). map_feats_unif([F1:R1|FRs1],FRs2,FRs3,Vs1,Vs2,Vs3,IqsIn,IqsOut,Goals, GoalsRest):- map_feats_unif_ne(FRs2,F1,R1,FRs1,FRs3,Vs1,Vs2,Vs3,IqsIn,IqsOut,Goals, GoalsRest). map_feats_unif_ne([],F1,R1,FRs1,FRs3,Vs1,[],Vs3,IqsIn,IqsOut,Goals,GoalsRest):- map_new_feats([F1:R1|FRs1],FRs3,Vs1,Vs3,IqsIn,IqsOut,Goals,GoalsRest). map_feats_unif_ne([F2:R2|FRs2],F1,R1,FRs1,FRs3,Vs1,Vs2,Vs3, IqsIn,IqsOut,Goals,GoalsRest):- compare(Comp,F1,F2), map_feats_unif_act(Comp,F1,F2,R1,R2,FRs1,FRs2,FRs3,Vs1,Vs2,Vs3, IqsIn,IqsOut,Goals,GoalsRest). map_feats_unif_act(=,F1,_F2,R1,R2,FRs1,FRs2,FRs3,[V1|Vs1],[V2|Vs2],Vs3, IqsIn,IqsOut,[ud(V1,V2,IqsIn,IqsMid)|Goals1],GoalsRest):- unify_type(R1,R2,R1UnifyR2), map_new_feats_find(F1,R1UnifyR2,FRs3,V1,Vs3,FRs3Out,Vs3Out,IqsMid,IqsMid2, Goals1,Goals2), map_feats_unif(FRs1,FRs2,FRs3Out,Vs1,Vs2,Vs3Out,IqsMid2,IqsOut,Goals2, GoalsRest). map_feats_unif_act(<,F1,F2,R1,R2,FRs1,FRs2,FRs3,[V1|Vs1],Vs2,Vs3, IqsIn,IqsOut,Goals,GoalsRest2):- map_new_feats_find(F1,R1,FRs3,V1,Vs3,FRs3Out,Vs3Out,IqsIn,IqsMid, Goals,GoalsRest1), map_feats_unif_ne(FRs1,F2,R2,FRs2,FRs3Out,Vs2,Vs1,Vs3Out, IqsMid,IqsOut,GoalsRest1,GoalsRest2). map_feats_unif_act(>,F1,F2,R1,R2,FRs1,FRs2,FRs3,Vs1,[V2|Vs2],Vs3, IqsIn,IqsOut,Goals,GoalsRest2):- map_new_feats_find(F2,R2,FRs3,V2,Vs3,FRs3Out,Vs3Out,IqsIn,IqsMid, Goals,GoalsRest1), map_feats_unif_ne(FRs2,F1,R1,FRs1,FRs3Out,Vs1,Vs2,Vs3Out, IqsMid,IqsOut,GoalsRest1,GoalsRest2). % ------------------------------------------------------------------------------ % map_new_feats(FRs:s, FRsNew:s, Vs:s, VsNew:s, % IqsIn:s,IqsOut:s,Gs:s,GsRest:s) % ------------------------------------------------------------------------------ % FRs and FRsNew must be instantiated in alpha order where % FRs is a sublist of NewFs; % create Vs and VsNew where Vs and VsNew share a value if the % feature in Fs and NewFs matches up, otherwise VsNew gets a fresh % minimum feature structure (_-bot) for a value; % all necessary value coercion is also performed % ------------------------------------------------------------------------------ map_new_feats([],FRsNew,[],VsNew,IqsIn,IqsOut,SubGoals,SubGoalsRest):- map_new_feats_introduced(FRsNew,VsNew,IqsIn,IqsOut,SubGoals,SubGoalsRest). map_new_feats([Feat:TypeRestr|FRs],FRsNew,[V|Vs],VsNew,IqsIn,IqsOut,SubGoals, SubGoalsRest2):- map_new_feats_find(Feat,TypeRestr,FRsNew,V,VsNew, FRsNewLeft,VsNewLeft,IqsIn,IqsMid,SubGoals,SubGoalsRest1), map_new_feats(FRs,FRsNewLeft,Vs,VsNewLeft,IqsMid,IqsOut,SubGoalsRest1, SubGoalsRest2). % ------------------------------------------------------------------------------ % map_new_feats_find(Feat,TypeRestr,FRs,V,Vs,FRs2,Vs2,IqsIn,IqsOut, % SubGoals,SubGoalsRest) % ------------------------------------------------------------------------------ % finds Feat value V in Vs, parallel to FRs, with restriction TypeRestr on V, % with FRs2 being left over; carries out coercion on new feature values % with SubGoals-SubGoalsRest being the code to do this % ------------------------------------------------------------------------------ map_new_feats_find(Feat,TypeRestr,[Feat:TypeRestrNew|FRs], V,[V|Vs],FRs,Vs,IqsIn,IqsOut,SubGoals,SubGoalsRest):- !, ( sub_type(TypeRestrNew,TypeRestr) -> (SubGoals = SubGoalsRest, IqsOut = IqsIn) ; ((TypeRestrNew = a_ X) -> (Goal =.. ['add_to_type_a_',SVs,Tag,IqsIn,IqsOut,X], SubGoals = [deref(V,Tag,SVs),Goal|SubGoalsRest]) ; (cat_atoms(add_to_type_,TypeRestrNew,Rel), Goal =.. [Rel,SVs,Tag,IqsIn,IqsOut], SubGoals = [deref(V,Tag,SVs),Goal|SubGoalsRest])) ). map_new_feats_find(Feat,TypeRestr,[_:TypeRestrNew|FRs], V,[(Tag-SVs)|Vs],FRsNew,VsNew,IqsIn,IqsOut, SubGoals,SubGoalsRest):- mgsc(TypeRestrNew,SVs,Tag,IqsIn,IqsMid,SubGoals,SubGoalsMid), %( (TypeRestrNew = a_ X) % -> Goal =.. ['add_to_type_a_',bot,Tag,IqsIn,IqsMid,X] % ; (cat_atoms(add_to_type_,TypeRestrNew,Rel), % Goal =.. [Rel,bot,Tag,IqsIn,IqsMid])), map_new_feats_find(Feat,TypeRestr,FRs,V,Vs,FRsNew, VsNew,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest). % ------------------------------------------------------------------------------ % map_new_feats_introduced(FRs,Vs,IqsIn,IqsOut,SubGoals,SubGoalsRest) % ------------------------------------------------------------------------------ % instantiates Vs to act as values of features in FRs; SubGoals contains % type coercions necessary so that Vs satisfy constraints in FRs % ------------------------------------------------------------------------------ map_new_feats_introduced([],[],Iqs,Iqs,Rest,Rest). map_new_feats_introduced([_:TypeRestr|FRs],[(Ref-SVs)|Vs],IqsIn,IqsOut, SubGoals,SubGoalsRest):- mgsc(TypeRestr,SVs,Ref,IqsIn,IqsMid,SubGoals,SubGoalsMid), % ((TypeRestr = a_ X) % -> Goal =.. ['add_to_type_a_',bot,Ref,IqsIn,IqsMid,X] % ; (cat_atoms(add_to_type_,TypeRestr,Rel), % Goal =.. [Rel,bot,Ref,IqsIn,IqsMid])), map_new_feats_introduced(FRs,Vs,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest). % ============================================================================== % Lexical Rules % ============================================================================== % ------------------------------------------------------------------------------ % lex_rule(WordIn,TagIn,SVsIn,WordOut,TagOut,SVsOut,IqsIn,IqsOut) mh(0) % ------------------------------------------------------------------------------ % WordOut with category TagOut-SVsOut can be produced from % WordIn with category TagIn-SVsIn by the application of a single % lexical rule; TagOut-SVsOut is fully dereferenced on output; % Words are converted to character lists and back again % ------------------------------------------------------------------------------ lex_rule(WordIn,TagIn,SVsIn,WordOut,TagOut,SVsOut,IqsIn,IqsOut) if_h SubGoals :- ( (_LexRuleName lex_rule DescIn **> DescOut morphs Morphs), Cond = true ; (_LexRuleName lex_rule DescIn **> DescOut if Cond morphs Morphs) ), empty_assoc(VarsIn), compile_desc(DescIn,TagIn,SVsIn,IqsIn,IqsMid,SubGoalsFinal,SubGoalsRest1, true,VarsIn,VarsMid,FSPal,[],FSsMid), compile_body(Cond,IqsMid,IqsMid2,SubGoalsRest1,SubGoalsMid,true,VarsMid, VarsMid2,FSPal,FSsMid,FSsMid2), compile_desc(DescOut,TagMid,bot,IqsMid2,IqsMid3,SubGoalsMid, [morph(Morphs,WordIn,WordOut), fully_deref_prune(TagMid,bot,TagOut,SVsOut,IqsMid3,IqsOut)], true,VarsMid2,_,FSPal,FSsMid2,FSsOut), build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsFinal,[]). % ------------------------------------------------------------------------------ % morph(Morphs,WordIn,WordOut) % ------------------------------------------------------------------------------ % converst WordIn to list of chars, performs morph_chars using Morphs % and then converts resulting characters to WordOut % ------------------------------------------------------------------------------ morph(Morphs,WordIn,WordOut):- name(WordIn,CodesIn), make_char_list(CodesIn,CharsIn), morph_chars(Morphs,CharsIn,CharsOut), make_char_list(CodesOut,CharsOut), name(WordOut,CodesOut). % ------------------------------------------------------------------------------ % morph_chars(Morphs:)>, % CharsIn:)>, CharsOut:)>) % ------------------------------------------------------------------------------ % applies first pattern rewriting in Morphs that matches input CharsIn % to produce output CharsOut; CharsIn should be instantiated and % CharsOut should be uninstantiated for sound result % ------------------------------------------------------------------------------ morph_chars((Morph,Morphs),CharsIn,CharsOut):- morph_template(Morph,CharsIn,CharsOut) -> true ; morph_chars(Morphs,CharsIn,CharsOut). morph_chars(Morph,CharsIn,CharsOut):- morph_template(Morph,CharsIn,CharsOut). % ------------------------------------------------------------------------------ % morph_template(Morph:, CharsIn:, CharsOut:) % ------------------------------------------------------------------------------ % applies tempalte Morph to CharsIn to produce Chars Out; first % breaks Morph into an input and output pattern and optional condition % ------------------------------------------------------------------------------ morph_template((PattIn becomes PattOut),CharsIn,CharsOut):- morph_pattern(PattIn,CharsIn), morph_pattern(PattOut,CharsOut). morph_template((PattIn becomes PattOut when Cond),CharsIn,CharsOut):- morph_pattern(PattIn,CharsIn), call(Cond), morph_pattern(PattOut,CharsOut). % ------------------------------------------------------------------------------ % morph_pattern(Patt:,Chars:)>) % ------------------------------------------------------------------------------ % apply pattern Patt, which is sequence of atomic patterns, % to list of characters Chars, using conc/3 to deconstruct Chars % ------------------------------------------------------------------------------ morph_pattern(Var,CharsIn):- var(Var), !, Var = CharsIn. morph_pattern((AtPatt,Patt),CharsIn):- !, make_patt_list(AtPatt,List), append(List,CharsMid,CharsIn), morph_pattern(Patt,CharsMid). morph_pattern(AtPatt,CharsIn):- make_patt_list(AtPatt,CharsIn). % ------------------------------------------------------------------------------ % make_patt_list(AtPatt:,List:)>) % ------------------------------------------------------------------------------ % turns an atomic pattern AtPatt, either a variable, list of characters % or atom into a list of characters (or possibly a variable); List % should not be instantiated % ------------------------------------------------------------------------------ make_patt_list(Var,Var):- var(Var), !. make_patt_list([H|T],[H|TOut]):- !, make_patt_list(T,TOut). make_patt_list([],[]):- !. make_patt_list(Atom,CharList):- atom(Atom), name(Atom,Name), make_char_list(Name,CharList). % ------------------------------------------------------------------------------ % make_char_list(CharNames:)>, CharList:)>) % ------------------------------------------------------------------------------ % turns list of character ASCII codes and returns list of corresponding % characters % ------------------------------------------------------------------------------ make_char_list([],[]). make_char_list([CharName|Name],[Char|CharList]):- name(Char,[CharName]), make_char_list(Name,CharList). % ============================================================================== % Rounds-Kasper Logic % ============================================================================== % ------------------------------------------------------------------------------ % add_to(Phi:, Tag:, SVs:, IqsIn:s, IqsOut:s) % ------------------------------------------------------------------------------ % Info in Phi is added to FSIn (FSIn already derefenced); % ------------------------------------------------------------------------------ add_to(X,Ref2,SVs2,Iqs,Iqs) :- var(X), !,(X = Ref2-SVs2). add_to(Ref1-SVs1,Ref2,SVs2,IqsIn,IqsOut):- !, if((deref(Ref1,SVs1,Ref3,SVs3), u(SVs2,SVs3,Ref2,Ref3,IqsIn,IqsOut)), true, (suppress_adderrs -> fail ; error_msg((nl, write('add_to could not unify '), \+ \+ (duplicates_list([Ref1-SVs1,Ref2-SVs2],IqsIn,[],_,[],_,0,_), nl,tab(5),pp_fs(Ref1-SVs1,[],VisMid,5), nl, write('and '), pp_fs(Ref2-SVs2,VisMid,VisOut,5), pp_iqs(IqsIn,VisOut,_,5)), ttynl)))). add_to([],Ref,SVs,IqsIn,IqsOut):- !, add_to(e_list,Ref,SVs,IqsIn,IqsOut). add_to([H|T],Ref,SVs,IqsIn,IqsOut):- !, add_to((hd:H,tl:T),Ref,SVs,IqsIn,IqsOut). add_to(Path1 == Path2,Tag,SVs,IqsIn,IqsOut):- !, pathval(Path1,Tag,SVs,TagAtPath1,SVsAtPath1,IqsIn,IqsMid), deref(Tag,SVs,TagMid,SVsMid), pathval(Path2,TagMid,SVsMid,TagAtPath2,SVsAtPath2,IqsMid,IqsMid2), if(u(SVsAtPath1,SVsAtPath2,TagAtPath1,TagAtPath2,IqsMid2,IqsOut), true, (suppress_adderrs -> fail ; error_msg((nl, write('add_to could not unify paths '), write(Path1), write(' and '), write(Path2), write(' in '), nl, pp_fs(Tag-SVs,IqsIn,5), ttynl)))). add_to(=\= Desc,Tag,SVs,IqsIn,IqsOut):- !,add_to(Desc,Tag2,bot,IqsIn,IqsMid), check_inequal_conjunct(ineq(Tag,SVs,Tag2,bot,done),IqOut,Result), ( (Result = succeed) -> IqsOut = IqsMid ; ((IqOut \== done) -> IqsOut = [IqOut|IqsMid] ; (suppress_adderrs -> fail ; error_msg((nl, write('add_to could not inequate '), nl, pp_fs(Tag2-bot,[],5), nl, write('and '), nl, pp_fs(Tag-SVs,IqsIn,5), ttynl))))). add_to(Feat:Desc,Ref,SVs,IqsIn,IqsOut):- !, if(featval(Feat,SVs,Ref,FSatFeat,IqsIn,IqsMid), (deref(FSatFeat,RefatFeat,SVsatFeat), add_to(Desc,RefatFeat,SVsatFeat,IqsMid,IqsOut)), (suppress_adderrs -> fail ; error_msg((nl, write('add_to could not add feature '), write(Feat), write(' to '), pp_fs(Ref-SVs,IqsIn,5), ttynl)))). add_to((Desc1,Desc2),Ref,SVs,IqsIn,IqsOut):- !, add_to(Desc1,Ref,SVs,IqsIn,IqsMid), deref(Ref,SVs,Ref2,SVs2), add_to(Desc2,Ref2,SVs2,IqsMid,IqsOut). add_to((Desc1;Desc2),Ref,SVs,IqsIn,IqsOut):- !, ( add_to(Desc1,Ref,SVs,IqsIn,IqsOut) ; add_to(Desc2,Ref,SVs,IqsIn,IqsOut) ). add_to(@ MacroName,Ref,SVs,IqsIn,IqsOut):- !, if((MacroName macro Desc), add_to(Desc,Ref,SVs,IqsIn,IqsOut), error_msg((nl, write('add_to could not add undefined macro '), write(MacroName), write(' to '), pp_fs(Ref-SVs,IqsIn,5), ttynl))). add_to(Type,Ref,SVs,IqsIn,IqsOut):- type(Type), !, if(add_to_type(Type,SVs,Ref,IqsIn,IqsOut), true, (suppress_adderrs -> fail ; error_msg((nl, write('add_to could not add incompatible type '), write(Type), nl, write('to '), pp_fs(Ref-SVs,IqsIn,5), ttynl)))). add_to(FunDesc,Ref,SVs,IqsIn,IqsOut) :- % complex function constraints fun(FunDesc), !,mg_sat_goal(FunDesc,Fun,IqsIn,IqsMid), % can use for fun. desc.'s too fsolve(Fun,Ref,SVs,IqsMid,IqsOut). add_to(Atom,Ref,SVs,Iqs,Iqs) :- atomic(Atom), !, error_msg((nl, write('add_to could not add undefined type '), write(Atom), nl, write('to '), pp_fs(Ref-SVs,Iqs,5), ttynl)). add_to(Desc,Ref,SVs,Iqs,Iqs):- error_msg((nl,write('add_to could not add ill formed complex description '), nl, tab(5), write(Desc), nl, write('to '), pp_fs(Ref-SVs,Iqs,5), ttynl)). % add_to_list(Descs:s,FSs:s,IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % add each description in Descs to the respective FS in FSs % ------------------------------------------------------------------------------ add_to_list([],[],Iqs,Iqs). add_to_list([Desc|Descs],[FS|FSs],IqsIn,IqsOut) :- deref(FS,Tag,SVs), add_to(Desc,Tag,SVs,IqsIn,IqsMid), add_to_list(Descs,FSs,IqsMid,IqsOut). % add_to_fresh(Descs:s,FSs:s,IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % same as add_to_list, but instantiates the FS's first to bottom % ------------------------------------------------------------------------------ add_to_fresh([],[],Iqs,Iqs). add_to_fresh([Desc|Descs],[Ref-bot|FSs],IqsIn,IqsOut) :- add_to(Desc,Ref,bot,IqsIn,IqsMid), add_to_fresh(Descs,FSs,IqsMid,IqsOut). % ------------------------------------------------------------------------------ % pathval(P:,TagIn:,SVsIn:,TagOut:, % IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % TagOut-SVsOut is the undereferenced value of dereferenced TagIn-SVsIn % at path P % ------------------------------------------------------------------------------ pathval([],Tag,SVs,Tag,SVs,Iqs,Iqs). pathval([Feat|Path],Tag,SVs,TagOut,SVsOut,IqsIn,IqsOut):- if(featval(Feat,SVs,Tag,FSMid,IqsIn,IqsMid), (deref(FSMid,TagMid,SVsMid), pathval(Path,TagMid,SVsMid,TagOut,SVsOut,IqsMid,IqsOut)), (suppress_adderrs -> fail ; (write('feature '), write(Feat), write(' in path '), write([Feat|Path]), write('could not be added to '), pp_fs(Tag-SVs,[],5), fail))). % ------------------------------------------------------------------------------ % add_to_type(Type:,SVs:,Ref:,IqsIn:s, % IqsOut:s) mh(2) % ------------------------------------------------------------------------------ % adds Type to Ref-SVs -- arranged so that it can be compiled % ------------------------------------------------------------------------------ add_to_type(Type1,SVs2,Ref,IqsIn,IqsOut) if_h SubGoals :- unify_type(Type1,Type2,Type3), add_to_typeact(Type2,Type3,Type1,SVs2,Ref,IqsIn,IqsOut,SubGoals). % ------------------------------------------------------------------------------ % add_to_typeact(Type2,Type3,Type1,SVs,Ref,IqsIn,IqsOut,SubGoals) % ------------------------------------------------------------------------------ % SubGoals is code to add type Type1 to Ref-SVs of type Type2, with % result being of Type3 % ------------------------------------------------------------------------------ add_to_typeact(a_ X,a_ X,a_ X,a_ X,_,Iqs,Iqs,[]) :- !. add_to_typeact(a_ X,a_ X,bot,a_ X,_,Iqs,Iqs,[]) :- !. add_to_typeact(bot,a_ X,a_ X,bot,_-(a_ X),Iqs,Iqs,[]) :- !. add_to_typeact(Type2,Type3,Type1,SVs2,Ref,IqsIn,IqsOut,SubGoals):- approps(Type2,FRs2), ( (sub_type(Type1,Type2)) % if Type1 subsumes Type2, then do nothing -> (same_length(FRs2,Vs2), SubGoals = [], IqsOut = IqsIn) ; ((FRs2 = []) % if Type2 is atomic, then we can use MGSat for Type3 -> (mgsc(Type3,SVs3,Tag3,IqsIn,IqsOut,SubGoals,[]), Ref = (Tag3-SVs3), Vs2 = []) ; (approps(Type3,FRs3), % o.w. need to find out which feat's are new map_new_feats(FRs2,FRs3,Vs2,Vs3,IqsIn,IqsMid,SubGoals,SubGoalsRest), add_to_typecons(Type3,Type2,Tag3,SVs3,IqsMid,IqsOut,SubGoalsRest), ((Vs3 = []) -> SVs3 = Type3 ; (SVs4 =.. [Type3|Vs3], SVs3 = SVs4)), Ref = (Tag3-SVs3)) )), SVs2 =.. [Type2|Vs2]. % ------------------------------------------------------------------------------ % add_to_typecons(Type:,ExclType:,Tag:,SVs:s, % IqsIn:s,IqsOut:s,SubGoals:s) % ------------------------------------------------------------------------------ % Enforce the constraint for Type, and for all supersorts of Type, excluding % those in the ideal of ExclType, on Tag-SVs % ------------------------------------------------------------------------------ add_to_typecons(Type,ET,Tag,SVs,IqsIn,IqsOut,SubGoals) :- esetof(T,(sub_type(T,Type), % find set of types whose constraints \+sub_type(T,ET)),ConsTypes), % must be satisfied map_cons(ConsTypes,Tag,SVs,IqsIn,IqsOut,SubGoals,[]). % this map_cons is the same as the one for ucons % ------------------------------------------------------------------------------ % featval(F:,SVs:,Ref:,V:, % IqsIn:s,IqsOut:s) mh(1) % ------------------------------------------------------------------------------ % Ref-SVs value for feature F is V -- may involve coercion; % Ref-SVs is fully dereferenced; V may not be % ------------------------------------------------------------------------------ featval(F,SVs,Tag,V,IqsIn,IqsOut) if_h SubGoals:- introduce(F,TypeIntro), add_to_type(TypeIntro,SVs,Tag,IqsIn,IqsOut) if_h SubGoals, % actually seems to pay to recompute this rather than compile featval % add_to_type code in one shot deref(Tag,SVs,_NewTag,NewSVs), NewSVs =.. [Sort|Vs], % don't have to worry about atoms as long as approps(Sort,FRs), % TypeIntro can't be bot (i.e. bot has no features) find_featval(F,FRs,Vs,V). % ------------------------------------------------------------------------------ % find_featval(Feat,FRs,Vs,V) % ------------------------------------------------------------------------------ % V is element of Vs same distance from front as F:_ is from front of FRs % ------------------------------------------------------------------------------ find_featval(F,[F:_TypeRestr|_],[V|_Vs],V):-!. find_featval(F,[_|FRs],[_|Vs],V):- find_featval(F,FRs,Vs,V). % ------------------------------------------------------------------------------ % iso(FS1:, FS2:) % ------------------------------------------------------------------------------ % determines whether structures FS1 and FS2 are isomorphic; % not currently used, but perhaps necessary for inequations % ------------------------------------------------------------------------------ iso(FS1,FS2):- iso_seq(iso(FS1,FS2,done)). % ------------------------------------------------------------------------------ % iso_seq(FSSeq:) % ------------------------------------------------------------------------------ % takes structure consisting of done/0 or iso(FS1,FS2,Isos) % representing list of isomorphisms. makes sure that all are isomorphic % ------------------------------------------------------------------------------ iso_seq(done). iso_seq(iso(FS1,FS2,Isos)):- deref(FS1,Tag1,SVs1), deref(FS2,Tag2,SVs2), ( (Tag1 == Tag2) -> iso_seq(Isos) ; (Tag1 = Tag2, iso_sub_seq(SVs1,SVs2,Isos))). iso_sub_seq(a_ X,a_ Y,Isos) if_h [X==Y,iso_seq(Isos)]. % ext. like Prolog iso_sub_seq(SVs1,SVs2,Isos) if_h SubGoal :- extensional(Sort), \+ (Sort = a_ _), approps(Sort,FRs), length(FRs,N), functor(SVs1,Sort,N), functor(SVs2,Sort,N), new_isos(N,SVs1,SVs2,Isos,SubGoal). new_isos(0,_,_,SubGoal,[iso_seq(SubGoal)]) :- !. new_isos(N,SVs1,SVs2,Isos,SubGoal) :- arg(N,SVs1,V1), arg(N,SVs2,V2), M is N-1, new_isos(M,SVs1,SVs2,iso(V1,V2,Isos),SubGoal). % ------------------------------------------------------------------------------ % extensionalise(Ref:, SVs:, Iqs:) %------------------------------------------------------------------------------- % search for extensional types which should be unified in Tag-SVs, and its % inequations, and do it. Extensional types are assumed to be maximal. %------------------------------------------------------------------------------- extensionalise(Ref,SVs,Iqs) :- ext_act(fs(Ref,SVs,fsdone),edone,done,Iqs). extensionalise(FS,Iqs) :- deref(FS,Ref,SVs), ext_act(fs(Ref,SVs,fsdone),edone,done,Iqs). ext_act(fs(Ref,SVs,FSs),ExtQ,Ineqs,Iqs) :- check_pre_traverse(SVs,Ref,ExtQ,FSs,Ineqs,Iqs). ext_act(fsdone,ExtQ,Ineqs,Iqs) :- ext_ineq(Ineqs,ExtQ,Iqs). ext_ineq(ineq(Ref1,SVs1,Ref2,SVs2,Ineqs),ExtQ,Iqs) :- deref(Ref1,SVs1,DRef1,DSVs1), deref(Ref2,SVs2,DRef2,DSVs2), ext_act(fs(DRef1,DSVs1,fs(DRef2,DSVs2,fsdone)),ExtQ,Ineqs,Iqs). ext_ineq(done,ExtQ,Iqs) :- ext_iqs(Iqs,ExtQ). ext_iqs([Iq|Iqs],ExtQ) :- ext_ineq(Iq,ExtQ,Iqs). ext_iqs([],_). extensionalise_list(FSList,Iqs) :- list_to_fss(FSList,FSs), ext_act(FSs,edone,done,Iqs). list_to_fss([],fsdone). list_to_fss([FS|FSList],fs(Tag,SVs,FSs)) :- deref(FS,Tag,SVs), list_to_fss(FSList,FSs). check_pre_traverse(SVs,Ref,ExtQ,FSs,Ineqs,Iqs) if_b [!|SubGoals] :- type(T), ( (T = (a_ _)) -> SVs = T, SubGoals = [traverseQ(ExtQ,Ref,SVs,FSs,ExtQ,Ineqs,Iqs)] ; extensional(T) -> approps(T,FRs), length(FRs,N), functor(SVs,T,N), SubGoals = [traverseQ(ExtQ,Ref,SVs,FSs,ExtQ,Ineqs,Iqs)] ). check_pre_traverse(SVs,_,ExtQ,FSs,Ineqs,Iqs) if_b [check_post_traverse(SVs,ExtQ,FSs,Ineqs,Iqs)]. check_post_traverse(SVs,ExtQ,FSs,Ineqs,Iqs) if_b [!|SubGoals] :- type(T), clause(ext_sub_structs(T,SVs,NewFSs,FSs,SubGoals, [ext_act(NewFSs,ExtQ,Ineqs,Iqs)]),true). check_post_traverse(_,ExtQ,FSs,Ineqs,Iqs) if_b [ext_act(FSs,ExtQ,Ineqs,Iqs)]. % ------------------------------------------------------------------------------ % traverseQ(ExtQRest:s,ExtQ:s,Ref:,SVs:,FSs:s, % Ineqs:s,Iqs:s) % ------------------------------------------------------------------------------ % Add Ref-SVs to the extensionality queue, ExtQ. Only ExtQRest remains to % traverse (ExtQ is the head). If the difference is unbound, then add Ref-SVs % to the end. If the first element on the difference is the same FS as % Ref-SVs, then no need to add. If the first element can be extensionally % identified with Ref-SVs, then stop looking, since now Ref-SVs is the same as % that FS. If none of these, then go on to the next element. % ------------------------------------------------------------------------------ traverseQ(edone,Ref,SVs,FSs,ExtQ,Ineqs,Iqs) :- check_post_traverse(SVs,ext(Ref,SVs,ExtQ),FSs,Ineqs,Iqs). traverseQ(ext(ERef,ESVs,ERest),Ref,SVs,FSs,ExtQ,Ineqs,Iqs) :- ERef == Ref -> ext_act(FSs,ExtQ,Ineqs,Iqs) ; iso_seq(iso(Ref-SVs,ERef-ESVs,done)) -> ext_act(FSs,ExtQ,Ineqs,Iqs) ; traverseQ(ERest,Ref,SVs,FSs,ExtQ,Ineqs,Iqs). % ------------------------------------------------------------------------------ % check_inequal(IqsIn:s,IqsOut:s) %------------------------------------------------------------------------------- % Checks the inequations in IqsIn. Inequations are given in CNF, hence % IqsIn = [Iq_1,...,Iq_n] holds if Iq_1 holds and ... and Iq_n holds % Iq_i = ineq(Tag1,SVs1,Tag2,SVs2,ineq(...,done)...) holds if FS1 is not % structure-shared with FS2 or ... ("done" marks end of list) %------------------------------------------------------------------------------- check_inequal([],[]). check_inequal([IqIn|IqsIn],IqsOut) :- check_inequal_conjunct(IqIn,IqOut,Result), check_inequal_act(Result,IqOut,IqsIn,IqsOut). check_inequal_act(done,done,_,_) :- % conjunct not satisfied !,fail. check_inequal_act(succeed,_,IqsIn,IqsOut) :- % conjunct satisfied !,check_inequal(IqsIn,IqsOut). check_inequal_act(_,IqOut,IqsIn,[IqOut|IqsOut]) :- % conjunct temporarily check_inequal(IqsIn,IqsOut). % satisfied check_inequal_conjunct(done,done,done). check_inequal_conjunct(ineq(ITag1,ISVs1,ITag2,ISVs2,IqInRest),IqOut,Result) :- deref(ITag1,ISVs1,Tag1,SVs1), deref(ITag2,ISVs2,Tag2,SVs2), ( (Tag1 == Tag2) -> check_inequal_conjunct(IqInRest,IqOut,Result) ; ((SVs1 = a_ X) % fold in results of unify_type/3 and atom extensionality -> ((SVs2 = a_ Y) -> ((X==Y) -> check_inequal_conjunct(IqInRest,IqOut,Result) ; ((\+ \+(X=Y)) -> (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest), check_inequal_conjunct(IqInRest,IqOutRest,Result)) ; (Result = succeed))) ; (functor(SVs2,Sort2,_), ((Sort2 \== bot) -> Result = succeed ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest), check_inequal_conjunct(IqInRest,IqOutRest,Result))))) ; ((SVs2 = a_ _) -> (functor(SVs1,Sort1,_), ((Sort1 \== bot) -> Result = succeed ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest), check_inequal_conjunct(IqInRest,IqOutRest,Result)))) ; (functor(SVs1,Sort1,_), functor(SVs2,Sort2,_), (unify_type(Sort1,Sort2,_) -> (check_sub_seq(SVs1,SVs2,IqInRest,IqOut,Result) -> true ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest), check_inequal_conjunct(IqInRest,IqOutRest,Result))) ; Result = succeed))))). check_sub_seq(_,_,_,_,_) if_h [fail] :- % atoms never make it to check_sub_seq \+ (extensional(S),(\+ (S = a_ _))). check_sub_seq(SVs1,SVs2,IqInRest,IqOut,Result) if_h SubGoal :- extensional(Sort), \+ (Sort = a_ _), approps(Sort,FRs), length(FRs,N), functor(SVs1,Sort,N), functor(SVs2,Sort,N), new_checks(N,SVs1,SVs2,IqInRest,IqOut,Result,SubGoal). new_checks(0,_,_,SubGoal,IqOut,Result, [check_inequal_conjunct(SubGoal,IqOut,Result)]) :- !. new_checks(N,SVs1,SVs2,IqInRest,IqOut,Result,SubGoal) :- arg(N,SVs1,VTag1-VSVs1), arg(N,SVs2,VTag2-VSVs2), M is N-1, new_checks(M,SVs1,SVs2,ineq(VTag1,VSVs1,VTag2,VSVs2,IqInRest), IqOut,Result,SubGoal). % ------------------------------------------------------------------------------ % match_list(Sort:,Vs:,Tag:,SVs:,Right:,N:, % Dtrs:,DtrsRest:,NextRight:,Chart:, % IqsIn:,IqsOut:) % ------------------------------------------------------------------------------ % Run-time predicate compiled into rules. Matches a list of cats in Chart, % specified by Sort(Vs), to span an edge to OldRight, the first of which is % Tag-SVs, which spans to Right. Also matches an edge for the next category % of the current rule to use (necessary because an initial empty-list cats % matches nothing). % ------------------------------------------------------------------------------ match_list(Sort,[HdFS,TlFS],Tag,SVs,Right,N,[N|DtrsMid],DtrsRest,Chart, NextRight,IqsIn,IqsOut) :- sub_type(ne_list,Sort), !,ud(HdFS,Tag,SVs,IqsIn,IqsMid), check_inequal(IqsMid,IqsMid2), deref(TlFS,_,TlSVs), TlSVs =.. [TlSort|TlVs], % a_ correctly causes error in recursive call match_list_rest(TlSort,TlVs,Right,NextRight,DtrsMid,DtrsRest,Chart,IqsMid2, IqsOut). match_list(Sort,_,_,_,_,_,_,_,_,_,_,_) :- error_msg((nl,write('error: cats> value with sort, '),write(Sort), write(' is not a valid list argument'))). % ------------------------------------------------------------------------------ % match_list_rest(Sort,Vs:,Right:,NewRight:, % DtrsRest:,DtrsRest2:,Chart:,IqsIn:, % IqsOut:) % ------------------------------------------------------------------------------ % same as match_list, except edge spans from Right to NewRight, and no % matches for the next category are necessary % ------------------------------------------------------------------------------ match_list_rest(e_list,_,Right,Right,DtrsRest,DtrsRest,_,Iqs,Iqs) :- !. match_list_rest(Sort,[HdFS,TlFS],Right,NewRight,[N|DtrsRest],DtrsRest2,Chart, IqsIn,IqsOut) :- sub_type(ne_list,Sort), !,get_edge(Right,Chart,N,MidRight,Tag,SVs,EdgeIqs,_,_), ud(HdFS,Tag,SVs,IqsIn,IqsMid), append(IqsMid,EdgeIqs,IqsMid2), check_inequal(IqsMid2,IqsMid3), deref(TlFS,_,TlSVs), TlSVs =.. [TlSort|TlVs], % a_ correctly causes error in recursive call match_list_rest(TlSort,TlVs,MidRight,NewRight,DtrsRest,DtrsRest2,Chart, IqsMid3,IqsOut). match_list_rest(Sort,_,_,_,_,_,_,_,_) :- error_msg((nl,write('error: cats> value with sort, '),write(Sort), write(' is not a valid list argument'))). % ============================================================================== % Chart Parser % ============================================================================== % ------------------------------------------------------------------------------ % rec(+Ws:s, Tag:, SVs:, Iqs:s) % ------------------------------------------------------------------------------ % Ws can be parsed as category Tag-SVs with inequations Iqs; Tag-SVs % uninstantiated to start % ------------------------------------------------------------------------------ :- dynamic num/1. rec(Ws,Tag,SVs,IqsOut):- clear, assert(parsing(Ws)), asserta(num(0)), reverse_count(Ws,[],WsRev,0,Length), CLength is Length - 1, functor(Chart,chart,CLength), build(WsRev,Length,Chart), retract(to_rebuild(Index)), clause(edge(Index,0,Length,Tag,SVs,IqsIn,_,_),true), extensionalise(Tag,SVs,IqsIn), check_inequal(IqsIn,IqsOut). % ------------------------------------------------------------------------------ % rec(+Ws:s, Tag:, SVs:, Iqs:s, ?Desc:) % ------------------------------------------------------------------------------ % Like rec/4, but Tag-SVs also satisfies description, Desc. % ------------------------------------------------------------------------------ rec(Ws,TagOut,SVsOut,IqsOut,Desc) :- clear, assert(parsing(Ws)), asserta(num(0)), reverse_count(Ws,[],WsRev,0,Length), CLength is Length - 1, functor(Chart,chart,CLength), build(WsRev,Length,Chart), retract(to_rebuild(Index)), clause(edge(Index,0,Length,Tag,SVs,IqsIn,_,_),true), (secret_noadderrs ; secret_adderrs, fail), add_to(Desc,Tag,SVs,IqsIn,IqsMid), deref(Tag,SVs,TagOut,SVsOut), extensionalise(TagOut,SVsOut,IqsMid), check_inequal(IqsMid,IqsOut), (secret_adderrs ; secret_noadderrs, fail). % ------------------------------------------------------------------------------ % build(Ws:s, Right:, Chart:) % ------------------------------------------------------------------------------ % fills in inactive edges of chart from beginning to Right using % Ws, representing words in chart in reverse order. Chart is the functor % 'chart' of arity equal to the length of the input string (which is thus % bounded at 255). % ------------------------------------------------------------------------------ build([W|Ws],Right,Chart):- RightMinus1 is Right - 1, ( % empty_cat(N,Right,Tag,SVs,Iqs,_,_), % rule(Tag,SVs,Iqs,Right,Right,empty(N,Right)) % ; [no,lexical,entry,for,W] if_error (\+ lex(W,_,_,_) ), lex(W,Tag,SVs,Iqs), add_edge(RightMinus1,Right,Tag,SVs,Iqs,[],lexicon,Chart) ; ( RightMinus1 =:= 0 -> true ; rebuild_edges(Edges), arg(RightMinus1,Chart,Edges), build(Ws,RightMinus1,Chart) ) ). %build([],_):- % empty_cat(N,0,Tag,SVs,Iqs,_,_), % rule(Tag,SVs,Iqs,0,0,empty(N,0)). build([],_,_). % ------------------------------------------------------------------------------ % rebuild_edges(Edges:s) % ------------------------------------------------------------------------------ % Copy non-looping edges asserted into the database in the most recent pass % (all of the edges from the most recent node) into an edge/8 structure on % the heap for inclusion into the chart. Copying them once now means that we % only copy an edge once in total rather than every time a rule asks for it. % We can do this because we have closed the rules under prefixes of empty % categories; so we know that no edge will be needed until closure at the next % node begins. % ------------------------------------------------------------------------------ rebuild_edges(Edges) :- retract(to_rebuild(Index)) -> clause(edge(Index,_,R,T,S,IQ,D,RN),true), Edges = edge(Index,R,T,S,IQ,D,RN,EdgesRest), rebuild_edges(EdgesRest) ; Edges = nomore. % ------------------------------------------------------------------------------ % add_edge_deref(Left:, Right:, Tag:, SVs:, % Iqs:s,Dtrs:s,RuleName,Chart:) eval % ------------------------------------------------------------------------------ % adds dereferenced category Tag-SVs,Iqs as inactive edge from Left to Right; % check for any rules it might start, then look for categories in Chart % to complete those rules % ------------------------------------------------------------------------------ add_edge_deref(Left,Right,Tag,SVs,IqsIn,Dtrs,RuleName,Chart):- fully_deref_prune(Tag,SVs,TagOut,SVsOut,IqsIn,IqsOut), (no_subsumption -> (edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) -> rule(TagOut,SVsOut,IqsOut,Left,Right,N,Chart)) ; (subsumed(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName) -> fail ; (edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) -> rule(TagOut,SVsOut,IqsOut,Left,Right,N,Chart)))). add_edge(Left,Right,TagOut,SVsOut,Iqs,Dtrs,RuleName,Chart):- (no_subsumption -> (edge_assert(Left,Right,TagOut,SVsOut,Iqs,Dtrs,RuleName,N) -> rule(TagOut,SVsOut,Iqs,Left,Right,N,Chart)) ; (subsumed(Left,Right,TagOut,SVsOut,Iqs,Dtrs,RuleName) -> fail ; (edge_assert(Left,Right,TagOut,SVsOut,Iqs,Dtrs,RuleName,N) -> rule(TagOut,SVsOut,Iqs,Left,Right,N,Chart)))). gennum(N) :- retract(num(N)), NewN is N+1, asserta(num(NewN)). gen_emptynum(N) :- retract(emptynum(N)), NewN is N-1, asserta(emptynum(NewN)). count_edges(N):- setof(edge(M,X,Y,Z,W,I,D,R),edge(M,X,Y,Z,W,I,D,R),Es), length(Es,N). % ------------------------------------------------------------------------------ % get_edge(Left:,Chart:,Index:,Right:,Tag:, % SVs:,EdgeIqs:,Dtrs:s,RuleName:) % ------------------------------------------------------------------------------ % Retrieve an edge from the chart, which means either an empty category % or one of the non-empty edges in Chart % ------------------------------------------------------------------------------ get_edge(Right,_,empty(N,Right),Right,Tag,SVs,EdgeIqs,Dtrs,RuleName) :- empty_cat(N,Right,Tag,SVs,EdgeIqs,Dtrs,RuleName). get_edge(Left,Chart,N,Right,Tag,SVs,EdgeIqs,Dtrs,RuleName) :- arg(Left,Chart,Edges), edge_member(Edges,N,Right,Tag,SVs,EdgeIqs,Dtrs,RuleName). % clause(edge(Left,N,Right,Tag,SVs,EdgeIqs,Dtrs,RuleName),true). edge_member(edge(I,R,T,S,IQ,D,RN,Edges),N,Right,Tag,SVs,EdgeIqs,Dtrs, RuleName) :- I = N, R = Right, T = Tag, S = SVs, IQ = EdgeIqs, D = Dtrs, RN = RuleName ; edge_member(Edges,N,Right,Tag,SVs,EdgeIqs,Dtrs,RuleName). % ------------------------------------------------------------------------------ % subsumed(Left:,Right:,Tag:,SVs:,Iqs:s, % Dtrs:s,RuleName) % ------------------------------------------------------------------------------ % Check if any edge spanning Left to Right subsumes Tag-SVs, the feature % structure of the candidate edge, or vice versa. Succeeds based on whether % or not Tag-SVs is subsumed - but all edges subsumed by Tag-SVs are also % retracted. % ------------------------------------------------------------------------------ subsumed(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName) :- clause(to_rebuild(EI),true), clause(edge(EI,Left,Right,ETag,ESVs,EIqs,_,_),true), %this may have >1 soln! empty_assoc(H), empty_assoc(K), subsume(s(Tag,SVs,ETag,ESVs,sdone),Iqs,EIqs,<,>,LReln,RReln,H,K), subsumed_act(RReln,LReln,EI,Tag,SVs,Iqs,Dtrs,RuleName,Left,Right). subsumed_act(>,LReln,EI,Tag,SVs,Iqs,Dtrs,RuleName,Left,Right) :- %edge subsumes !,edge_discard(LReln,EI,Tag,SVs,Iqs,Dtrs,RuleName,Left,Right). % candidate subsumed_act(#,<,EI,Tag,SVs,Iqs,Dtrs,RuleName,Left,_) :- % candidate edge_retract(Left,EI,Tag,SVs,Iqs,Dtrs,RuleName). % subsumes edge % subsumed_act(#,#,_,_,_,_,_,_,_,_) fails % subsume(Ss,Iqs1,Iqs2,LeftRelnIn,RightRelnIn,LeftRelnOut,RightRelnOut,H,K) % ------------------------------------------------------------------------------ % LeftRelnOut is bound to < if LeftRelnIn is not # and there exists a % subsumption morphism, H (see Carpenter, 1992, p. 41) from Tag1-SVs1 to % Tag2-SVs2, for every s(Tag1,SVs1,Tag2,SVs2,_) in Ss, and from the % inequations in Iqs1 to those in Iqs2. Otherwise, LeftRelnOut is bound to % #. RightRelnOut is bound to > if RightRelnIn is not #, and % a subsumption morphism, K, exists in the reverse direction, and is bound % otherwise to #. The FS's in the s-structures are expected to be fully % dereferenced, with irrelevant inequations pruned off (which can be % achieved by using fully_deref_prune). % ------------------------------------------------------------------------------ subsume(sdone,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- subsume_iqs(Iqs,EIqs,LRelnIn,LRelnOut,H), % as a last resort, try to subsume_iqs(EIqs,Iqs,RRelnIn,RRelnOut,K). % disprove subsumption using ineqs subsume(s(Tag,SVs,ETag,ESVs,Ss),Iqs,EIqs, LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- get_assoc(Tag,H,HPair) -> (get_assoc(ETag,K,KPair) % first try to disprove subsumption using -> HPair = [HTag|_], % observed structure sharing at current roots KPair = [KTag|_], (KTag == Tag -> (HTag == ETag -> ((LRelnIn == #,RRelnIn == #) -> LRelnOut = #,RRelnOut = # % we can quit once we show this ; subsume(Ss,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) ) ; LRelnOut = #, (RRelnIn == # -> RRelnOut = # ; subsume(Ss,Iqs,EIqs,#,RRelnIn,#,RRelnOut,H,K) ) ) ; RRelnOut = #, (HTag == ETag -> (LRelnIn == # -> LRelnOut = # ; subsume(Ss,Iqs,EIqs,LRelnIn,#,LRelnOut,#,H,K) ) ; LRelnOut = #, RRelnOut = # ) ) ; LRelnOut = #, (RRelnIn == # -> RRelnOut = # ; subsume_type(SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,#,RRelnIn, #,RRelnOut,H,K) ) ) ; (get_assoc(ETag,K,KPair) -> RRelnOut = #, (LRelnIn == # -> LRelnOut = # ; subsume_type(Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs,LRelnIn,#, LRelnOut,#,H,K) ) ; subsume_type(SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn, LRelnOut,RRelnOut,H,K) ). % next try to disprove subsumption using type information at root node subsume_type(bot,(a_ X),Tag,ETag,Ss,Iqs,EIqs,LRelnIn,_RRelnIn,LRelnOut, RRelnOut,H,K) if_b [!,RRelnOut = #, (LRelnIn == # -> LRelnOut = # ; put_assoc(Tag,H,[ETag|(a_ X)],NewH), subsume(Ss,Iqs,EIqs,LRelnIn,#,LRelnOut,#, NewH,K) )]. subsume_type((a_ X),bot,Tag,ETag,Ss,Iqs,EIqs,_LRelnIn,RRelnIn,LRelnOut, RRelnOut,H,K) if_b [!,LRelnOut = #, (RRelnIn == # -> RRelnOut = # ; put_assoc(ETag,K,[Tag|(a_ X)],NewK), subsume(Ss,Iqs,EIqs,#,RRelnIn,#,RRelnOut, H,NewK) )]. subsume_type((a_ X),(a_ Y),Tag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut, RRelnOut,H,K) if_b [!,(subsumes_chk(X,Y) % this is all variant/2 -> (subsumes_chk(Y,X) % does anyway -> ((LRelnIn == # -> LRelnOut = #, H = NewH ; put_assoc(Tag,H,[ETag|(a_ Y)], NewH) ), (RRelnIn == # -> RRelnOut = #, K = NewK ; put_assoc(ETag,K,[Tag|(a_ X)], NewK) ), subsume(Ss,Iqs,EIqs,LRelnIn,RRelnIn, LRelnOut,RRelnOut,NewH,NewK) ) ; RRelnOut = #, (LRelnIn == # -> LRelnOut = # ; put_assoc(Tag,H,[ETag|(a_ Y)], NewH), subsume(Ss,Iqs,EIqs,LRelnIn,#, LRelnOut,#,NewH,K) ) ) ; (subsumes_chk(Y,X) -> LRelnOut = #, (RRelnIn == # -> RRelnOut = # ; put_assoc(ETag,K,[Tag|(a_ X)], NewK), subsume(Ss,Iqs,EIqs,#,RRelnIn,#, RRelnOut,H,NewK) ) ; LRelnOut = #, RRelnOut = # ) )]. subsume_type(SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut, H,K) if_b SubGoals :- Sort subs _, % dont want a_/1 atoms approps(Sort,FRs), length(FRs,N), length(Vs,N), SVs =.. [Sort|Vs], subsume_type_act(Sort,FRs,N,Vs,SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn, LRelnOut,RRelnOut,H,K,SubGoals). subsume_type_act(Sort,_FRs,N,Vs,SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn, LRelnOut,RRelnOut,H,K,[!,(LRelnIn == # -> LRelnOut = #, H = NewH ; put_assoc(Tag,H,[ETag|ESVs],NewH) ), (RRelnIn == # -> RRelnOut = #, K = NewK ; put_assoc(ETag,K,[Tag|SVs],NewK) ), subsume(NewSs,Iqs,EIqs,LRelnIn, RRelnIn,LRelnOut,RRelnOut, NewH,NewK)]) :- length(EVs,N), append_s(Vs,EVs,Ss,NewSs), ESVs =.. [Sort|EVs]. subsume_type_act(Sort,FRs,_N,Vs,_SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,LRelnIn, _RRelnIn,LRelnOut,RRelnOut,H,K, [!,RRelnOut = #, (LRelnIn == # -> LRelnOut = # ; put_assoc(Tag,H,[ETag|ESVs],NewH), subsume(NewSs,Iqs,EIqs,LRelnIn,#,LRelnOut,#,NewH,K) )]) :- sub_type(Sort,ESort), \+ functor(ESort,'a_',1), ESort \== Sort, approps(ESort,EFRs), length(EFRs,EN), length(EVs,EN), sub_feats(FRs,EFRs,EVs,SubEVs), append_s(Vs,SubEVs,Ss,NewSs), ESVs =.. [ESort|EVs]. subsume_type_act(Sort,FRs,_N,Vs,SVs,ESVs,Tag,ETag,Ss,Iqs,EIqs,_LRelnIn,RRelnIn, LRelnOut,RRelnOut,H,K,[!,LRelnOut = #, (RRelnIn == # -> RRelnOut = # ; put_assoc(ETag,K,[Tag|SVs],NewK), subsume(NewSs,Iqs,EIqs,#,RRelnIn, #,RRelnOut,H,NewK) )]) :- sub_type(ESort,Sort), \+ functor(Sort,'a_',1), Sort \== ESort, approps(ESort,EFRs), length(EFRs,EN), length(EVs,EN), sub_feats(EFRs,FRs,Vs,SubVs), append_s(SubVs,EVs,Ss,NewSs), ESVs =.. [ESort|EVs]. subsume_type_act(_,_,_,_,_,_,_,_,_,_,_,_,_,#,#,_,_,[]). % still need 1 arg to multi-hash subsume_iqs([],_,Reln,Reln,_). subsume_iqs([Iq|Iqs1],Iqs2,RelnIn,RelnOut,H) :- RelnIn == # -> RelnOut = # ; subsume_iq(Iq,Iqs2,RelnIn,RelnMid,H), % make sure image of each conjunct subsume_iqs(Iqs1,Iqs2,RelnMid,RelnOut,H). % holds in image FS subsume_iq(done,Iqs2Out,RelnIn,RelnOut,_) :- % negated image of conjunct is check_inequal(Iqs2Out,_) % satisfied by image FS, so no subsumption -> RelnOut = # % morphism exists. ; RelnOut = RelnIn. % image of conjunct is satisfied by an % inequation conjunct of the image FS (which % failed in the check_inequal/2 call) subsume_iq(ineq(Tag1,SVs1,Tag2,SVs2,IqRest),Iqs2Mid,RelnIn,RelnOut,H) :- (get_assoc(Tag1,H,HPair1) % test which inequated FS has an image -> HPair1 = [HTag1|HSVs1], (get_assoc(Tag2,H,HPair2) -> HPair2 = [HTag2|HSVs2], unify_disjunct_image(HTag1,HSVs1,HTag2,HSVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H) ; unify_disjunct_image(HTag1,HSVs1,Tag2,SVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H) ) ; get_assoc(Tag2,H,HPair2), % inequation was not pruned, so this one exists HPair2 = [HTag2|HSVs2], unify_disjunct_image(Tag1,SVs1,HTag2,HSVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H) % use an inequated FS with no image itself for matching conjuncts ) -> true ; RelnOut = RelnIn. % image of conjunct is % implicitly encoded in the image FS (since % unifying the images of the inequated FSs of % every disjunct failed earlier in this clause). unify_disjunct_image(Tag1,SVs1,Tag2,SVs2,IqRest,Iqs2Mid,RelnIn,RelnOut,H) :- u(SVs1,SVs2,Tag1,Tag2,Iqs2Mid,Iqs2Out), subsume_iq(IqRest,Iqs2Out,RelnIn,RelnOut,H). % sub_feats(SubFRs,FRs,Vs,SubVs) % ------------------------------------------------------------------------------ % SubFRs is a sorted sublist of sorted feature:restriction list, FRs. Vs is % a list of values of features of FRs in order. SubVs is the sublist of Vs % consisting of values of features of SubFRs in order. % ------------------------------------------------------------------------------ sub_feats([],_,_,[]) :- !. sub_feats([Feat:_|SubFRs],[Feat:_|FRs],[V|Vs],[V|SubVs]) :- !,sub_feats(SubFRs,FRs,Vs,SubVs). sub_feats(SubFRs,[_|FRs],[_|Vs],SubVs) :- sub_feats(SubFRs,FRs,Vs,SubVs). % append_s(Vs,EVs,Ss,NewSs) % ------------------------------------------------------------------------------ % NewSs is Ss plus in-order pairs of FS's from Vs and EVs (which are the same % length), in s-structures. % ------------------------------------------------------------------------------ append_s([],[],Ss,Ss). append_s([Tag-SVs|Vs],[ETag-ESVs|EVs],Ss,s(Tag,SVs,ETag,ESVs,NewSs)) :- append_s(Vs,EVs,Ss,NewSs). % edge_discard(LReln:/#,I:,Tag:,SVs:s,Iqs:s, % Dtrs:s,RuleName,Left:,Right:) % ------------------------------------------------------------------------------ % Discard edge Tag-SVs, with inequations Iqs, daughters Dtrs, created by rule % RuleName, because it is subsumed by the edge with index I. If LReln is a % variable, then the two are equal - otherwise, LReln is #, which indicates % strict subsumption. % ------------------------------------------------------------------------------ edge_discard(_,_,_,_,_,_,_,_,_) :- no_interpreter, !. edge_discard(LReln,I,Tag,SVs,Iqs,Dtrs,RuleName,Left,Right) :- length(Dtrs,ND), !,print_edge_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). print_edge_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nl,pp_fs(Tag-SVs,Iqs), nl,write('Edge created for category above:'), % nl,write(' index: '),write(I), nl,write(' from: '),write(Left),write(' to: '),write(Right), nl,write(' string: '),write_out(Left,Right), nl,write(' rule: '),write(RuleName), nl,write(' # of dtrs: '),write(ND),nl, print_edge_discard_act(LReln,I), nl,query_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). print_edge_discard_act(<,I) :- !,nl,write('is equal to an existing edge, index:'),write(I),write('.'). print_edge_discard_act(#,I) :- nl,write('is subsumed by an existing edge, index:'),write(I),write('.'). query_discard(_,_,_,_,_,_,_,_,_,_) :- go(_), !. query_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nl,write('Action(noadd,continue,break,dtr-#,existing,abort)? '), nl,read(Response), query_discard_act(Response,LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_discard_act(noadd,_,_,_,_,_,_,_,_,_,_) :- !. query_discard_act(continue,_,_,_,_,_,_,_,_,_,_) :- !,fail. query_discard_act(break,LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- !,break, print_edge_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_discard_act(dtr-D,LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule), !,length(DDtrs,DND), print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND), print_edge_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_discard_act(existing,LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- clause(edge(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName),true), !,edge_act(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName), print_edge_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_discard_act(abort,_,_,_,_,_,_,_,_,_,_) :- !,abort. query_discard_act(_,LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- query_discard(LReln,I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). % edge_retract(Left:,I:,Tag:,SVs:,Iqs:s, % Dtrs:s,RuleName:) % ------------------------------------------------------------------------------ % Retract edge with index I because it is subsumed by Tag-SVs, with inequations % Iqs, daughters Dtrs, created by rule RuleName % ------------------------------------------------------------------------------ edge_retract(Left,I,_,_,_,_,_) :- no_interpreter, retract(to_rebuild(I)), retract(edge(I,Left,_,_,_,_,_,_)), !,fail. % failure-drive through all subsumed edges edge_retract(Left,I,Tag,SVs,Iqs,Dtrs,RuleName) :- !,clause(edge(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName),true), length(EDtrs,NED), print_edge_retract(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName). print_edge_retract(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName) :- nl,pp_fs(ETag-ESVs,EIqs), nl,write('Edge created for category above:'), nl,write(' index: '),write(I), nl,write(' from: '),write(Left),write(' to: '),write(Right), nl,write(' string: '),write_out(Left,Right), nl,write(' rule: '),write(ERuleName), nl,write(' # of dtrs: '),write(NED),nl, nl,write('is subsumed by an incoming edge.'), nl,query_retract(Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName). query_retract(Left,I,_,_,_,_,_,_,_,_,_,_,_,_) :- go(_), retract(edge(I,Left,_,_,_,_,_,_)), retract(to_rebuild(I)), !,fail. query_retract(Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName) :- nl,write('Action(retract,continue,break,dtr-#,incoming,abort)? '), nl,read(Response), query_retract_act(Response,Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName). query_retract_act(retract,Left,I,_,_,_,_,_,_,_,_,_,_,_,_) :- retract(edge(I,Left,_,_,_,_,_,_)), retract(to_rebuild(I)), !,fail. query_retract_act(remain,_,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !,fail. query_retract_act(continue,_,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !. query_retract_act(break,Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName) :- !,break, print_edge_retract(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName). query_retract_act(dtr-D,Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName) :- nth_index(EDtrs,D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule), !,length(DDtrs,DND), print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND), print_edge_retract(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName). query_retract_act(incoming,Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName) :- !,length(Dtrs,ND), (print_incoming_edge(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) -> true ; print_edge_retract(I,Left,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName)). query_retract_act(abort,_,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !,abort. query_retract_act(_,Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName) :- query_retract(Left,I,Right,ETag,ESVs,EIqs,EDtrs,ERuleName,NED, Tag,SVs,Iqs,Dtrs,RuleName). print_incoming_edge(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nl,pp_fs(Tag-SVs,Iqs), nl,write('Incoming Edge: '), nl,write(' from: '),write(Left),write(' to: '),write(Right), nl,write(' string: '),write_out(Left,Right), nl,write(' rule: '),write(RuleName), nl,write(' # of dtrs: '),write(ND), query_incoming_edge(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_incoming_edge(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nl,write('Action(noadd,dtr-#,existing,abort)?' ), nl,read(Response), query_incoming_act(Response,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_incoming_act(noadd,_,_,_,_,_,_,_,_) :- !. query_incoming_act(existing,_,_,_,_,_,_,_,_) :- !,fail. query_incoming_act(abort,_,_,_,_,_,_,_,_) :- !,abort. query_incoming_act(dtr-D,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule), !,length(DDtrs,DND), print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND), print_incoming_edge(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_incoming_act(_,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- query_incoming_edge(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName,ND). % ============================================================================== % Interpreter % ============================================================================== edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) :- no_interpreter, !,gennum(N), asserta(to_rebuild(N)), asserta(edge(N,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName)). edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) :- !,nl, length(Dtrs,ND), (print_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) -> gennum(N), asserta(to_rebuild(N)), asserta(edge(N,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName))). print_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) :- nl,pp_fs(TagOut-SVsOut,IqsOut), nl,write('Edge created for category above: '), nl,write(' from: '),write(Left),write(' to: '),write(Right), nl,write(' string: '),write_out(Left,Right), nl,write(' rule: '),write(RuleName), nl,write(' # of dtrs: '),write(ND), nl,query_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). query_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) :- go(Left), % right-to-left parser triggers on left !,retractall(go(_)), query_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). query_edge(_,_,_,_,_,_,_,_) :- go(_), !. query_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) :- nl,write('Action(add,noadd,go(-#),break,dtr-#,abort)? '), nl,read(Response), query_edge_act(Response,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). query_edge_act(add,_,_,_,_,_,_,_,_) :- !. query_edge_act(noadd,_,_,_,_,_,_,_,_) :- !,fail. query_edge_act(go,_,_,_,_,_,_,_,_) :- !,asserta(go(go)). query_edge_act(go-G,_,_,_,_,_,_,_,_) :- !,asserta(go(G)). query_edge_act(break,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) :- !,break, print_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). query_edge_act(dtr-D,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND):- nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule), !,length(DDtrs,DND), print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND), print_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). query_edge_act(abort,_,_,_,_,_,_,_,_) :- !,abort. query_edge_act(_,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) :- query_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND) :- nl,pp_fs(DTag-DSVs,DIqs), nl,write('Daughter number '), write(D), nl,write(' from: '),write(DLeft),write(' to: '),write(DRight), nl,write(' string: '),write_out(DLeft,DRight), nl,write(' rule: '),write(DRule), nl,write(' # of dtrs: '),write(DND), query_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND). query_dtr_edge(D,I,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND) :- nl,write('Action(retract,dtr-#,parent,abort)?' ), nl,read(Response), query_dtr_act(Response,D,I,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND). query_dtr_act(parent,_,_,_,_,_,_,_,_,_,_) :- !. query_dtr_act(retract,_,I,DLeft,_,_,_,_,_,_,_) :- retract(edge(I,DLeft,_,_,_,_,_,_)), % will fail on empty cats !. query_dtr_act(abort,_,_,_,_,_,_,_,_,_,_) :- !,abort. query_dtr_act(dtr-DD,D,I,Left,Right,Tag,SVs,Iqs,Dtrs,Rule,ND) :- nth_index(Dtrs,DD,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule), !,length(DDtrs,DND), print_dtr_edge(DD,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule,DND), print_dtr_edge(D,I,Left,Right,Tag,SVs,Iqs,Dtrs,Rule,ND). query_dtr_act(_,D,I,Left,Right,Tag,SVs,Iqs,Dtrs,Rule,ND) :- query_dtr_edge(D,I,Left,Right,Tag,SVs,Iqs,Dtrs,Rule,ND). nth_index([I|Is],N,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule) :- N =:= 1 -> DI = I, (I = empty(E,DLeft) -> empty_cat(E,DLeft,DTag,DSVs,DIqs,DDtrs,DRule), DLeft = DRight ; (clause(edge(I,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule),true) -> true ; error_msg((nl,write('edge has been retracted'))) ) ) ; NMinus1 is N-1, nth_index(Is,NMinus1,DI,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule). % ============================================================================== % Functional Description Resolution/Compilation % ============================================================================== % fsolve(Fun:,Ref:,SVs:,IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % Solve function constraint, Fun, along with its argument descriptions. % ------------------------------------------------------------------------------ fsolve(_,_,_,_,_) if_b [fail] :- \+ current_predicate(+++>,+++>(_,_)). fsolve(Fun,Tag,SVs,IqsIn,IqsOut) if_b Goals :- current_predicate(+++>,+++>(_,_)), empty_assoc(VarsIn), (FHead +++> FResult), FHead =.. [Rel|ArgDescs], compile_descs(ArgDescs,Args,IqsIn,IqsMid,GoalsMid, [check_inequal(IqsMid,IqsMid2)|GoalsMid2],true,VarsIn,VarsMid, FSPal,[],FSsMid), Fun =.. [Rel|Args], compile_desc(FResult,Tag,SVs,IqsMid2,IqsOut,GoalsMid2,[],true,VarsMid,_,FSPal, FSsMid,FSsOut), build_fs_palette(FSsOut,FSPal,Goals,GoalsMid,[]). % ============================================================================== % Definite Clause Resolution/Compilation % ============================================================================== % ------------------------------------------------------------------------------ % compile_body(GoalDesc,IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut, % FSPal,FSsIn,FSsOut) % ------------------------------------------------------------------------------ % compiles arbitrary Goal. % PGoals is instantiated to list of Prolog goals required to add % arguments relations in Goal and then call the procedure to solve them. % IqsIn and IqsOut are uninstantiated at compile time. % ------------------------------------------------------------------------------ compile_body(((GD1,GD2),GD3),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut):- !, compile_body((GD1,(GD2,GD3)),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut). compile_body(((IfD -> ThenD ; ElseD),PGD),IqsIn,IqsOut, [(IfG -> ThenG ; ElseG)|PGoalsMid],PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut) :- !,compile_body(IfD,IqsIn,IqsMid,IfGoals,[],CBSafe,VarsIn,VarsIf,FSPal,FSsIn, FSsIf), compile_body(ThenD,IqsMid,IqsMid2,ThenGoals,[],false,VarsIf,VarsThen,FSPal, FSsIf,FSsThen), compile_body(ElseD,IqsIn,IqsMid2,ElseGoals,[],false,VarsIn,VarsElse,FSPal, FSsIn,FSsElse), goal_list_to_seq(IfGoals,IfG), goal_list_to_seq(ThenGoals,ThenG), goal_list_to_seq(ElseGoals,ElseG), vars_merge(VarsThen,VarsElse,VarsMid), fss_merge(FSsThen,FSsElse,FSsMid), compile_body(PGD,IqsMid2,IqsOut,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut, FSPal,FSsMid,FSsOut). compile_body(((GD1;GD2),GD3),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut):- !, compile_body(((GD1,GD3);(GD2,GD3)),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe, VarsIn,VarsOut,FSPal,FSsIn,FSsOut). compile_body((\+ GD1, GD2),IqsIn,IqsOut,[(\+ PGoal)|PGoalsMid],PGoalsRest, CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut):- !, compile_body(GD1,IqsIn,_,PGoalsList,[],CBSafe,VarsIn,_,FSPal,FSsIn,_), goal_list_to_seq(PGoalsList,PGoal), compile_body(GD2,IqsIn,IqsOut,PGoalsMid,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal, FSsIn,FSsOut). compile_body((Desc1 =@ Desc2,GD),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut):- !, compile_desc(Desc1,Tag1,bot,IqsIn,IqsMid,PGoals,PGoalsMid,CBSafe, VarsIn,VarsMid,FSPal,FSsIn,FSsMid), compile_desc(Desc2,Tag2,bot,IqsMid,IqsMid2,PGoalsMid, [deref(Tag1,bot,DTag1,DSVs1), deref(Tag2,bot,DTag2,DSVs2), ext_act(fs(DTag1,DSVs1,fs(DTag2,DSVs2,fsdone)),edone,done, IqsMid2), check_inequal(IqsMid2,IqsMid3), deref(DTag1,DSVs1,Tag1Out,_), deref(DTag2,DSVs2,Tag2Out,_), (Tag1Out == Tag2Out)|PGoalsMid2], CBSafe,VarsMid,VarsMid2,FSPal,FSsMid,FSsMid2), compile_body(GD,IqsMid3,IqsOut,PGoalsMid2,PGoalsRest,CBSafe,VarsMid2, VarsOut,FSPal,FSsMid2,FSsOut). compile_body((true,GD),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal, FSsIn,FSsOut):- !, compile_body(GD,IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal, FSsIn,FSsOut). compile_body((fail,_),Iqs,Iqs,[fail|PGoalsRest],PGoalsRest,_,Vars,Vars,_,FSs,FSs):- !. compile_body((!,PGD),IqsIn,IqsOut,[!|PGoalsMid],PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut):- !, compile_body(PGD,IqsIn,IqsOut,PGoalsMid,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut). compile_body(((IfD -> ThenD),PGD),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe, VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !,compile_body(((IfD -> ThenD ; fail),PGD),IqsIn,IqsOut,PGoals,PGoalsRest, CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut). compile_body((prolog(Goal),GD),IqsIn,IqsOut,[Goal|PGoalsMid],PGoalsRest,CBSafe, VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, term_variables(Goal,HookVarsList), hook_vars_merge(HookVarsList,VarsIn,VarsMid), compile_body(GD,IqsIn,IqsOut,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal, FSsIn,FSsOut). compile_body((AGD,GD2),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal, FSsIn,FSsOut):- !, AGD =.. [Rel|ArgDescs], compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,PGoals,[AGoal|PGoalsMid], CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid), append(Args,[IqsMid,IqsMid2],CompiledArgs), cat_atoms('fs_',Rel,CompiledRel), AGoal =.. [CompiledRel|CompiledArgs], compile_body(GD2,IqsMid2,IqsOut,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut, FSPal,FSsMid,FSsOut). compile_body((IfD -> ThenD ; ElseD),IqsIn,IqsOut, [(IfG -> ThenG ; ElseG)|PGoalsRest],PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut) :- !,compile_body(IfD,IqsIn,IqsMid,IfGoals,[],CBSafe,VarsIn,VarsIf,FSPal,FSsIn, FSsIf), compile_body(ThenD,IqsMid,IqsOut,ThenGoals,[],false,VarsIf,VarsThen,FSPal, FSsIf,FSsThen), compile_body(ElseD,IqsIn,IqsOut,ElseGoals,[],false,VarsIn,VarsElse,FSPal, FSsIn,FSsElse), goal_list_to_seq(IfGoals,IfG), goal_list_to_seq(ThenGoals,ThenG), goal_list_to_seq(ElseGoals,ElseG), vars_merge(VarsThen,VarsElse,VarsOut), fss_merge(FSsThen,FSsElse,FSsOut). compile_body((GD1;GD2),IqsIn,IqsOut,[(PGoal1;PGoal2)|PGoalsRest],PGoalsRest,_, VarsIn,VarsOut,FSPal,FSsIn,FSsOut):- !, compile_body(GD1,IqsIn,IqsOut,PGoals1,[],false,VarsIn,VarsDisj1,FSPal, FSsIn,FSsDisj1), compile_body(GD2,IqsIn,IqsOut,PGoals2,[],false,VarsIn,VarsDisj2,FSPal,FSsIn, FSsDisj2), goal_list_to_seq(PGoals1,PGoal1), goal_list_to_seq(PGoals2,PGoal2), vars_merge(VarsDisj1,VarsDisj2,VarsOut), fss_merge(FSsDisj1,FSsDisj2,FSsOut). compile_body((\+ GD),Iqs,Iqs,[(\+ PGoal)|PGoalsRest],PGoalsRest,CBSafe, VarsIn,VarsIn,FSPal,FSs,FSs) :- % vars will be unbound, so dont thread !, compile_body(GD,Iqs,_,PGoalsList,[],CBSafe,VarsIn,_,FSPal,FSs,_), goal_list_to_seq(PGoalsList,PGoal). compile_body((Desc1 =@ Desc2),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut):- !, compile_desc(Desc1,Tag1,bot,IqsIn,IqsMid,PGoals,PGoalsMid,CBSafe, VarsIn,VarsMid,FSPal,FSsIn,FSsMid), compile_desc(Desc2,Tag2,bot,IqsMid,IqsMid2,PGoalsMid, [deref(Tag1,bot,DTag1,DSVs1), deref(Tag2,bot,DTag2,DSVs2), ext_act(fs(DTag1,DSVs1,fs(DTag2,DSVs2,fsdone)),edone,done, IqsMid2), check_inequal(IqsMid2,IqsOut), deref(DTag1,DSVs1,Tag1Out,_), deref(DTag2,DSVs2,Tag2Out,_), (Tag1Out == Tag2Out)|PGoalsRest], CBSafe,VarsMid,VarsOut,FSPal,FSsMid,FSsOut). compile_body(!,Iqs,Iqs,[!|PGoalsRest],PGoalsRest,_,Vars,Vars,_,FSs,FSs):- !. compile_body((IfD -> ThenD),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut) :- !,compile_body((IfD -> ThenD ; fail),IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe, VarsIn,VarsOut,FSPal,FSsIn,FSsOut). compile_body(true,Iqs,Iqs,PGoals,PGoals,_,Vars,Vars,_,FSs,FSs):- !. compile_body(fail,Iqs,Iqs,[fail|PGoalsRest],PGoalsRest,_,Vars,Vars,_,FSs,FSs):- !. compile_body(prolog(Goal),Iqs,Iqs,[Goal|PGoalsRest],PGoalsRest,_,VarsIn, VarsOut,_,FSs,FSs) :- !, term_variables(Goal,HookVarsList), hook_vars_merge(HookVarsList,VarsIn,VarsOut). compile_body(AtGD,IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal, FSsIn,FSsOut):- AtGD =.. [Rel|ArgDescs], compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,PGoals,[AtGoal|PGoalsRest], CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut), append(Args,[IqsMid,IqsOut],CompiledArgs), cat_atoms('fs_',Rel,CompiledRel), AtGoal =.. [CompiledRel|CompiledArgs]. % ------------------------------------------------------------------------------ % goal_list_to_seq(Goals:s, GoalsSeq:) % ------------------------------------------------------------------------------ % % ------------------------------------------------------------------------------ goal_list_to_seq([],true). goal_list_to_seq([G|Gs],GsSeq) :- ((G = true) -> goal_list_to_seq(Gs,GsSeq) ; goal_list_to_seq_act(Gs,G,GsSeq)). goal_list_to_seq_act([],G,G). goal_list_to_seq_act([G2|Gs],G,(G,GsSeq)):- goal_list_to_seq_act(Gs,G2,GsSeq). % ------------------------------------------------------------------------------ % compile_descs(Descs,Vs,IqsIn,IqsOut,Goals,GoalsRest,CBSafe,VarsIn,VarsOut, % FSPal,FSsIn,FSsOut) % ------------------------------------------------------------------------------ % compiles descriptions Descs to constraint Vs into diff list Goals-GoalsRest % ------------------------------------------------------------------------------ compile_descs([],[],Iqs,Iqs,Goals,Goals,_,Vars,Vars,_,FSs,FSs). compile_descs([ArgDesc|ArgDescs],[Arg|Args],IqsIn,IqsOut, SubGoals,SubGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut):- compile_desc(ArgDesc,Arg,IqsIn,IqsMid,SubGoals,SubGoalsMid,CBSafe,VarsIn, VarsMid,FSPal,FSsIn,FSsMid), compile_descs(ArgDescs,Args,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest,CBSafe, VarsMid,VarsOut,FSPal,FSsMid,FSsOut). % ------------------------------------------------------------------------------ % compile_descs_fresh(Descs,Vs,IqsIn,IqsOut,Goals,GoalsRest,CBSafe,VarsIn, % VarsOut,FSPal,FSsIn,FSsOut) % ------------------------------------------------------------------------------ % similar to compile_descs, except that Vs are instantiated to Ref-bot % before compiling Descs % ------------------------------------------------------------------------------ compile_descs_fresh([],[],Iqs,Iqs,Goals,Goals,_,Vars,Vars,_,FSs,FSs). compile_descs_fresh([ArgDesc|ArgDescs],[Arg|Args],IqsIn,IqsOut, SubGoals,SubGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn, FSsOut):- ( var(ArgDesc) -> ( get_assoc(ArgDesc,VarsIn,Seen,VarsMid2,seen) -> ( Seen == seen -> Arg = ArgDesc, SubGoals = SubGoalsMid2 ; % Seen == tricky, SubGoals = [(var(ArgDesc) -> Arg = Ref-bot, ArgDesc = Arg ; Arg = ArgDesc)|SubGoalsMid2] ) ; Arg = ArgDesc, SubGoals = [ArgDesc = Ref-bot|SubGoalsMid2], put_assoc(ArgDesc,VarsIn,seen,VarsMid2) ), IqsMid = IqsIn, FSsMid2 = FSsIn ; ArgDesc = Tag-SVs -> deref(Tag,SVs,DTag,DSVs), find_fs(FSsIn,DTag,DSVs,SubGoals,SubGoalsMid2,Arg, FSPal,FSsMid2), IqsMid = IqsIn, VarsMid2 = VarsIn ; root_struct(ArgDesc,RStruct,DRest) -> ( var(RStruct) -> ( get_assoc(RStruct,VarsIn,Seen,VarsMid,seen) -> ( Seen == seen -> Arg = RStruct, SubGoals = SubGoalsMid ; % Seen == tricky, SubGoals = [(var(RStruct) -> Arg = Ref-bot, RStruct = Arg ; Arg = RStruct)|SubGoalsMid] ) ; Arg = RStruct, SubGoals = [RStruct = Ref-bot|SubGoalsMid], put_assoc(RStruct,VarsIn,seen,VarsMid) ), FSsMid = FSsIn ; RStruct = Tag-SVs, deref(Tag,SVs,DTag,DSVs), find_fs(FSsIn,DTag,DSVs,SubGoals,SubGoalsMid,Arg,FSPal,FSsMid), VarsMid = VarsIn ), compile_desc(DRest,Arg,IqsIn,IqsMid,SubGoalsMid,SubGoalsMid2,CBSafe, VarsMid,VarsMid2,FSPal,FSsMid,FSsMid2) ; % some other description - need a new FS Arg = Ref-bot, compile_desc(ArgDesc,Ref,bot,IqsIn,IqsMid,SubGoals,SubGoalsMid2,CBSafe, VarsIn,VarsMid2,FSPal,FSsIn,FSsMid2) ), compile_descs_fresh(ArgDescs,Args,IqsMid,IqsOut,SubGoalsMid2,SubGoalsRest, CBSafe,VarsMid2,VarsOut,FSPal,FSsMid2,FSsOut). % ------------------------------------------------------------------------------ % root_struct(+Desc:,-RootStruct:,-DRest:) % ------------------------------------------------------------------------------ % Find a variable that can be used to refer the feature structure described % by Desc. If there is one, then we can use that variable as the argument % of the predicate being assembled in compile_descs_fresh/12. % ------------------------------------------------------------------------------ root_struct((D1,D2),RStruct,DRest) :- is_root(D1),is_root(D2) -> ( RStruct = D1, DRest = D2 ; RStruct = D2, DRest = D1) ; is_root(D1) -> ( RStruct = D1, DRest = D2 ; root_struct(D2,RStruct,D2Rest), DRest = (D1,D2Rest)) ; is_root(D2) -> ( RStruct = D2, DRest = D1 ; root_struct(D1,RStruct,D1Rest), DRest = (D1Rest,D2)) ; ( root_struct(D1,RStruct,D1Rest), DRest = (D1Rest,D2) ; root_struct(D2,RStruct,D2Rest), DRest = (D1,D2Rest)). root_struct((D1;D2),RStruct,DRest) :- (is_root(D1),is_root(D2)) -> D1 == D2, RStruct = D1, DRest = bot ; is_root(D1) -> root_struct(D2,RStruct,D2Rest), D1 == RStruct, DRest = D2Rest ; is_root(D2) -> root_struct(D1,RStruct,D1Rest), D2 == RStruct, DRest = D1Rest ; root_struct(D1,RStruct,D1Rest), root_struct(D2,RStruct2,D2Rest), RStruct == RStruct2, DRest = (D1Rest;D2Rest). is_root(D) :- var(D) -> true ; functor(D,-,2). % ============================================================================== % Phrase Structure Rule Compiler % ============================================================================== :-dynamic curr_lex_rule_depth/1. curr_lex_rule_depth(2). % ------------------------------------------------------------------------------ % lex_rule_depth(N:) % ------------------------------------------------------------------------------ % asserts curr_lex_rule_depth/1 to N -- controls lexical rule depth % ------------------------------------------------------------------------------ lex_rule_depth(N):- retractall(curr_lex_rule_depth(_)), assert(curr_lex_rule_depth(N)). % ------------------------------------------------------------------------------ % lex(Word:, Tag:, SVs:, IqsOut:s) mh(0) % ------------------------------------------------------------------------------ % Word has category Tag-SVs % ------------------------------------------------------------------------------ (lex(Word,Tag,SVs,IqsOut) if_h) :- (WordStart ---> Desc), lex_act(Word,Tag,SVs,IqsOut,WordStart,Desc). lex_act(Word,Tag,SVs,IqsOut,WordStart,Desc) :- if(add_to(Desc,TagStart,bot,[],IqsMid), (curr_lex_rule_depth(Max), lex_close(0,Max,WordStart,TagStart,bot,Word,TagMid,SVsMid, IqsMid,IqsMid2), fully_deref_prune(TagMid,SVsMid,Tag,SVs,IqsMid2,IqsOut)), error_msg((nl,write('lex: unsatisfiable lexical entry for '), write(WordStart)))). % ------------------------------------------------------------------------------ % lex_close(WordIn:,TagIn:, SVsIn:, % WordOut:,TagOut:, SVsOut:, IqsIn:s, % IqsOut:s) % ------------------------------------------------------------------------------ % If WordIn has category TagIn-SVsIn, then WordOut has category % TagOut-SVsOut; computed by closing under lexical rules % ------------------------------------------------------------------------------ lex_close(_,_,Word,Tag,SVs,Word,Tag,SVs,Iqs,Iqs). lex_close(N,Max,WordIn,TagIn,SVsIn,WordOut,TagOut,SVsOut,IqsIn,IqsOut):- current_predicate(lex_rule,lex_rule(_,_,_,_,_,_,_,_)), N < Max, lex_rule(WordIn,TagIn,SVsIn,WordMid,TagMid,SVsMid,IqsIn,IqsMid), NPlus1 is N + 1, lex_close(NPlus1,Max,WordMid,TagMid,SVsMid,WordOut,TagOut,SVsOut,IqsMid, IqsOut). % ------------------------------------------------------------------------------ % empty_cat(N:, Node:, Tag:, SVs:, Iqs:s, % Dtrs:, RuleName:) mh(0) % ------------------------------------------------------------------------------ empty_cat(_,_,_,_,_,_,_) if_h [fail] :- \+ current_predicate(empty,empty(_)), findall(rule(Dtrs,_,Mother,RuleName,PrevDtrs,PrevDtrs,[]), (RuleName rule Mother ===> Dtrs), Rules), assert(alec_closed_rules(Rules)), !. empty_cat(N,Node,TagOut,SVsOut,IqsOut,Dtrs,RuleName) if_h []:- findall(empty(M,_,FTag,FSVs,FIqs,[],empty), (empty(Desc), add_to(Desc,Tag,bot,[],IqsIn), gen_emptynum(M), % curr_lex_rule_depth(Max), % should we be closing empty cats % lex_close(0,Max,e,Tag,bot,_,TagMid,SVsMid,IqsIn,IqsMid), % under lex. rules? fully_deref_prune(Tag,bot,FTag,FSVs,IqsIn,FIqs)), BasicEmptys), (no_subsumption -> MinimalEmptys = BasicEmptys ; minimise_emptys(BasicEmptys,[],MinimalEmptys) ), close_emptys(MinimalEmptys,ClosedEmptys,ClosedRules), (no_subsumption -> MinimalClosedEmptys = ClosedEmptys ; minimise_emptys(ClosedEmptys,[],MinimalClosedEmptys) ), ( member(empty(N,Node,TagOut,SVsOut,IqsOut,Dtrs,RuleName),MinimalClosedEmptys) ; assert(alec_closed_rules(ClosedRules)), fail ). % ------------------------------------------------------------------------------ % minimise_emptys(+Emptys:s,+Accum:s,?MinimalEmptys:s) % ------------------------------------------------------------------------------ % MinimalEmptys is the minimal list resulting from combining Emptys and % Accum. A list of empty(N,Node,Tag,SVs,Iqs,Dtrs,RuleName) terms is minimal % iff no term on the list subsumes any other term. % ------------------------------------------------------------------------------ minimise_emptys([],MinimalEmptys,MinimalEmptys). minimise_emptys([BE|BasicEmptys],Accum,MinimalEmptys) :- minimise_emptys_act(Accum,BE,BasicEmptys,NewAccum,NewAccum,MinimalEmptys). minimise_emptys_act([],B,BsRest,NewAccum,[B],MEs) :- minimise_emptys(BsRest,NewAccum,MEs). minimise_emptys_act([A|AsRest],B,BsRest,NewAccum,NARest,MEs) :- A = empty(_,_,ATag,ASVs,AIqs,_,_), B = empty(_,_,BTag,BSVs,BIqs,_,_), empty_assoc(H), empty_assoc(K), subsume(s(ATag,ASVs,BTag,BSVs,sdone),AIqs,BIqs,<,>,LReln,RReln,H,K), me_subsume_act(LReln,RReln,A,B,AsRest,BsRest,NewAccum,NARest,MEs). me_subsume_act(<,_,A,_,AsRest,BsRest,NewAccum,[A|AsRest],MEs) :- nl,write('EFD-closure discarded a subsumed empty category'), minimise_emptys(BsRest,NewAccum,MEs). me_subsume_act(#,>,_,B,AsRest,BsRest,NewAccum,NARest,MEs) :- nl,write('EFD-closure discarded a subsumed empty category'), minimise_emptys_act(AsRest,B,BsRest,NewAccum,NARest,MEs). me_subsume_act(#,#,A,B,AsRest,BsRest,NewAccum,[A|NARest],MEs) :- minimise_emptys_act(AsRest,B,BsRest,NewAccum,NARest,MEs). % ------------------------------------------------------------------------------ % close_emptys(+Emptys:s,-ClosedEmptys:s,-ClosedRules:s) % ------------------------------------------------------------------------------ % Close Emptys under the rules in the database to obtain ClosedEmptys. In % the process, we also close those rules closed under empty category prefixes, % to obtain ClosedRules. % ------------------------------------------------------------------------------ close_emptys(Emptys,ClosedEmptys,ClosedRules) :- findall(rule(Dtrs,_,Mother,RuleName,PrevDtrs,PrevDtrs,[]), (RuleName rule Mother ===> Dtrs), Rules), efd_iterate(Emptys,Rules,[],[],[],ClosedEmptys,ClosedRules). % ------------------------------------------------------------------------------ % efd_iterate(+Es:s,+Rs:s,+NRs:s,+EAs:s,+RAs:s, % -ClosedEmptys:s,-ClosedRules:s) % ------------------------------------------------------------------------------ % The Empty-First-Daughter closure algorithm closes a given collection of % base empty categories and base extended PS rules breadth-first under % prefixes of empty category daughters. This has the following benefits: % 1) it corrects a long-standing problem in ALE with combining empty % categories. Because any permutation of empty categories can, in % principle, be combined to form a new empty category, ALE cannot perform % depth-first closure under a leftmost empty category as it can with % normal edges; % 2) it corrects a problem that non-ISO-compatible Prologs, including SICStus % Prolog, have with asserted predicates that results in empty category % leftmost daughters not being able to combine with their own outputs; % 3) it allows parsers to establish a precondition that rules only need to % be closed with non-empty leftmost daughters at run-time. As a result, % when a new mother category is created and closed under rules as the % leftmost daughter, it cannot combine with other edges created with the % same left node. This allows ALE, at each step in its right-to-left pass % throught the string, to copy all of the edges in the internal database % back onto the heap before they can be used again, and thus reduces % edge copying to a constant 2/edge for non-empty edges (edges with % different left and right nodes). Keeping a copy of the chart on the % heap also allows for more sophisticated indexing strategies that would % otherwise be overwhelmed by the cost of copying the edge before matching. % % Let Es,Rs,NEs,NRs,EAs, and RAs be lists. Initialise Es to the base empty % categories, and Rs to the base rules, and the others to [] % % loop: % while Es =/= [] do % for each E in Es do % for each R in Rs do % match E against the leftmost unmatched category description of R % if it does not match, continue % if the leftmost category was the rightmost (unary rule), then % add the new empty category to NEs % otherwise, add the new rule (with leftmost category marked as matched) % to NRs % od % od % EAs := Es + EAs % Rs := Rs + RAs, RAs := [] % Es := NEs, NEs := [] % od % if NRs = [], % then end: EAs are the closed empty cats, Rs are the closed rules % else % Es := EAs, EAs := [] % RAs := Rs, Rs := NRs, NRs := [] % go to loop % % This algorithm terminates for exactly those grammars in which bottom-up % parsing over empty categories terminates, i.e., it is no worse than pure % bottom-up parsing. % ------------------------------------------------------------------------------ efd_iterate([],Rules,NewRules,EmptyAccum,_RuleAccum, % RuleAccum is [] ClosedEmptys,ClosedRules) :- !, (NewRules == [] -> ClosedEmptys = EmptyAccum, ClosedRules = Rules ; efd_iterate(EmptyAccum,NewRules,[],[],Rules,ClosedEmptys,ClosedRules) ). efd_iterate(Emptys,Rules,NewRules,EmptyAccum,RuleAccum, ClosedEmptys,ClosedRules) :- apply_once(Emptys,Rules,NewEmptysandRules), split_emptys_rules(NewEmptysandRules,NewRules,NewRules1,NewEmptys), append(Emptys,EmptyAccum,EmptyAccum1), append(Rules,RuleAccum,Rules1), efd_iterate(NewEmptys,Rules1,NewRules1,EmptyAccum1,[], ClosedEmptys,ClosedRules). % ------------------------------------------------------------------------------ % apply_once(+Es:s,+Rs:s,-NEsorRs:s) % ------------------------------------------------------------------------------ % the two for-loops of the EFD-closure algorithm above. % ------------------------------------------------------------------------------ apply_once(Emptys,Rules,NewEmptysandRules) :- findall(EmptyorRule, (member(Empty,Emptys), member(rule(Dtrs,Node,Mother,RuleName,PrevDtrs,PrevDtrsMid,Iqs), Rules), match_cat_to_next_cat(Dtrs,Mother,RuleName,PrevDtrs,PrevDtrsMid,Iqs, Empty,EmptyorRule,Node)), NewEmptysandRules). % ------------------------------------------------------------------------------ % split_emptys_rules(+NEsorRs:s,+NRsOld:s, % -NRsNew:s,-NEsNew:s) % ------------------------------------------------------------------------------ % classifies the results of apply_once/3 as empty cats or rules, and adds them % to NEs or NRs, respectively. % ------------------------------------------------------------------------------ split_emptys_rules([],NewRulesRest,NewRulesRest,[]). split_emptys_rules([Item|Items],NewRulesRest,NewRules,NewEmptys) :- functor(Item,Functor,_), ((Functor == rule) -> NewRules = [Item|NewRulesMid], % nl,write('EFD-closure generated a partial rule'), split_emptys_rules(Items,NewRulesRest,NewRulesMid,NewEmptys) ; % Functor == empty, NewEmptys = [Item|NewEmptysMid], % nl,write('EFD-closure generated an empty category'), split_emptys_rules(Items,NewRulesRest,NewRules,NewEmptysMid) ). % ------------------------------------------------------------------------------ % match_cat_to_next_cat(+Dtrs:s,+Mother:,+RuleName:, % +PrevDtrs:s,-PrevDtrsRest:s, % +RuleIqs:s,+Empty:, % -EmptyorRule:,-Node:) % ------------------------------------------------------------------------------ % interpretive matching of empty category to leftmost category description % plus all procedural attachments up to the next category description. % ------------------------------------------------------------------------------ match_cat_to_next_cat((cat> Dtr,Rest),Mother,RuleName,PrevDtrs, [empty(N,Node)|PrevDtrsMid],RuleIqs, empty(N,Node,Tag,SVs,Iqs,_,_),EmptyorRule,Node) :- append(Iqs,RuleIqs,IqsIn), add_to(Dtr,Tag,SVs,IqsIn,IqsMid), check_inequal(IqsMid,IqsMid2), match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,IqsMid2, EmptyorRule,Node). match_cat_to_next_cat((cat> Dtr),Mother,RuleName,PrevDtrs,[empty(N,Node)], RuleIqs,empty(N,Node,Tag,SVs,Iqs,_,_), empty(NewN,Node,TagOut,SVsOut,IqsOut,PrevDtrs,RuleName), Node) :- append(Iqs,RuleIqs,IqsIn), add_to(Dtr,Tag,SVs,IqsIn,IqsMid), add_to(Mother,Tag2,bot,IqsMid,IqsMid2), fully_deref_prune(Tag2,bot,TagOut,SVsOut,IqsMid2,IqsOut), gen_emptynum(NewN). match_cat_to_next_cat((sem_head> Dtr,Rest),Mother,RuleName,PrevDtrs, [empty(N,Node)|PrevDtrsMid],RuleIqs, empty(N,Node,Tag,SVs,Iqs,_,_),EmptyorRule,Node) :- append(Iqs,RuleIqs,IqsIn), add_to(Dtr,Tag,SVs,IqsIn,IqsMid), check_inequal(IqsMid,IqsMid2), match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,IqsMid2, EmptyorRule,Node). match_cat_to_next_cat((sem_head> Dtr),Mother,RuleName,PrevDtrs,[empty(N,Node)], RuleIqs,empty(N,Node,Tag,SVs,Iqs,_,_), empty(NewN,Node,TagOut,SVsOut,IqsOut,PrevDtrs,RuleName), Node) :- append(Iqs,RuleIqs,IqsIn), add_to(Dtr,Tag,SVs,IqsIn,IqsMid), add_to(Mother,Tag2,bot,IqsMid,IqsMid2), fully_deref_prune(Tag2,bot,TagOut,SVsOut,IqsMid2,IqsOut), gen_emptynum(NewN). match_cat_to_next_cat((cats> Dtrs,Rest),Mother,RuleName,PrevDtrs,PrevDtrsMid, RuleIqs,Empty,EmptyorRule,Node) :- add_to(Dtrs,DtrsTag,bot,RuleIqs,IqsIn), deref(DtrsTag,bot,_DTag,DSVs), functor(DSVs,DtrsType,_), (sub_type(ne_list,DtrsType) -> arg(1,DSVs,HdFS), Empty = empty(N,Node,Tag,SVs,Iqs,_,_), append(Iqs,IqsIn,IqsMid), ud(HdFS,Tag,SVs,IqsMid,IqsMid2), check_inequal(IqsMid2,IqsMid3), arg(2,DSVs,TlFS), deref(TlFS,TlTag,TlSVs), functor(TlSVs,TlType,_), (sub_type(ne_list,TlType) -> PrevDtrsMid = [empty(N,Node)|PrevDtrsRest], EmptyorRule = rule((remainder(TlTag,TlSVs),Rest),Node,Mother,RuleName, PrevDtrs,PrevDtr