% ============================================================================== % ALE -- Attribute Logic Engine % ============================================================================== % Version 3.1.1 --- November, 1998 % Developed under: SICStus Prolog, Version 3.0 #6 % Ported to: SWI Prolog, Version 2.9.10 % Authors: % Bob Carpenter % --------------------------- % Bell Laboratories % Lucent Technologies % 600 Mountain Ave., 2D-329 % Murray Hill, NJ 07974 % USA % carp@research.bell-labs.com % % Gerald Penn % -------------------------------- % Sonderforschungsbereich 340 % Universitaet Tuebingen % Kl. Wilhelmstr. 113 % 72074 Tuebingen % Germany % gpenn@sfs.nphil.uni-tuebingen.de % % SWI patch code :- style_check(-discontiguous). compile(X) :- style_check(-discontiguous), consult(X). % replaced consult/1 everwhere 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). % SWI equivalent is message_hook/3, but implementation (as of 2.9.10) 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). % end SWI patch code :- dynamic verbose_interpreter/0. :- dynamic quiet_interpreter/0. :- dynamic no_interpreter/0. :- dynamic no_subsumption/0. :- dynamic go/1. :- dynamic suppress_adderrs/0. :- dynamic parsing/0, generating/0. :- dynamic lexicon_consult/0. 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(quiet_interpreter), retractall(no_interpreter), asserta(verbose_interpreter), nl, write('interpreter is active'), nl. nointerp :- retractall(verbose_interpreter), retractall(quiet_interpreter), asserta(no_interpreter), nl, write('interpreter is inactive'), nl. subtest :- retractall(no_subsumption), nl, write('edge subsumption checking active'), nl. nosubtest :- asserta(no_subsumption), nl, write('edge subsumption checking inactive'), nl. secret_quiet :- retractall(verbose_interpreter), retractall(no_interpreter), asserta(quiet_interpreter). secret_verbose :- quiet_interpreter, !,retractall(quiet_interpreter), retractall(no_interpreter), asserta(verbose_interpreter). secret_verbose. clear :- retractall(edge(_,_,_,_,_,_,_,_)), retractall(parsing(_)), retractall(num(_)), % edge index retractall(go(_)), % interpreter go flag secret_verbose. 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(Type). (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 [!] :- Type cons Cons goal Goal, compile_desc(Cons,Tag,SVs,IqsIn,IqsMid,Goals,GoalsMid), compile_body(Goal,[],[],IqsMid,IqsOut,GoalsMid,Rest). ct(Type,Tag,SVs,Goals,Rest,IqsIn,IqsOut) if_b [!] :- Type cons Cons, \+ (Cons = (_ goal _)), compile_desc(Cons,Tag,SVs,IqsIn,IqsOut,Goals,Rest). 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). % ------------------------------------------------------------------------------ % 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). % ------------------------------------------------------------------------------ % 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 SubGoalsFinal:- ( (_LexRuleName lex_rule DescIn **> DescOut morphs Morphs), Cond = true ; (_LexRuleName lex_rule DescIn **> DescOut if Cond morphs Morphs) ), compile_desc(DescIn,TagIn,SVsIn,IqsIn,IqsMid,SubGoalsFinal,SubGoalsRest1), compile_body(Cond,[],[],IqsMid,IqsMid2,SubGoalsRest1,SubGoalsMid), compile_desc(DescOut,TagMid,bot,IqsMid2,IqsMid3,SubGoalsMid, [morph(Morphs,WordIn,WordOut), fully_deref_prune(TagMid,bot,TagOut,SVsOut,IqsMid3,IqsOut)]). % ------------------------------------------------------------------------------ % 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 % 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([Ref-SVs],_,done,Iqs). extensionalise(FS,Iqs) :- ext_act([FS],_,done,Iqs). ext_act([Ref-SVs|FSs],ExtQ,Ineqs,Iqs) :- traverseQ(ExtQ,ExtQ,Ref,SVs,FSs,Ineqs,Iqs). ext_act([],ExtQ,Ineqs,Iqs) :- ext_ineq(Ineqs,ExtQ,Iqs). ext_ineq(ineq(Ref1,SVs1,Ref2,SVs2,Ineqs),ExtQ,Iqs) :- ext_act([Ref1-SVs1,Ref2-SVs2],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(FSs,Iqs) :- ext_act(FSs,_,done,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(Rest,ExtQ,Ref,SVs,FSs,Ineqs,Iqs) :- var(Rest), !,Rest = ext(Ref,SVs,_), ((SVs = a_ _) -> ext_act(FSs,ExtQ,Ineqs,Iqs) ; (SVs =.. [_|Vs], append(Vs,FSs,NewFSs), ext_act(NewFSs,ExtQ,Ineqs,Iqs))). traverseQ(ext(ERef,_,_),ExtQ,Ref,_,FSs,Ineqs,Iqs) :- ERef == Ref, !,ext_act(FSs,ExtQ,Ineqs,Iqs). traverseQ(ext(ERef,ESVs,_),ExtQ,Ref,SVs,FSs,Ineqs,Iqs) :- iso(Ref-SVs,ERef-ESVs), !,ext_act(FSs,ExtQ,Ineqs,Iqs). traverseQ(ext(_,_,ERest),ExtQ,Ref,SVs,FSs,Ineqs,Iqs) :- traverseQ(ERest,ExtQ,Ref,SVs,FSs,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:, % IqsIn:,IqsOut:) % ------------------------------------------------------------------------------ % Run-time predicate compiled into rules. Matches a list of cats 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,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,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:,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,IqsIn, IqsOut) :- sub_type(ne_list,Sort), !,clause(edge(Right,N,MidRight,Tag,SVs,EdgeIqs,_,_),true), 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,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), build(WsRev,Length), clause(edge(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,Tag,SVs,IqsOut,Desc) :- clear, assert(parsing(Ws)), asserta(num(0)), reverse_count(Ws,[],WsRev,0,Length), build(WsRev,Length), clause(edge(0,_,Length,Tag,SVs,IqsIn,_,_),true), add_to(Desc,Tag,SVs,IqsIn,IqsMid), extensionalise(Tag,SVs,IqsMid), check_inequal(IqsMid,IqsOut). % ------------------------------------------------------------------------------ % build(Ws:s, Right:) % ------------------------------------------------------------------------------ % fills in charts inactive edges from beginning to Right using % Ws, representing words in chart in reverse order % ------------------------------------------------------------------------------ build([W|Ws],Right):- RightMinus1 is Right - 1, ( empty_cat(Tag,SVs,Iqs), add_edge(Right,Right,Tag,SVs,Iqs,[],empty) ; [no,lexical,entry,for,W] if_error (\+ lex(W,_,_,_) ), lex(W,Tag,SVs,Iqs), add_edge(RightMinus1,Right,Tag,SVs,Iqs,[],lexicon) ; build(Ws,RightMinus1) ). build([],_):- empty_cat(Tag,SVs,Iqs), add_edge(0,0,Tag,SVs,Iqs,[],empty). build([],_) :- quiet_interpreter, % if quiet mode was on, turn it off. !,secret_verbose. build([],_). % ------------------------------------------------------------------------------ % add_edge_deref(Left:, Right:, Tag:, SVs:, % Iqs:s,Dtrs:s,RuleName) 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):- fully_deref_prune(Tag,SVs,TagOut,SVsOut,IqsIn,IqsOut), (subsumed(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName) -> fail ; (edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N), apply_rule(TagOut,SVsOut,IqsOut,Left,Right,N))). add_edge(Left,Right,TagOut,SVsOut,IqsIn,Dtrs,RuleName):- check_inequal(IqsIn,IqsOut), % CAN PROBABLY REMOVE THIS (subsumed(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName) -> fail ; (edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N), apply_rule(TagOut,SVsOut,IqsOut,Left,Right,N))). apply_rule(TagOut,SVsOut,IqsOut,Left,Right,N) :- N >= 0, % make sure the proposed edge was asserted rule(TagOut,SVsOut,IqsOut,Left,Right,N). gennum(N) :- retract(num(N)), NewN is N+1, asserta(num(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). % 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(_,_,_,_,_,_,_) :- no_subsumption, !,fail. subsumed(Left,Right,Tag,SVs,Iqs,Dtrs,RuleName) :- clause(edge(Left,EI,Right,ETag,ESVs,EIqs,_,_),true), % this may have more than 1 soln! subsume([s(Tag,SVs,ETag,ESVs)],Iqs,EIqs,<,>,LReln,RReln,[],[]), 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,_) :- edge_retract(Left,EI,Tag,SVs,Iqs,Dtrs,RuleName). % candidate subsumes edge % subsumed_act(#,#,_,_,_,_,_,_,_,_) fails % subsume(Ss,Iqs1,Iqs2,LeftRelnIn,RightRelnIn,LeftRelnOut,RightRelnOut,H,K) % ------------------------------------------------------------------------------ % LeftRelnOut is bound to < if 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, LeftReln is bound to #. RightRelnOut is bound to > if % 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([],Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- subsume_iqs(Iqs,EIqs,LRelnIn,LRelnOut,H), subsume_iqs(EIqs,Iqs,RRelnIn,RRelnOut,K). subsume([s(Tag,SVs,ETag,ESVs)|Ss],Iqs,EIqs, LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- map_h_eq(H,Tag,HTag,_,HRes), map_h_eq(K,ETag,KTag,_,KRes), subsume_act(HRes,KRes,HTag,KTag,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K). subsume_act(?,?,_,_,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- !,subsume_type(<,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, % not # in 1st arg LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K). subsume_act(?,!,_,_,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, LRelnIn,_,LRelnOut,#,H,K) :- !,subsume_type(LRelnIn,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, LRelnIn,#,LRelnOut,#,H,K). subsume_act(!,?,_,_,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, _,RRelnIn,#,RRelnOut,H,K) :- !,subsume_type(RRelnIn,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, #,RRelnIn,#,RRelnOut,H,K). subsume_act(!,!,HTag,KTag,Tag,_,ETag,_,Ss,Iqs,EIqs, LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- % already visited, KTag == Tag, % so go on to the rest unless already incomparable !,subsume_act2(HTag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K). subsume_act(!,!,HTag,_,_,_,ETag,_,Ss,Iqs,EIqs, LRelnIn,_,LRelnOut,#,H,K) :- subsume_act2(HTag,ETag,Ss,Iqs,EIqs,LRelnIn,#,LRelnOut,#,H,K). subsume_act2(HTag,ETag,Ss,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- HTag == ETag, !,subsume_act3(LRelnIn,RRelnIn,Ss,Iqs,EIqs,LRelnOut,RRelnOut,H,K). subsume_act2(_,_,Ss,Iqs,EIqs,_,RRelnIn,#,RRelnOut,H,K) :- subsume_act3(#,RRelnIn,Ss,Iqs,EIqs,#,RRelnOut,H,K). subsume_act3(#,#,_,_,_,#,#,_,_) :- !. % incomparable subsume_act3(LRelnIn,RRelnIn,Ss,Iqs,EIqs,LRelnOut,RRelnOut,H,K) :- subsume(Ss,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K). % compare types if Reln isn't # yet subsume_type(#,_,_,_,_,_,_,_,_,_,#,#,_,_) :- !. subsume_type(_,Tag,SVs,ETag,ESVs,Ss,Iqs,EIqs, LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K) :- ((SVs = (a_ X)) -> (Sort = (a_ X),Vs=[]) ; SVs =.. [Sort|Vs]), ((ESVs = (a_ X)) -> (ESort = (a_ X),EVs=[]) ; ESVs =.. [ESort|EVs]), sub_type_reln(Sort,ESort,TReln), subsume_type_act(TReln,LRelnIn,RRelnIn,LRelnOut,RRelnOut,Tag,ETag,Sort,ESort, Vs,EVs,SVs,ESVs,Ss,Iqs,EIqs,H,K). % add common values to S-list subsume_type_act(=,#,RRelnIn,#,RRelnOut,Tag,ETag,_,_, Vs,EVs,SVs,_,Ss,Iqs,EIqs,H,K) :- !,subsume_type_act2(RRelnIn,RRelnOut,#,#,H, Tag,ETag,Vs,EVs,SVs,Ss,Iqs,EIqs,K). subsume_type_act(=,LRelnIn,RRelnIn,LRelnOut,RRelnOut,Tag,ETag,_,_, Vs,EVs,SVs,ESVs,Ss,Iqs,EIqs,H,K) :- !,subsume_type_act2(RRelnIn,RRelnOut,LRelnIn,LRelnOut,[h(Tag,ETag,ESVs)|H], Tag,ETag,Vs,EVs,SVs,Ss,Iqs,EIqs,K). subsume_type_act2(#,#,LRelnIn,LRelnOut,NewH,_,_,Vs,EVs,_,Ss,Iqs,EIqs,K) :- !,append_s(Vs,EVs,Ss,NewSs), subsume(NewSs,Iqs,EIqs,LRelnIn,#,LRelnOut,#,NewH,K). subsume_type_act2(RRelnIn,RRelnOut,LRelnIn,LRelnOut,NewH, Tag,ETag,Vs,EVs,SVs,Ss,Iqs,EIqs,K) :- append_s(Vs,EVs,Ss,NewSs), subsume(NewSs,Iqs,EIqs,LRelnIn,RRelnIn,LRelnOut,RRelnOut, NewH,[h(ETag,Tag,SVs)|K]). subsume_type_act(<,#,_,#,#,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !. subsume_type_act(<,LRelnIn,_,LRelnOut,#,Tag,ETag,Sort,ESort,Vs,EVs,_,ESVs, Ss,Iqs,EIqs,H,K) :- approps(Sort,FRs), approps(ESort,EFRs), sub_feats(FRs,EFRs,EVs,SubEVs), append_s(Vs,SubEVs,Ss,NewSs), subsume(NewSs,Iqs,EIqs,LRelnIn,#,LRelnOut,#,[h(Tag,ETag,ESVs)|H],K). subsume_type_act(>,_,#,#,#,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !. subsume_type_act(>,_,RRelnIn,#,RRelnOut,Tag,ETag,Sort,ESort,Vs,EVs,SVs,_, Ss,Iqs,EIqs,H,K) :- approps(Sort,FRs), approps(ESort,EFRs), sub_feats(EFRs,FRs,Vs,SubVs), append_s(SubVs,EVs,Ss,NewSs), subsume(NewSs,Iqs,EIqs,#,RRelnIn,#,RRelnOut,H,[h(ETag,Tag,SVs)|K]). subsume_type_act(#,_,_,#,#,_,_,_,_,_,_,_,_,_,_,_,_,_). subsume_iqs([],_,Reln,Reln,_). subsume_iqs([_|_],_,#,#,_) :- !. subsume_iqs([Iq|Iqs1],Iqs2,RelnIn,RelnOut,H) :- subsume_iq(Iq,Iqs2,RelnIn,RelnMid,H),% make sure image of each conjunct holds subsume_iqs(Iqs1,Iqs2,RelnMid,RelnOut,H). % in image FS subsume_iq(done,Iqs2Out,_,#,_) :- % negated image of conjunct is satisfied check_inequal(Iqs2Out,_), % by image FS, so no subsumption morphism !. % exists. subsume_iq(ineq(Tag1,SVs1,Tag2,SVs2,IqRest),Iqs2Mid,RelnIn,RelnOut,H) :- map_h_eq(H,Tag1,HTag1,HSVs1,HRes), % test which inequated FS has an image map_h_eq(H,Tag2,HTag2,HSVs2,KRes), subsume_iq_act(HRes,KRes,HTag1,HSVs1,HTag2,HSVs2,Tag1,SVs1,Tag2,SVs2, IqRest,Iqs2Mid,RelnIn,RelnOut,H), !. % need this cut since the call to subsume_iq in unify_disjunct_image % may succeed with the next clause, and we don't want it twice. subsume_iq(_,_,Reln,Reln,_). % image of conjunct is either satisfied by an % inequation conjunct of the image FS (which % failed in the 1st clause above), or is % implicitly encoded in the image FS (since % unifying the images of the inequated FS's of % every disjunct failed in the 2nd clause above). subsume_iq_act(?,_,_,_,HTag2,HSVs2,Tag1,SVs1,_,_,IqRest,Iqs2Mid, RelnIn,RelnOut,H) :- % Inequation is relevant so KRes is ! !,unify_disjunct_image(Tag1,SVs1,HTag2,HSVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H). % use an inequated FS with no image itself for matching conjuncts subsume_iq_act(!,KRes,HTag1,HSVs1,HTag2,HSVs2,_,_,Tag2,SVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H) :- subsume_iq_act2(KRes,HTag2,HSVs2,HTag1,HSVs1,Tag2,SVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H). subsume_iq_act2(?,_,_,HTag1,HSVs1,Tag2,SVs2,IqRest,Iqs2Mid,RelnIn,RelnOut,H) :- !,unify_disjunct_image(HTag1,HSVs1,Tag2,SVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H). subsume_iq_act2(!,HTag2,HSVs2,HTag1,HSVs1,_,_, IqRest,Iqs2Mid,RelnIn,RelnOut,H) :- unify_disjunct_image(HTag1,HSVs1,HTag2,HSVs2,IqRest,Iqs2Mid, RelnIn,RelnOut,H). 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). % map_h_eq(H,Tag,ImageTag,ImageSV,Result) % ------------------------------------------------------------------------------ % Find the image of Tag under subsumption morphism, H. If the image is % known, return Result !; if not, return ?. % ------------------------------------------------------------------------------ map_h_eq([],_,_,_,?). map_h_eq([h(Tag1,Tag2,SVs2)|_],Tag,Tag2,SVs2,!) :- Tag1 == Tag,!. map_h_eq([_|H],Tag1,Tag2,SVs2,Result) :- map_h_eq(H,Tag1,Tag2,SVs2,Result). % sub_type_reln(Sort1,Sort2,Reln) % ------------------------------------------------------------------------------ % Reln is =,<,>, or # based on subsumption comparison of Sort1 and Sort2 % ------------------------------------------------------------------------------ sub_type_reln(Sort,ESort,Reln) :- sub_type(Sort,ESort), !,(sub_type(ESort,Sort) -> (Reln = '=') % can't use unification for = ; (Reln = '<')). % because of poss. atom subsumption sub_type_reln(Sort,ESort,>) :- sub_type(ESort,Sort), !. sub_type_reln(_,_,#). % 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(_,_,_,_,_,_,_,_,_) :- quiet_interpreter, !. edge_discard(LReln,I,Tag,SVs,Iqs,Dtrs,RuleName,Left,Right) :- verbose_interpreter, 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(Left,I,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(edge(Left,I,_,_,_,_,_,_)), !,fail. % failure-drive through all subsumed edges edge_retract(Left,I,_,_,_,_,_) :- quiet_interpreter, retract(edge(Left,I,_,_,_,_,_,_)), !,fail. edge_retract(Left,I,Tag,SVs,Iqs,Dtrs,RuleName) :- verbose_interpreter, !,clause(edge(Left,I,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(Left,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(Left,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(edge(Left,N,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName)). edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) :- quiet_interpreter, !,gennum(N), asserta(edge(Left,N,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName)). edge_assert(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) :- verbose_interpreter, !,nl, length(Dtrs,ND), print_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND), edge_assert_act(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N). % REWRITE THIS edge_assert_act(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,N) :- retract(assert_edge), !,gennum(N), asserta(edge(Left,N,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName)). edge_assert_act(_,_,_,_,_,_,_,-1). % apply_rule will check N >= 0. 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(_), !,asserta(assert_edge). query_edge(Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND) :- nl,write('Action(add,noadd,go(-#),quiet,break,dtr-#,abort)? '), nl,read(Response), query_edge_act(Response,Left,Right,TagOut,SVsOut,IqsOut,Dtrs,RuleName,ND). query_edge_act(add,_,_,_,_,_,_,_,_) :- !,asserta(assert_edge). query_edge_act(noadd,_,_,_,_,_,_,_,_) :- !. query_edge_act(go,_,_,_,_,_,_,_,_) :- !,asserta(assert_edge), asserta(go(go)). query_edge_act(go-G,_,_,_,_,_,_,_,_) :- !,asserta(assert_edge), asserta(go(G)). query_edge_act(quiet,_,_,_,_,_,_,_,_) :- !,asserta(assert_edge), secret_quiet. 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(DLeft,I,_,_,_,_,_,_)), !. 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). % REWRITE THIS nth_index([I|_],1,I,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule) :- !,clause(edge(DLeft,I,DRight,DTag,DSVs,DIqs,DDtrs,DRule),true). % not indexed nth_index([_|Is],N,I,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule) :- N > 1, NMinus1 is N-1, nth_index(Is,NMinus1,I,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(+++>,+++>(_,_)), (FHead +++> FResult), FHead =.. [Rel|ArgDescs], compile_descs(ArgDescs,Args,IqsIn,IqsMid,Goals, [check_inequal(IqsMid,IqsMid2)|GoalsMid]), Fun =.. [Rel|Args], compile_desc(FResult,Tag,SVs,IqsMid2,IqsOut,GoalsMid,[]). % ============================================================================== % Definite Clause Resolution/Compilation % ============================================================================== % ------------------------------------------------------------------------------ % solve(Goals:s,IqsIn:s,IqsOut:s) % ------------------------------------------------------------------------------ % Gs is list of goals to be called % ------------------------------------------------------------------------------ solve([],Iqs,Iqs). solve([Goal|TailGoals],IqsIn,IqsOut):- solve(Goal,TailGoals,IqsIn,IqsOut). % ------------------------------------------------------------------------------ % solve(Goal:, TailGoals:s, IqsIn:s, IqsOut:s) mh(0) % ------------------------------------------------------------------------------ % solves Goal and then tail recursively solves TailGoals % ------------------------------------------------------------------------------ solve(_,_,_,_) if_b [fail] :- \+ current_predicate(if,if(_,_)). solve(Goal,TailGoals,IqsIn,IqsOut) if_b PGoals:- current_predicate(if,if(_,_)), (Head if Body), Head =.. [Rel|ArgDescs], compile_descs(ArgDescs,Args,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsMid2)|PGoalsRest]), Goal =.. [Rel|Args], compile_body(Body,[],TailGoals,IqsMid2,IqsOut,PGoalsRest,[]). solve(true,TailGoals,IqsIn,IqsOut) if_b [solve(TailGoals,IqsIn,IqsOut)]. % needed for trivial input case % to add more Prolog power to solve/2, could use the following: %solve((G1;G2),TailGoals) if_b [( solve(G1,TailGoals) % ; solve(G2,TailGoals) % )]. %solve((G1,G2),TailGoals) if_b [solve(G1,[]), solve(G2,TailGoals)]. % ------------------------------------------------------------------------------ % compile_body(GoalDesc,ContGoals,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest) % ------------------------------------------------------------------------------ % compiles arbitrary Goal, assuming ContGoals is a list of goals to solve % first and TailGoals is list of goals to solve last; TailGoals % is uninstantiated at compile time; % 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),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest):- !, compile_body((GD1,(GD2,GD3)),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest). compile_body(((GD1;GD2),GD3),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest):- !, compile_body(((GD1,GD3);(GD2,GD3)),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest). compile_body((\+ GD1, GD2),ContGoals,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, compile_cont(ContGoals,IqsIn,IqsMid,PGoals,[\+ PGoal|PGoalsMid]), compile_body(GD1,[],[],IqsMid,_,PGoalsList,[]), goal_list_to_seq(PGoalsList,PGoal), compile_body(GD2,[],TailGoals,IqsMid,IqsOut,PGoalsMid,PGoalsRest). compile_body((Desc1 =@ Desc2,GD),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest):- !,compile_cont(ContGoals,IqsIn,IqsMid,PGoals,PGoalsMid), compile_desc(Desc1,Tag1,bot,IqsMid,IqsMid2,PGoalsMid,PGoalsMid2), compile_desc(Desc2,Tag2,bot,IqsMid2,IqsMid3,PGoalsMid2, [deref(Tag1,bot,DTag1,DSVs1), deref(Tag2,bot,DTag2,DSVs2), extensionalise_list([DTag1-DSVs1,DTag2-DSVs2],IqsMid3), check_inequal(IqsMid3,IqsMid4), deref(DTag1,DSVs1,Tag1Out,_), deref(DTag2,DSVs2,Tag2Out,_), (Tag1Out == Tag2Out)|PGoalsMid3]), compile_body(GD,[],TailGoals,IqsMid4,IqsOut,PGoalsMid3,PGoalsRest). compile_body((true,GD),Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, compile_body(GD,Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest). compile_body((!,PGD),Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, compile_cont(Cont,IqsIn,IqsMid,PGoals,[!|PGoalsMid]), compile_body(PGD,[],TailGoals,IqsMid,IqsOut,PGoalsMid,PGoalsRest). compile_body((prolog(Goal),GD),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest) :- !,compile_cont(ContGoals,IqsIn,IqsMid,PGoals,[Goal|PGoalsMid]), compile_body(GD,[],TailGoals,IqsMid,IqsOut,PGoalsMid,PGoalsRest). compile_body((AGD,GD2),Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, AGD =.. [Rel|ArgDescs], compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,PGoals,PGoalsMid), Goal =.. [Rel|Args], append(Cont,[Goal],NewCont), compile_body(GD2,NewCont,TailGoals,IqsMid,IqsOut,PGoalsMid,PGoalsRest). compile_body((GD1;GD2),Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, compile_cont(Cont,IqsIn,IqsMid,PGoals,[(PGoal1;PGoal2)|PGoalsRest]), compile_body(GD1,[],TailGoals,IqsMid,IqsOut,PGoals1,[]), compile_body(GD2,[],TailGoals,IqsMid,IqsOut,PGoals2,[]), goal_list_to_seq(PGoals1,PGoal1), goal_list_to_seq(PGoals2,PGoal2). compile_body((\+ GD),Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, compile_cont(Cont,IqsIn,IqsMid,PGoals, [\+ PGoal,solve(TailGoals,IqsMid,IqsOut)|PGoalsRest]), compile_body(GD,[],[],IqsMid,_,PGoalsList,[]), goal_list_to_seq(PGoalsList,PGoal). compile_body((Desc1 =@ Desc2),ContGoals,TailGoals,IqsIn,IqsOut, PGoals,PGoalsRest):- !,compile_cont(ContGoals,IqsIn,IqsMid,PGoals,PGoalsMid), compile_desc(Desc1,Tag1,bot,IqsMid,IqsMid2,PGoalsMid,PGoalsMid2), compile_desc(Desc2,Tag2,bot,IqsMid2,IqsMid3,PGoalsMid2, [deref(Tag1,bot,DTag1,DSVs1), deref(Tag2,bot,DTag2,DSVs2), extensionalise_list([DTag1-DSVs1,DTag2-DSVs2],IqsMid3), check_inequal(IqsMid3,IqsMid4), deref(DTag1,DSVs1,Tag1Out,_), deref(DTag2,DSVs2,Tag2Out,_), (Tag1Out == Tag2Out), solve(TailGoals,IqsMid4,IqsOut)|PGoalsRest]). compile_body(!,Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, compile_cont(Cont,IqsIn,IqsMid,PGoals, [!,solve(TailGoals,IqsMid,IqsOut)|PGoalsRest]). compile_body(true,Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- !, append(Cont,TailGoals,NewGoals), compile_cont(NewGoals,IqsIn,IqsOut,PGoals,PGoalsRest). compile_body(prolog(Goal),ContGoals,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest) :- !,compile_cont(ContGoals,IqsIn,IqsMid,PGoals, [Goal,solve(TailGoals,IqsMid,IqsOut)|PGoalsRest]). compile_body(AtGD,Cont,TailGoals,IqsIn,IqsOut,PGoals,PGoalsRest):- append(Cont,[AtGoal|TailGoals],[FirstGoal|RestGoals]), AtGD =.. [Rel|ArgDescs], compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,PGoals, [solve(FirstGoal,RestGoals,IqsMid,IqsOut)|PGoalsRest]), AtGoal =.. [Rel|Args]. % ------------------------------------------------------------------------------ % compile_cont(Gs:,IqsIn:s,IqsOut:s,PGoals:, % PGoalsRest:) % ------------------------------------------------------------------------------ % instantiates diff list PGoals-PGoalsRest of Prolog goals to appropriate % solve/1, solve/2 or nothing condition for solving Gs; calls solve/1 on vars % ------------------------------------------------------------------------------ compile_cont(VarGs,IqsIn,IqsOut,[solve(VarGs,IqsIn,IqsOut)|PGoals],PGoals):- var(VarGs), !. compile_cont([],Iqs,Iqs,PGoals,PGoals). compile_cont([G|Gs],IqsIn,IqsOut,[solve(G,Gs,IqsIn,IqsOut)|PGoals],PGoals). % ------------------------------------------------------------------------------ % 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) % ------------------------------------------------------------------------------ % compiles descriptions Descs to constraint Vs into diff list Goals-GoalsRest % ------------------------------------------------------------------------------ compile_descs([],[],Iqs,Iqs,Goals,Goals). compile_descs([ArgDesc|ArgDescs],[Arg|Args],IqsIn,IqsOut, SubGoals,SubGoalsRest):- compile_desc(ArgDesc,Arg,IqsIn,IqsMid,SubGoals,SubGoalsMid), compile_descs(ArgDescs,Args,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest). % ------------------------------------------------------------------------------ % compile_descs_fresh(Descs,Vs,IqsIn,IqsOut,Goals,GoalsRest) % ------------------------------------------------------------------------------ % similar to compile_descs, except that Vs are instantiated to Ref-bot % before compiling Descs % ------------------------------------------------------------------------------ compile_descs_fresh([],[],Iqs,Iqs,Goals,Goals). compile_descs_fresh([ArgDesc|ArgDescs],[Ref-bot|Args],IqsIn,IqsOut, SubGoals,SubGoalsRest):- compile_desc(ArgDesc,Ref,bot,IqsIn,IqsMid,SubGoals,SubGoalsMid), compile_descs_fresh(ArgDescs,Args,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest). % ============================================================================== % 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(Tag:, SVs:, Iqs:s) mh(0) % ------------------------------------------------------------------------------ empty_cat(_,_,_) if_h [fail] :- \+ current_predicate(empty,empty(_)), !. empty_cat(TagOut,SVsOut,IqsOut) if_h []:- empty(Desc), add_to(Desc,Tag,bot,[],IqsIn), % curr_lex_rule_depth(Max), % should we be closing empty cat's % lex_close(0,Max,e,Tag,bot,_,TagMid,SVsMid,IqsIn,IqsMid), % under lex. rules? fully_deref_prune(Tag,bot,TagOut,SVsOut,IqsIn,IqsOut). % ------------------------------------------------------------------------------ % rule(, SVs:, Iqs:s, Left:, Right:, % N:) mh(0) % ------------------------------------------------------------------------------ % adds the result of any rule of which Tag-SVs from Left to Right % might be the first element and the rest of the categories are in the chart % ------------------------------------------------------------------------------ rule(Tag,SVs,Iqs,Left,Right,N) if_h SubGoals :- (RuleName rule Mother ===> Daughters), compile_dtrs(Daughters,Tag,SVs,Iqs,Left,Right,N,SubGoals,[],Mother,RuleName). % ------------------------------------------------------------------------------ % compile_dtrs(Dtrs,Tag,SVs,Iqs,Left,Right,N,PGoals,PGoalsRest,Mother,RuleName) % ------------------------------------------------------------------------------ % compiles description Dtrs to apply rule to first category Tag-SVs, % at position Left-Right in chart, producing a list of Prolog goals % diff list PGoals-PGoalsRest; Mother is result produced % ------------------------------------------------------------------------------ compile_dtrs((cat> Dtr,Rest),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName):- !, compile_desc(Dtr,Tag,SVs,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsOut)|PGoalsMid]), compile_dtrs_rest(Rest,Left,Right,IqsOut,PGoalsMid,PGoalsRest,Mother, [N|DtrsRest],DtrsRest,RuleName). compile_dtrs((sem_head> Dtr,Rest),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName):- !, compile_desc(Dtr,Tag,SVs,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsOut)|PGoalsMid]), compile_dtrs_rest(Rest,Left,Right,IqsOut,PGoalsMid,PGoalsRest,Mother, [N|DtrsRest],DtrsRest,RuleName). compile_dtrs((cats> Dtrs,Rest),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName) :- !,compile_desc(Dtrs,Tag2,bot,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsMid2), deref(Tag2,bot,_,DescSVs), DescSVs =.. [Sort|Vs], ((Sort == e_list) -> PGoal_elist ; (match_list(Sort,Vs,Tag,SVs,Right,N,RuleDtrs,DtrsRest,NextRight, IqsMid2,IqsOut), % a_ correctly causes error PGoal_nelist))|PGoalsRest]), compile_dtrs_rest(Rest,Left,NextRight,IqsOut,PGoalsMid_nelist,[], Mother,RuleDtrs,DtrsRest,RuleName), compile_dtrs(Rest,Tag,SVs,IqsMid2,Left,Right,N,PGoalsMid_elist,[], Mother,RuleName), goal_list_to_seq(PGoalsMid_nelist,PGoal_nelist), goal_list_to_seq(PGoalsMid_elist,PGoal_elist). compile_dtrs((goal> Goal,Rest),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName):- !, compile_body(Goal,[],[],IqsIn,IqsMid,PGoals,PGoalsMid), compile_dtrs(Rest,Tag,SVs,IqsMid,Left,Right,N,PGoalsMid,PGoalsRest, Mother,RuleName). compile_dtrs((sem_goal> Goal,Rest),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName):- !, compile_body(Goal,[],[],IqsIn,IqsMid,PGoals,PGoalsMid), compile_dtrs(Rest,Tag,SVs,IqsMid,Left,Right,N,PGoalsMid,PGoalsRest, Mother,RuleName). compile_dtrs((cat> Dtr),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest,Mother, RuleName):- !, compile_desc(Dtr,Tag,SVs,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsMid2)|PGoalsMid]), compile_desc(Mother,Tag2,bot,IqsMid2,IqsOut,PGoalsMid, [add_edge_deref(Left,Right,Tag2,bot,IqsOut,[N],RuleName)| PGoalsRest]). compile_dtrs((sem_head> Dtr),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName):- !, compile_desc(Dtr,Tag,SVs,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsMid2)|PGoalsMid]), compile_desc(Mother,Tag2,bot,IqsMid2,IqsOut,PGoalsMid, [add_edge_deref(Left,Right,Tag2,bot,IqsOut,[N],RuleName)| PGoalsRest]). % don't check inequations after mother since add_edge_deref does that compile_dtrs((cats> Dtrs),Tag,SVs,IqsIn,Left,Right,N,PGoals,PGoalsRest, Mother,RuleName) :- !,compile_desc(Dtrs,Tag3,bot,IqsIn,IqsMid,PGoals, [check_inequal(IqsMid,IqsMid2), deref(Tag3,bot,_,DescSVs), DescSVs =.. [Sort|Vs], ((Sort == e_list) -> fail ; (match_list(Sort,Vs,Tag,SVs,Right,N,RuleDtrs,[],NextRight, IqsMid2,IqsMid3), PGoal))|PGoalsRest]), % a_ correctly compile_desc(Mother,Tag2,bot,IqsMid3,IqsOut,PGoalsMid, % causes error [add_edge_deref(Left,NextRight,Tag2,bot,IqsOut,RuleDtrs,RuleName)]), goal_list_to_seq(PGoalsMid,PGoal). compile_dtrs(Foo,_,_,_,_,_,_,_,_,_,_):- !, [invalid,line,Foo,in,rule] if_error true, fail. % ------------------------------------------------------------------------------ % compile_dtrs_rest(Dtrs,Left,Right,IqsMid,PGoals,PGoalsRest,Mother, % PrevDtrs,DtrsRest,RuleName) % ------------------------------------------------------------------------------ % same as compile_dtrs, only after first category on RHS of rule is % found; thus looks for an edge/4 if a cat> or cats> spec is found % ------------------------------------------------------------------------------ compile_dtrs_rest((cat> Dtr,Rest),Left,Right,IqsMid, [clause(edge(Right,N,NewRight,Tag,SVs,EdgeIqs,_,_),true)|PGoals], PGoalsRest,Mother,PrevDtrs,[N|DtrsRest],RuleName):- !,compile_desc(Dtr,Tag,SVs,IqsMid,IqsMid2,PGoals, [append(IqsMid2,EdgeIqs,IqsMid3), check_inequal(IqsMid3,IqsOut)|PGoalsMid]), compile_dtrs_rest(Rest,Left,NewRight,IqsOut,PGoalsMid,PGoalsRest,Mother, PrevDtrs,DtrsRest,RuleName). compile_dtrs_rest((sem_head> Dtr,Rest),Left,Right,IqsMid, [clause(edge(Right,N,NewRight,Tag,SVs,EdgeIqs,_,_),true)|PGoals], PGoalsRest,Mother,PrevDtrs,[N|DtrsRest],RuleName):- !,compile_desc(Dtr,Tag,SVs,IqsMid,IqsMid2,PGoals, [append(IqsMid2,EdgeIqs,IqsMid3), check_inequal(IqsMid3,IqsOut)|PGoalsMid]), compile_dtrs_rest(Rest,Left,NewRight,IqsOut,PGoalsMid,PGoalsRest,Mother, PrevDtrs,DtrsRest,RuleName). compile_dtrs_rest((cats> Dtrs,Rest),Left,Right,IqsMid,PGoals,PGoalsRest, Mother,PrevDtrs,DtrsRest,RuleName) :- !,compile_desc(Dtrs,Tag,bot,IqsMid,IqsMid2,PGoals, [check_inequal(IqsMid2,IqsMid3), deref(Tag,bot,_,SVs), SVs =.. [Sort|Vs], match_list_rest(Sort,Vs,Right,NewRight,DtrsRest,DtrsRest2,IqsMid3,IqsOut)| PGoalsMid]),% a_ causes error compile_dtrs_rest(Rest,Left,NewRight,IqsOut,PGoalsMid,PGoalsRest,Mother, PrevDtrs,DtrsRest2,RuleName). compile_dtrs_rest((goal> Goal,Rest),Left,Right,IqsMid,PGoals,PGoalsRest, Mother,PrevDtrs,DtrsRest,RuleName):- !, compile_body(Goal,[],[],IqsMid,IqsMid2,PGoals,PGoalsMid), compile_dtrs_rest(Rest,Left,Right,IqsMid2,PGoalsMid,PGoalsRest,Mother, PrevDtrs,DtrsRest,RuleName). compile_dtrs_rest((sem_goal> Goal,Rest),Left,Right,IqsMid,PGoals,PGoalsRest, Mother,PrevDtrs,DtrsRest,RuleName):- !, compile_body(Goal,[],[],IqsMid,IqsMid2,PGoals,PGoalsMid), compile_dtrs_rest(Rest,Left,Right,IqsMid2,PGoalsMid,PGoalsRest,Mother, PrevDtrs,DtrsRest,RuleName). compile_dtrs_rest((cat> Dtr),Left,Right,IqsMid, [clause(edge(Right,N,NewRight,Tag,SVs,EdgeIqs,_,_),true)|PGoals], PGoalsRest,Mother,PrevDtrs,[N],RuleName):- !,compile_desc(Dtr,Tag,SVs,IqsMid,IqsMid2,PGoals, [append(IqsMid2,EdgeIqs,IqsMid3), check_inequal(IqsMid3,IqsMid4)|PGoalsMid]), compile_desc(Mother,Tag2,bot,IqsMid4,IqsOut,PGoalsMid, [add_edge_deref(Left,NewRight,Tag2,bot,IqsOut, PrevDtrs,RuleName)|PGoalsRest]). compile_dtrs_rest((sem_head> Dtr),Left,Right,IqsMid, [clause(edge(Right,N,NewRight,Tag,SVs,EdgeIqs,_,_),true)|PGoals], PGoalsRest,Mother,PrevDtrs,[N],RuleName):- !,compile_desc(Dtr,Tag,SVs,IqsMid,IqsMid2,PGoals, [append(IqsMid2,EdgeIqs,IqsMid3), check_inequal(IqsMid3,IqsMid4)|PGoalsMid]), compile_desc(Mother,Tag2,bot,IqsMid4,IqsOut,PGoalsMid, [add_edge_deref(Left,NewRight,Tag2,bot,IqsOut, PrevDtrs,RuleName)|PGoalsRest]). % don't check inequations after mother since add_edge_deref does that compile_dtrs_rest((cats> Dtrs),Left,Right,IqsMid,PGoals,PGoalsRest, Mother,PrevDtrs,DtrsRest,RuleName) :- !,compile_desc(Dtrs,Tag,bot,IqsMid,IqsMid2,PGoals, [check_inequal(IqsMid2,IqsMid3), deref(Tag,bot,_,SVs), SVs =.. [Sort|Vs], match_list_rest(Sort,Vs,Right,NewRight,DtrsRest,[],IqsMid3,IqsMid4)| PGoalsMid]),% a_ causes error compile_desc(Mother,Tag2,bot,IqsMid4,IqsOut,PGoalsMid, [add_edge_deref(Left,NewRight,Tag2,bot,IqsOut, PrevDtrs,RuleName)|PGoalsRest]). % don't check inequations after mother since add_edge_deref does that compile_dtrs_rest((goal> Goal),Left,Right,IqsMid,PGoals,PGoalsRest,Mother, PrevDtrs,[],RuleName):- !, compile_body(Goal,[],[],IqsMid,IqsMid2,PGoals,PGoalsMid), compile_desc(Mother,Tag2,bot,IqsMid2,IqsOut,PGoalsMid, [add_edge_deref(Left,Right,Tag2,bot,IqsOut, PrevDtrs,RuleName)|PGoalsRest]). compile_dtrs_rest((sem_goal> Goal),Left,Right,IqsMid,PGoals,PGoalsRest,Mother, PrevDtrs,[],RuleName):- !, compile_body(Goal,[],[],IqsMid,IqsMid2,PGoals,PGoalsMid), compile_desc(Mother,Tag2,bot,IqsMid2,IqsOut,PGoalsMid, [add_edge_deref(Left,Right,Tag2,bot,IqsOut, PrevDtrs,RuleName)|PGoalsRest]). % don't check inequations after mother since add_edge_deref does that compile_dtrs_rest(Foo,_,_,_,_,_,_,_,_,_):- [invalid,line,Foo,in,rule] if_error true, !, fail. % ------------------------------------------------------------------------------ % compile_desc(Desc:, FS:, IqsIn:s, IqsOut:s, % Goals:s, GoalsRest:s) % ------------------------------------------------------------------------------ % Goals are the Prolog goals required to add the description Desc % to the feature structure FS. IqsIn and IqsOut are uninstantiated at % compile time. % ------------------------------------------------------------------------------ compile_desc(X,FS2,IqsIn,IqsOut,[(var(X) -> X = FS2, IqsOut = IqsIn ; ud(X,FS2,IqsIn,IqsOut))|Goals],Goals) :- var(X), !. compile_desc(Tag1-SVs1,Tag2-SVs2,IqsIn,IqsOut, [ud(Tag1,SVs1,Tag2,SVs2,IqsIn,IqsOut)|GoalsRest],GoalsRest):- !. compile_desc([],FS,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_desc(e_list,FS,IqsIn,IqsOut,Goals,GoalsRest). compile_desc([H|T],FS,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_desc((hd:H,tl:T),FS,IqsIn,IqsOut,Goals,GoalsRest). compile_desc(Path1 == Path2,FS,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_pathval(Path1,FS,FSatPath1,IqsIn,IqsMid,Goals,GoalsMid), compile_pathval(Path2,FS,FSatPath2,IqsMid,IqsMid2, GoalsMid,[ud(FSatPath1,FSatPath2,IqsMid2,IqsOut)|GoalsRest]). compile_desc(=\= Desc,Tag-SVs,IqsIn,IqsOut,Goals,GoalsRest) :- !,compile_desc(Desc,Tag2,bot,IqsIn,IqsMid,Goals, [check_inequal_conjunct(ineq(Tag,SVs,Tag2,bot,done),IqOut,Result), ((Result = succeed) -> IqsOut = IqsMid ; (IqOut \== done, IqsOut = [IqOut|IqsMid])) |GoalsRest]). compile_desc(Feat:Desc,FS,IqsIn,IqsOut,[deref(FS,Tag,SVs),Goal|GoalsMid], GoalsRest):- !, [description,uses,unintroduced,feature,Feat] if_error (\+ approp(Feat,_,_)), cat_atoms('featval_',Feat,Rel), Goal =.. [Rel,SVs,Tag,FSatFeat,IqsIn,IqsMid], compile_desc(Desc,FSatFeat,IqsMid,IqsOut,GoalsMid,GoalsRest). compile_desc((Desc1,Desc2),FS,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_desc(Desc1,FS,IqsIn,IqsMid,Goals,GoalsMid), compile_desc(Desc2,FS,IqsMid,IqsOut,GoalsMid,GoalsRest). compile_desc((Desc1;Desc2),FS,IqsIn,IqsOut, [(Goals1Seq;Goals2Seq)|GoalsRest],GoalsRest):- !, compile_desc(Desc1,FS,IqsIn,IqsOut,Goals1,[]), compile_desc(Desc2,FS,IqsIn,IqsOut,Goals2,[]), goal_list_to_seq(Goals1,Goals1Seq), goal_list_to_seq(Goals2,Goals2Seq). compile_desc(@ MacroName,FS,IqsIn,IqsOut,Goals,GoalsRest):- !, [undefined,macro,MacroName,used,in,description] if_error (\+ (MacroName macro Desc)), (MacroName macro Desc), compile_desc(Desc,FS,IqsIn,IqsOut,Goals,GoalsRest). compile_desc(a_ X,FS,IqsIn,IqsOut,[deref(FS,Tag,SVs),Goal|GoalsRest], GoalsRest) :- !, Goal =.. ['add_to_type_a_',SVs,Tag,IqsIn,IqsOut,X]. compile_desc(FunDesc,FS,IqsIn,IqsOut,Goals,GoalsRest):- fun(FunDesc), !,compile_fun(FunDesc,FS,IqsIn,IqsOut,Goals,GoalsRest). compile_desc(Type,FS,IqsIn,IqsOut,[deref(FS,Tag,SVs),Goal|GoalsRest], GoalsRest):- [undefined,type,Type,used,in,description] if_error (\+ type(Type)), type(Type), cat_atoms('add_to_type_',Type,AddtotypeType), Goal =.. [AddtotypeType,SVs,Tag,IqsIn,IqsOut]. % ------------------------------------------------------------------------------ % compile_desc(Desc:, Tag:, SVs:, IqsIn:s, % IqsOut:s, Goals:s, GoalsRest:s) % ------------------------------------------------------------------------------ % 7-place version of compile_desc/6 % ------------------------------------------------------------------------------ compile_desc(X,Tag2,SVs2,IqsIn,IqsOut,[(var(X) -> X = Tag2-SVs2, IqsOut = IqsIn ; ud(X,Tag2,SVs2,IqsIn,IqsOut))|Goals],Goals) :- var(X), !. compile_desc(Tag1-SVs1,Tag2,SVs2,IqsIn,IqsOut, [ud(Tag1,SVs1,Tag2,SVs2,IqsIn,IqsOut)|GoalsRest],GoalsRest):- !. compile_desc([],Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_desc(e_list,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest). compile_desc([H|T],Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_desc((hd:H,tl:T),Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest). compile_desc(Path1 == Path2,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_pathval(Path1,Tag,SVs,FSatPath1,IqsIn,IqsMid,Goals,GoalsMid), compile_pathval(Path2,Tag,SVs,FSatPath2,IqsMid,IqsMid2, GoalsMid,[ud(FSatPath1,FSatPath2,IqsMid2,IqsOut)|GoalsRest]). compile_desc(=\= Desc,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest) :- !,compile_desc(Desc,Tag2,bot,IqsIn,IqsMid,Goals, [check_inequal_conjunct(ineq(Tag,SVs,Tag2,bot,done),IqOut,Result), ((Result = succeed) -> IqsOut = IqsMid ; (IqOut \== done, IqsOut = [IqOut|IqsMid])) |GoalsRest]). compile_desc(Feat:Desc,Tag,SVs,IqsIn,IqsOut, [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsMid], GoalsRest):- !, [description,uses,unintroduced,feature,Feat] if_error (\+ approp(Feat,_,_)), cat_atoms('featval_',Feat,Rel), Goal =.. [Rel,SVsOut,TagOut,FSatFeat,IqsIn,IqsMid], compile_desc(Desc,FSatFeat,IqsMid,IqsOut,GoalsMid,GoalsRest). compile_desc((Desc1,Desc2),Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest):- !, compile_desc(Desc1,Tag,SVs,IqsIn,IqsMid,Goals,GoalsMid), compile_desc(Desc2,Tag,SVs,IqsMid,IqsOut,GoalsMid,GoalsRest). compile_desc((Desc1;Desc2),Tag,SVs,IqsIn,IqsOut, [(Goals1Seq;Goals2Seq)|GoalsRest],GoalsRest):- !, compile_desc(Desc1,Tag,SVs,IqsIn,IqsOut,Goals1,[]), compile_desc(Desc2,Tag,SVs,IqsIn,IqsOut,Goals2,[]), goal_list_to_seq(Goals1,Goals1Seq), goal_list_to_seq(Goals2,Goals2Seq). compile_desc(@ MacroName,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest):- !, [undefined,macro,MacroName,used,in,description] if_error (\+ (MacroName macro Desc)), (MacroName macro Desc), compile_desc(Desc,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest). compile_desc(a_ X,Tag,SVs,IqsIn,IqsOut, [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsRest],GoalsRest) :- !, Goal =.. ['add_to_type_a_',SVsOut,TagOut,IqsIn,IqsOut,X]. compile_desc(FunDesc,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest):- fun(FunDesc), !,compile_fun(FunDesc,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest). compile_desc(Type,Tag,SVs,IqsIn,IqsOut, [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsRest],GoalsRest):- [undefined,type,Type,used,in,description] if_error (\+ type(Type)), type(Type), cat_atoms('add_to_type_',Type,AddtotypeType), Goal =.. [AddtotypeType,SVsOut,TagOut,IqsIn,IqsOut]. % ------------------------------------------------------------------------------ % compile_pathval(Path:,FSIn:,FSOut:, % IqsIn:s,IqsOut:s, % Goals:s, GoalsRest:s) % ------------------------------------------------------------------------------ % Goals-GoalsRest is difference list of goals needed to determine that % FSOut is the (undereferenced) value of dereferenced FSIn at Path; % might instantiate Tag or substructures in SVs in finding path value % ------------------------------------------------------------------------------ compile_pathval([],FS,FS,Iqs,Iqs,Goals,Goals) :- !. compile_pathval([Feat|Feats],FS,FSAtPath,IqsIn,IqsOut, [deref(FS,Tag,SVs),Goal|GoalsMid],GoalsRest):- !, [undefined,feature,Feat,used,in,path,[Feat|Feats]] if_error (\+ approp(Feat,_,_)), cat_atoms('featval_',Feat,Rel), Goal =.. [Rel,SVs,Tag,FSAtFeat,IqsIn,IqsMid], compile_pathval(Feats,FSAtFeat,FSAtPath,IqsMid,IqsOut,GoalsMid,GoalsRest). compile_pathval(P,_,_,_,_,_,_) :- error_msg((nl,write('pathval: illegal path specified - '), write(P))). % ------------------------------------------------------------------------------ % compile_pathval(Path:,RefIn:,SVsIn:,FSOut:, % IqsIn:s,IqsOut:s, % Goals:s, GoalsRest:s) % ------------------------------------------------------------------------------ % 8-place version of compile_pathval/7 % ------------------------------------------------------------------------------ compile_pathval([],Tag,SVs,Tag-SVs,Iqs,Iqs,Goals,Goals) :- !. compile_pathval([Feat|Feats],Tag,SVs,FSAtPath,IqsIn,IqsOut, [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsMid],GoalsRest):- !, [undefined,feature,Feat,used,in,path,[Feat|Feats]] if_error (\+ approp(Feat,_,_)), cat_atoms('featval_',Feat,Rel), Goal =.. [Rel,SVsOut,TagOut,FSAtFeat,IqsIn,IqsMid], compile_pathval(Feats,FSAtFeat,FSAtPath,IqsMid,IqsOut,GoalsMid,GoalsRest). compile_pathval(P,_,_,_,_,_,_,_) :- error_msg((nl,write('pathval: illegal path specified - '), write(P))). % compile_fun(Fun:,FS:,IqsIn:s,IqsOut:s, % Goals:s,GoalsRest:s) % ------------------------------------------------------------------------------ % Goals-RoalsRest is difference list of goals needed to determine that FS % satisfies functional constraint Fun % ------------------------------------------------------------------------------ compile_fun(FunDesc,FS,IqsIn,IqsOut,Goals,GoalsRest) :- FunDesc =.. [Rel|ArgDescs], compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,Goals, [deref(FS,Tag,SVs), fsolve(Fun,Tag,SVs,IqsMid,IqsOut)|GoalsRest]), Fun =.. [Rel|Args]. % compile_fun(Fun:,Ref:,SVs:,IqsIn:s,IqsOut:s, % Goals:s,GoalsRest:s) % ------------------------------------------------------------------------------ % 7-place version of compile_fun/6 % ------------------------------------------------------------------------------ compile_fun(FunDesc,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest) :- FunDesc =.. [Rel|ArgDescs], compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,Goals, [fsolve(Fun,Tag,SVs,IqsMid,IqsOut)|GoalsRest]), Fun =.. [Rel|Args]. % ============================================================================== % Compiler % ============================================================================== % ------------------------------------------------------------------------------ % compile_gram(File:) % ------------------------------------------------------------------------------ % compiles grammar from File; all commands set up same way, with optional % argument for file, which is recompiled, if necessary % ------------------------------------------------------------------------------ :- dynamic ale_compiling/1. :- dynamic alec/1. :- dynamic lexicon_updating/0. alec_announce(Message) :- write(user_error,Message),nl(user_error),flush_output(user_error). term_expansion(end_of_file,Code) :- prolog_load_context(file,File), (ale_compiling(File) -> % current_stream(File,_,S), % seek(S,-1,current,_), % reset end_of_file alec_catch(Code) ; (Code = end_of_file)). term_expansion((WordStart ---> Desc),[(WordStart ---> Desc), (:- multifile (lex)/4), (:- dynamic (lex)/4)|Code]) :- lexicon_updating, secret_noadderrs, bagof(lex(Word,Tag,SVs,IqsOut),lex_act(Word,Tag,SVs,IqsOut,WordStart,Desc), Code), secret_adderrs. term_expansion((empty Desc),[(empty Desc), (:- multifile (empty_cat)/3), (:- dynamic (empty_cat)/3)|Code]) :- lexicon_updating, secret_noadderrs, bagof(empty_cat(TagOut,SVsOut,IqsOut), (add_to(Desc,Tag,bot,[],IqsIn), fully_deref_prune(Tag,bot,TagOut,SVsOut,IqsIn,IqsOut)), Code), secret_adderrs. touch(File) :- open(File,update,S), write(S,':- true.'),nl(S), close(S). alec_catch(Code) :- retract(alec(Stage)) -> alec_catch_act(Stage,Code) ; (Code = [end_of_file]). alec_catch_act(subtype,Code) :- !,compile_sub_type(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(unifytype,Code) :- !,compile_unify_type(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(approp,Code) :- !,compile_approp(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(ext,Code) :- !,compile_ext(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(iso,Code) :- !,multi_hash(0,(iso_sub_seq)/3,Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(check,Code) :- !,multi_hash(0,(check_sub_seq)/5,Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(fun,Code) :- !,compile_fun(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(cons,Code) :- !,compile_cons(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(mgsc,[(:- alec_catch(CodeRest))|CodeRest]) :- !,compile_mgsc_assert. alec_catch_act(addtype,Code) :- !,compile_add_to_type(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(featval,Code) :- !,compile_featval(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(u,Code) :- !,compile_u(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(dcs,Code) :- !,compile_dcs(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(lexrules,Code) :- !,compile_lex_rules(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(lex,Code) :- !,compile_lex(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(empty,Code) :- !,compile_empty(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(rules,Code) :- !,compile_rules(Code,[(:- alec_catch(CodeRest))|CodeRest]). alec_catch_act(generate,Code) :- !,compile_generate(Code,[end_of_file]). alec_catch_act(_,Code) :- retract(ale_compiling(_)), (Code = [end_of_file]). compile_gram(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish_preds, assert(alec(subtype)),assert(alec(unifytype)),assert(alec(approp)), assert(alec(ext)),assert(alec(iso)),assert(alec(check)),assert(alec(fun)), assert(alec(cons)),assert(alec(mgsc)), assert(alec(addtype)),assert(alec(featval)), assert(alec(u)),assert(alec(dcs)),assert(alec(lexrules)), assert(alec(lex)),assert(alec(empty)),assert(alec(rules)), assert(alec(generate)), swi_consult(File), retract(ale_compiling(_)). abolish_preds :- abolish((empty)/1), abolish((rule)/2), abolish((lex_rule)/2), abolish(('--->')/2), abolish((sub)/2), abolish((if)/2), abolish((macro)/2), abolish((ext)/1), abolish((cons)/2), abolish((intro)/2), abolish((semantics)/1), abolish(('+++>')/2). compile_gram :- touch('.alec_sub'), absolute_file_name('.alec_sub',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(subtype)),assert(alec(unifytype)),assert(alec(approp)), assert(alec(ext)),assert(alec(iso)),assert(alec(check)),assert(alec(fun)), assert(alec(cons)),assert(alec(mgsc)), assert(alec(addtype)),assert(alec(featval)), assert(alec(u)),assert(alec(dcs)),assert(alec(lexrules)), assert(alec(lex)),assert(alec(empty)),assert(alec(rules)), assert(alec(generate)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_sig(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((sub)/2),abolish((ext)/1), abolish((intro)/2), assert(alec(subtype)),assert(alec(unifytype)),assert(alec(approp)), assert(alec(ext)),assert(alec(iso)),assert(alec(check)), swi_consult(File), retract(ale_compiling(_)). compile_sig :- touch('.alec_sub'), absolute_file_name('.alec_sub',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(subtype)),assert(alec(unifytype)),assert(alec(approp)), assert(alec(ext)),assert(alec(iso)),assert(alec(check)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_sub_type(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((sub)/2),abolish((intro)/2), assert(alec(subtype)), swi_consult(File), retract(ale_compiling(_)). compile_sub_type :- touch('.alec_sub'), absolute_file_name('.alec_sub',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(subtype)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_sub_type(Code,CodeRest) :- alec_announce('Compiling sub-types...'), abolish((sub_type)/2), retractall(_ sub_def _), ([no,types,defined] if_warning_else_fail (\+current_predicate(sub,_ sub _), \+current_predicate(intro,_ intro _), Code = [(:- alec_catch(CodeRest)|CodeRest)]) ; (current_predicate(sub,_ sub _) -> [S,subsumes,bot] if_error (S sub Ss, (member(bot,Ss) % fails if Ss = _ intro _ ; Ss = (Ts intro _), member(bot,Ts))), [subtype/feature,specification,given,for,'a_/1',atom] if_error ( (a_ _) sub _ ), ['a_/1',atom,declared,subsumed,by,type,Type] if_error ( immed_subtypes(Type,SubTypes), member(a_ _,SubTypes) ), [Type,multiply,defined] if_error ( bagof(S,Subs^(S sub Subs),Types), duplicated(Type,Types) ), [illegal,variable,occurence,in,Type,sub,SubTypes,intro,FRs] if_error (Type sub SubTypes intro FRs, (var(Type) ;member(SubType,SubTypes), var(SubType) ;member(F:R,FRs), (var(F) ;var(R)))), % R can be a variable if parametric types are added [illegal,variable,occurence,in,Type,sub,SubTypes] if_error (Type sub SubTypes, \+(SubTypes = (_ intro _)), (var(Type) ;member(SubType,SubTypes), var(SubType))) ; true), (current_predicate(intro,_ intro _) -> [illegal,variable,occurence,in,Type,intro,FRs] if_error (Type intro FRs, (var(Type) ;member(F:R,FRs), (var(F) ;var(R)))), % R can be a variable if parametric types added [feature,specification,given,for,'a_/1',atom] if_error ( (a_ _) intro _ ) ; true)), ensure_sub_intro, maximal_defaults, bottom_defaults, [unary,branch,from,Type,to,SubType] if_warning immed_subtypes(Type,[SubType]), multi_hash(1,(sub_type)/2,Code,CodeRest). maximal_defaults :- _ sub Xs, (Xs = (SubTypes intro Intros) -> (member(SubType,SubTypes) ;member(_:SubType,Intros)) ;member(SubType,Xs)), \+SubType = (a_ _), \+SubType subs _, SubType \== bot, assert(max_def(SubType)), assert(SubType sub_def []), fail. maximal_defaults :- IType intro Intros, (\+IType = (a_ _), \+IType subs _, IType \== bot, SubType = IType ; member(_:SubType,Intros), \+SubType = (a_ _), \+SubType subs _, SubType \== bot), assert(max_def(SubType)), assert(SubType sub_def []), fail. maximal_defaults :- current_predicate(ext,ext(_)), ext(Exts), member(EType,Exts), \+ EType = (a_ _), \+ EType subs _, EType \== bot, assert(max_def(EType)), assert(EType sub_def []), fail. maximal_defaults :- max_def(_) ->( write_list([assuming,the,following,are,maximal,'type(s): ']), retract(max_def(Type)), write(Type),write(' '), fail ; ttynl) ; true. bottom_defaults :- setof(Type,(type(Type), \+imm_sub_type(_,Type), Type \== bot, \+Type = (a_ _)),BDTypes), !,ttynl, write_list([assuming,the,'type(s):']), nl,write_list(BDTypes), nl,write_list([are,immediately,subsumed,by,bottom]),nl, (bot sub Xs -> (Xs = (BotTypes intro BotIntros) -> % bottom declared with intro append(BDTypes,BotTypes,NewBotTypes), assert(bot sub_def NewBotTypes intro BotIntros) ;append(BDTypes,Xs,NewBotTypes), % bottom declared w/o intro assert(bot sub_def NewBotTypes)) ;assert(bot sub_def BDTypes)). % bottom not declared bottom_defaults :- (bot subs _) -> true % bot declared and no other types necessary ; assert(bot sub_def []). % bot not declared and no other types necessary ensure_sub_intro :- (\+current_predicate(sub,(_ sub _)) -> assertz((_ sub _ :- fail)) ; true), (\+current_predicate(intro,(_ intro _)) -> assertz((_ intro _ :- fail)) ; true). compile_unify_type :- touch('.alec_unify'), absolute_file_name('.alec_unify',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(unifytype)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_unify_type(Code,CodeRest) :- alec_announce('Compiling type unification...'), abolish((unify_type)/3), multi_hash(1,(unify_type)/3,Code,CodeRest). compile_approp(File) :- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((sub)/2),abolish((intro)/2), assert(alec(approp)), swi_consult(File), retract(ale_compiling(_)). compile_approp :- touch('.alec_approp'), absolute_file_name('.alec_approp',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(approp)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_approp(Code,CodeRest) :- alec_announce('Compiling appropriateness...'), abolish((approp)/3), [bot,has,appropriate,features] if_error ((bot sub _ intro [_:_|_]) ;(bot intro [_:_|_])), [no,features,introduced] if_warning (\+ (_ sub _ intro [_:_|_]), \+ (_ intro [_:_|_])), [multiple,specification,for,F,in,declaration,of,S] if_error ( S sub _ intro FRs, duplicated(F:_,FRs) ; S intro FRs2, duplicated(F:_,FRs2)), [multiple,feature,specifications,for,type,S] if_error (S sub _ intro _, S intro _ ;bagof(IType,FRs^(IType intro FRs),ITypes), duplicated(S,ITypes)), % multiple sub/2 taken care of above [atom,'a_',X,is,ground,in,declaration,of,S] if_warning ( ( S sub _ intro FRs ; S intro FRs), member((_:(a_ X)),FRs), ground(X)), multi_hash(1,(approp)/3,Code,[ (:- [appropriateness,cycle,following,path,Fs,from,type,S] if_error ( type(S), feat_cycle(S,Fs) )), (:- [homomorphism,condition,fails,for,F,in,S1,and,S2] if_warning ( approp(F,S1,T1), approp(F,S2,T2), unify_type(S1,S2,S3), approp(F,S3,T3), unify_type(T1,T2,T1UnifyT2), \+sub_type(T3,T1UnifyT2)))|CodeRest]). % must check with sub_type because of atoms compile_extensional(File) :- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((ext)/1), assert(alec(ext)),assert(alec(iso)),assert(alec(check)), swi_consult(File), retract(ale_compiling(_)). compile_extensional :- touch('.alec_ext'), absolute_file_name('.alec_ext',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(ext)),assert(alec(iso)),assert(alec(check)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_ext(Code,CodeRest) :- alec_announce('Compiling extensionality declarations...'), abolish((extensional)/1),abolish((iso_sub_seq)/3),abolish((check_sub_seq)/5), ((\+current_predicate(ext,ext(_)) ; ext([])) -> (Code = [extensional(a_ _)|CodeRest]) ;(ext(Exts), compile_ext_act(Exts,Code,CodeRest))). compile_ext_act([],[extensional(a_ _)|CodeRest],CodeRest). compile_ext_act([a_ _|Exts],Code,CodeRest) :- !,compile_ext_act(Exts,Code,CodeRest). compile_ext_act([E|Exts],[extensional(E)|CodeMid],CodeRest) :- [extensional,type,E,is,not,maximal] if_error (sub_type(E,S), S \== E), compile_ext_act(Exts,CodeMid,CodeRest). compile_cons(File) :- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((cons)/2), assert(alec(cons)), swi_consult(File), retract(ale_compiling(_)). compile_cons :- touch('.alec_cons'), absolute_file_name('.alec_cons',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(cons)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_cons(Code,CodeRest) :- alec_announce('Compiling type constraints...'), abolish((ct)/7), (current_predicate(cons,(_ cons _)) -> [bot,has,constraints] if_error ( bot cons _ ), [multiple,constraint,declarations,for,CType] if_error (bagof(CT,Cons^(CT cons Cons),CTypes), duplicated(CType,CTypes)), [constraint,declaration,given,for,atom] if_error ((a_ _) cons _ ), ['=@',accessible,by,procedural,attachment,calls,from,constraint,for,Type] if_warning (current_predicate(cons,(_ cons _)), current_predicate(if,(_ if _)), find_xeqs([],EGs), Type cons _ goal Gs, find_xeq_act(Gs,EGs)) ; true), multi_hash(0,(ct)/7,Code,CodeRest). find_xeqs(Accum,EGs) :- findall(EG,find_xeq(Accum,EG),NewAccum,Accum), find_xeqs_act(NewAccum,Accum,EGs). find_xeqs_act(EGs,EGs,EGs) :- !. find_xeqs_act(NewAccum,_,EGs) :- find_xeqs(NewAccum,EGs). find_xeq(Accum,G/N) :- (Head if Body), functor(Head,G,N), \+member(G/N,Accum), find_xeq_act(Body,Accum). find_xeq_act(=@(_,_),_) :- !. find_xeq_act((G1,_),Accum) :- find_xeq_act(G1,Accum), !. find_xeq_act((_,G2),Accum) :- find_xeq_act(G2,Accum), !. find_xeq_act((G1;_),Accum) :- find_xeq_act(G1,Accum), !. find_xeq_act((_;G2),Accum) :- find_xeq_act(G2,Accum), !. find_xeq_act((\+ G),Accum) :- find_xeq_act(G,Accum), !. find_xeq_act(At,Accum) :- functor(At,AG,AN), member(AG/AN,Accum). compile_logic:- touch('.alec_mgsat'), absolute_file_name('.alec_mgsat',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(mgsc)), assert(alec(addtype)),assert(alec(featval)), assert(alec(u)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_mgsat:- touch('.alec_mgsat'), absolute_file_name('.alec_mgsat',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(mgsc)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_mgsc_assert :- alec_announce('Compiling most general satisfiers...'), abolish((mgsc)/7), setof(T,Subs^(T subs Subs),Types), top_sort_list(Types,[],_,[],AppropTypes), assert(mgsc((a_ X),(a_ X),_,Iqs,Iqs,CGs,CGs)), map_mgsat(AppropTypes). map_mgsat([]). map_mgsat([T|AppropTypes]) :- approps(T,FRs), map_mgsat_act(FRs,Vs,IqsIn,IqsMid,ConsGoals,ConsGoalsMid), SVs =.. [T|Vs], mgsat_cons(T,Tag,SVs,IqsMid,IqsOut,ConsGoalsMid,ConsGoalsRest), assert(mgsc(T,SVs,Tag,IqsIn,IqsOut,ConsGoals,ConsGoalsRest)), map_mgsat(AppropTypes). map_mgsat_act([],[],Iqs,Iqs,ConsGoals,ConsGoals). map_mgsat_act([_:TypeRestr|FRs],[(Tag-SVs)|Vs],IqsIn,IqsOut,ConsGoals, ConsGoalsRest) :- mgsc(TypeRestr,SVs,Tag,IqsIn,IqsMid,ConsGoals,ConsGoalsMid), map_mgsat_act(FRs,Vs,IqsMid,IqsOut,ConsGoalsMid,ConsGoalsRest). mgsat_cons(Type,Tag,SVs,IqsIn,IqsOut,ConsGoals,ConsGoalsRest) :- esetof(T,sub_type(T,Type),ConsTypes), map_cons(ConsTypes,Tag,SVs,IqsIn,IqsOut,ConsGoals,ConsGoalsRest). compile_add_to_type :- touch('.alec_addtype'), absolute_file_name('.alec_addtype',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(addtype)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_add_to_type(Code,CodeRest) :- alec_announce('Compiling type promotion...'), abolish((add_to_type)/5), multi_hash(1,(add_to_type)/5,Code,CodeRest). compile_add_to_type3(Code,CodeRest) :- findall((Goal :- deref(FS,Tag,SVs), Goal2), ((Type subs _), % types other than a_/1 atoms cat_atoms('add_to_type_',Type,Rel), Goal =.. [Rel,FS,IqsIn,IqsOut], Goal2 =.. [Rel,SVs,Tag,IqsIn,IqsOut]), Code, [('add_to_type_a_'(FS,IqsIn,IqsOut,X) :- deref(FS,Tag,SVs), 'add_to_type_a_'(SVs,Tag,IqsIn,IqsOut,X))|CodeRest]). compile_featval :- touch('.alec_featval'), absolute_file_name('.alec_featval',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(featval)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_featval(Code,CodeRest) :- alec_announce('Compiling feature selection...'), abolish((featval)/6), ( ((_ sub _ intro _) ; (_ intro _)) -> multi_hash(1,(featval)/6,Code,CodeRest) ; (Code = CodeRest)). compile_featval4(Code,CodeRest) :- setof(Clause, Feat^Goal^Goal2^Rel^Type^Subs^FRs^R^( (Clause = (Goal :- deref(FS,Tag,SVs), Goal2)), ( (Type subs Subs intro FRs), member(Feat:R,FRs), cat_atoms('featval_',Feat,Rel), Goal =.. [Rel,FS,FSOut,IqsIn,IqsOut], Goal2 =.. [Rel,SVs,Tag,FSOut,IqsIn,IqsOut] ; (Type intro FRs), member(Feat:R,FRs), cat_atoms('featval_',Feat,Rel), Goal =.. [Rel,FS,FSOut,IqsIn,IqsOut], Goal2 =.. [Rel,SVs,Tag,FSOut,IqsIn,IqsOut])), CodeNoEnd), append(CodeNoEnd,CodeRest,Code). compile_u :- touch('.alec_u'), absolute_file_name('.alec_u',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(u)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_u(Code,CodeRest) :- alec_announce('Compiling unification...'), abolish((u)/6), multi_hash(1,(u)/6,Code,CodeRest). compile_grammar(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((empty)/1),abolish((rule)/2), abolish((lex_rule)/2), abolish(('--->')/2), abolish((semantics)/1), assert(alec(lexrules)),assert(alec(lex)),assert(alec(empty)), assert(alec(rules)),assert(alec(generate)), swi_consult(File), retract(ale_compiling(_)). compile_grammar :- touch('.alec_lr'), absolute_file_name('.alec_lr',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(lexrules)),assert(alec(lex)),assert(alec(empty)), assert(alec(rules)),assert(alec(generate)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_lex_rules(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((lex_rule)/2), assert(alec(lexrules)), swi_consult(File), retract(ale_compiling(_)). compile_lex_rules :- touch('.alec_lr'), absolute_file_name('.alec_lr',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(lexrules)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_lex_rules(Code,CodeRest) :- abolish((lex_rule)/8), (parsing -> alec_announce('Compiling lexical rules...'), ( [no,lexical,rules,found] if_warning_else_fail (\+ current_predicate(lex_rule,lex_rule(_,_))) -> (Code = CodeRest) ; ([lexical,rule,RuleName,lacks,morphs,specification] if_error ((RuleName lex_rule _ **> _ if _) ;(RuleName lex_rule _ **> _)), multi_hash(0,(lex_rule)/8,Code,CodeRest)) ) ; (Code = CodeRest)). compile_lex(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish(('--->')/2), assert(alec(lex)), swi_consult(File), retract(ale_compiling(_)). compile_lex :- touch('.alec_lex'), absolute_file_name('.alec_lex',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(lex)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_lex(CodeStart,CodeRest) :- (lexicon_consult -> (CodeStart = [(:- multifile (lex)/4),(:- dynamic (lex)/4)|Code]) ; (CodeStart = Code)), abolish((lex)/4), secret_noadderrs, (parsing -> alec_announce('Compiling lexicon...'), ( [no,lexicon,found] if_warning_else_fail (\+ current_predicate('--->',(_ ---> _))) -> (CodeRest = Code) ; multi_hash(0,(lex)/4,Code,CodeRest)) ; (CodeRest = Code)), secret_adderrs. % update_lex(+File) % ----------------- update_lex(File) :- lexicon_consult, assert(lexicon_updating), swi_consult(File), retract(lexicon_updating). % retract_lex(+LexSpec) % --------------------- retract_lex(LexSpec) :- LexSpec = [_|_] -> retract_lex_list(LexSpec) ; retract_lex_one(LexSpec). retract_lex_list([]). retract_lex_list([Lex|LexRest]) :- retract_lex_one(Lex), retract_lex_list(LexRest). retract_lex_one(Word) :- lex(Word,Tag,SVs,IqsIn), nl, write('WORD: '), write(Word), nl, write('ENTRY: '), extensionalise(Tag,SVs,IqsIn), check_inequal(IqsIn,IqsOut), pp_fs(Tag-SVs,IqsOut), ttynl, write('RETRACT? '),ttyflush,read(y), retract(lex(Word,Tag,SVs,IqsIn)), fail. retract_lex_one(_). retractall_lex(LexSpec) :- LexSpec = [_|_] -> retractall_lex_list(LexSpec) ; retractall(lex(LexSpec,_,_,_)). retractall_lex_list([]). retractall_lex_list([Lex|LexRest]) :- retractall(lex(Lex,_,_,_)), retract_lex_list(LexRest). % export_words(+Stream,+Delimiter) % -------------------------------- % Write the words in the current lexicon in a Delimiter-separated list to % Stream export_words(Stream,Delimiter) :- setof(Word,Tag^SVs^Iqs^lex(Word,Tag,SVs,Iqs),Words), export_words_act(Words,Stream,Delimiter). export_words_act([],_,_). export_words_act([W|Ws],Stream,Delimiter) :- write(Stream,W),write(Stream,Delimiter), export_words_act(Ws,Stream,Delimiter). compile_empty(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((empty)/1), assert(alec(empty)), swi_consult(File), retract(ale_compiling(_)). compile_empty :- touch('.alec_empty'), absolute_file_name('.alec_empty',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(empty)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_empty(CodeStart,CodeRest) :- (lexicon_consult -> (CodeStart = [(:- multifile (empty_cat)/3), (:- dynamic (empty_cat)/3)|Code]) ; (CodeStart = Code)), abolish((empty_cat)/3), secret_noadderrs, (parsing -> (alec_announce('Compiling empty categories...'), multi_hash(0,(empty_cat)/3,Code,CodeRest)) ; (Code = CodeRest)), secret_adderrs. compile_rules(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((rule)/2), assert(alec(rules)), swi_consult(File), retract(ale_compiling(_)). retract_empty :- empty_cat(Tag,SVs,IqsIn), extensionalise(Tag,SVs,IqsIn), check_inequal(IqsIn,IqsOut), nl, write('EMPTY CATEGORY: '), pp_fs(Tag-SVs,IqsOut,4), ttynl, write('RETRACT? '),ttyflush,read(y), retract(empty_cat(Tag,SVs,IqsIn)), fail. retract_empty. retractall_empty :- retractall(empty_cat(_,_,_)). compile_rules :- touch('.alec_rules'), absolute_file_name('.alec_rules',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(rules)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_rules(Code,CodeRest) :- alec_announce('Compiling phrase structure rules...'), abolish((rule)/6), abolish((chain_rule)/12), abolish((non_chain_rule)/8),abolish((chained)/7), ( [no,phrase,structure,rules,found] if_warning_else_fail (\+ current_predicate(rule,rule(_,_))) -> (Code = CodeRest) ; [rule,RuleName,has,no,'cat>','cats>',or,'sem_head>',specification] if_error ((RuleName rule _ ===> Body), \+ cat_member(Body), \+ cats_member(Body), \+ sem_head_member(Body)), [rule,RuleName,has,multiple,'sem_head>',specifications] if_error ((RuleName rule _ ===> Body), multiple_heads(Body)), [rule,RuleName,has,wrongly,placed,'sem_goal>',specifications] if_error ((RuleName rule _ ===> Body), bad_sem_goal(Body)), (parsing -> multi_hash(0,(rule)/6,Code,CodeGen) ; (CodeGen = Code)), (generating -> (( [no,chain,rules,found] if_warning_else_fail (\+ ((_ rule _ ===> Body), split_dtrs(Body,_,_,_,_,_))) -> (CodeNotChained = CodeGen) ; multi_hash(0,(chain_rule)/12,CodeGen,CodeChained), multi_hash(0,(chained)/7,CodeChained,CodeNotChained)), ( [no,non_chain,rules,found] if_warning_else_fail (\+ ((_ rule _ ===> Body), \+ split_dtrs(Body,_,_,_,_,_)), \+ current_predicate(empty,empty(_)), \+ current_predicate('--->',(_ ---> _))) -> (CodeNotChained = CodeRest) ; multi_hash(0,(non_chain_rule)/8,CodeNotChained,CodeRest))) ; (CodeGen = CodeRest))). compile_generate(File) :- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((semantics)/1), assert(alec(generate)), swi_consult(File), retract(ale_compiling(_)). compile_generate :- touch('.alec_gen'), absolute_file_name('.alec_gen',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(generate)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_generate(Code,CodeRest) :- abolish((generate)/6), (generating -> alec_announce('Compiling semantics directive...'), ( [no,semantics,specification,found] if_warning_else_fail (\+ current_predicate(semantics,semantics(_))) -> (Code = CodeRest) ; semantics(Pred), functor(Goal,Pred,2), ([no,Pred,definite,clause,found] if_warning_else_fail (\+ (current_predicate(if,(_ if _)), (Goal if _))) -> (Code = CodeRest) ; multi_hash(0,(generate)/6,Code,CodeRest))) ; (Code = CodeRest)). compile_dcs(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish((if)/2), assert(alec(dcs)), swi_consult(File), retract(ale_compiling(_)). compile_dcs :- touch('.alec_dcs'), absolute_file_name('.alec_dcs',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(dcs)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_dcs(Code,CodeRest) :- alec_announce('Compiling definite clauses...'), abolish((solve)/4), [no,definite,clauses,found] if_warning (\+ current_predicate(if,if(_,_))), multi_hash(0,(solve)/4,Code,CodeRest). compile_fun(File):- absolute_file_name(File,[file_type(prolog),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), abolish(('+++>')/2), assert(alec(fun)), swi_consult(File), retract(ale_compiling(_)). compile_fun :- touch('.alec_fun'), absolute_file_name('.alec_fun',[file_type(txt),file_errors(fail), solutions(first)],AbsFileName), assert(ale_compiling(AbsFileName)), assert(alec(fun)), swi_consult(AbsFileName), retract(ale_compiling(_)). compile_fun(Code,CodeRest) :- alec_announce('Compiling functional descriptions...'), abolish((fsolve)/5),abolish((fun)/1), ([no,functional,descriptions,found] if_warning_else_fail (\+ current_predicate(+++>,+++>(_,_))) -> (Code = [(fun(_) :- !,fail)|CodeRest]) ; (setof(Functor/Arity,F^((F +++> _), % IS THIS RIGHT? functor(F,Functor,Arity)),Functions), compile_fun_act(Functions,Code,CodeFSolve), multi_hash(0,(fsolve)/5,CodeFSolve,CodeRest)) ). compile_fun_act([],Code,Code). compile_fun_act([(Functor/Arity)|Functions], [fun(Template)|CodeMid],CodeRest) :- functor(Template,Functor,Arity), compile_fun_act(Functions,CodeMid,CodeRest). % ------------------------------------------------------------------------------ % cat_member(Dtrs) % ------------------------------------------------------------------------------ % true if Dtrs has at least one category member % ------------------------------------------------------------------------------ cat_member((cat> _)). cat_member((cat> _, _)):-!. cat_member((_,Body)):- cat_member(Body). % ------------------------------------------------------------------------------ % sem_head_member(+Dtrs:s) % ------------------------------------------------------------------------------ % true if Dtrs has at least one sem_head> member % ------------------------------------------------------------------------------ sem_head_member((sem_head> _)). sem_head_member((sem_head> _,_)):-!. sem_head_member((_,Body)):- sem_head_member(Body). % ------------------------------------------------------------------------------ % sem_goal_member(+Dtrs:s) % ------------------------------------------------------------------------------ % true if Dtrs has at least one sem_goal> member % ------------------------------------------------------------------------------ sem_goal_member((sem_goal> _)). sem_goal_member((sem_goal> _,_)):-!. sem_goal_member((_,Body)):- sem_goal_member(Body). % ------------------------------------------------------------------------------ % cats_member(Dtrs) % ------------------------------------------------------------------------------ % true if Dtrs has at least one cats member % ------------------------------------------------------------------------------ cats_member((cats> _)). cats_member((cats> _, _)):- !. % doesn't check for cats> [] or elist! cats_member((_,Body)):- cats_member(Body). % ------------------------------------------------------------------------------ % multiple_heads(+Dtrs:s) % ------------------------------------------------------------------------------ % checks whether Dtrs has multiple sem_head> members % ------------------------------------------------------------------------------ multiple_heads((sem_head> _,Dtrs)) :- !, sem_head_member(Dtrs). multiple_heads((_,Dtrs)) :- multiple_heads(Dtrs). % ------------------------------------------------------------------------------ % bad_sem_goal(+Dtrs:s) % ------------------------------------------------------------------------------ % checks whether Dtrs has wrongly placed sem_goal> members % ------------------------------------------------------------------------------ bad_sem_goal(Dtrs) :- % there's a sem_head split_dtrs(Dtrs,_,_,_,DtrsBefore,DtrsAfter), !, (sem_goal_member(DtrsBefore) -> true ; sem_goal_member(DtrsAfter)). bad_sem_goal(Dtrs) :- % there's no sem_head sem_goal_member(Dtrs). % ------------------------------------------------------------------------------ % if_h(Goal:, SubGoals:s) +user % ------------------------------------------------------------------------------ % accounts for multi-hash goals with no subgoals given % ------------------------------------------------------------------------------ Goal if_h [] :- Goal if_h. % ------------------------------------------------------------------------------ % multi_hash(N:, Fun/Arity:/,Code:,CodeRest:) % ------------------------------------------------------------------------------ % for each solution T1,...,TK of ?- G(T1,...,TK) if_h SubGoals. % G(f1(X11,...,X1J1),V2,...,VK):- % G_f1(V2,...,VK,X11,...,X1J1). % ... % G_f1_f2_..._fN(TN+1,...,TK,X11,...,X1J1,X21,..,X2J2,...,XN1,..,XNJN):- % SubGoals. % order matters for clauses listed with if_b, but not with if_h % clauses with if_b must have subgoals listed, even if empty (for order) % Will not behave properly with if_b on discontiguous user declarations for N>0 % ------------------------------------------------------------------------------ multi_hash(N,(Fun)/Arity,Code,CodeRest):- length(Args,Arity), Goal =.. [Fun|Args], ( setof(sol(Args,SubGoals), if_h(Goal,SubGoals), Sols) -> true ; bagof(sol(Args,SubGoals), if_b(Goal,SubGoals), Sols) ), mh(N,Sols,Fun,Code,CodeRest). mh(0,Sols,Fun,Code,CodeRest):- !, mh_zero(Sols,Fun,Code,CodeRest). mh(N,Sols,Fun,Code,CodeRest):- mh_nonzero(Sols,Fun,N,Code,CodeRest). mh_zero([],_,Code,Code). mh_zero([sol(Args,SubGoals)|Sols],Fun,[Clause|CodeMid],CodeRest) :- Goal =.. [Fun|Args], (SubGoals = [] -> (Clause = Goal) ; (goal_list_to_seq(SubGoals,SubGoalSeq), Clause = (Goal :- SubGoalSeq))), mh_zero(Sols,Fun,CodeMid,CodeRest). %write_soln(Args,SubGoals,Fun,Col):- % eval % Goal =.. [Fun|Args], % write_clause(Goal,SubGoals,Col). mh_nonzero([],_,_,Code,Code). mh_nonzero([sol(Args,SubGoals)],Fun,_,[Clause|CodeRest],CodeRest):- !, Goal =.. [Fun|Args], (SubGoals = [] -> (Clause = Goal) ; (goal_list_to_seq(SubGoals,SubGoalSeq), Clause = (Goal :- SubGoalSeq))). mh_nonzero([sol([Arg|Args],SubGoals)|Sols],Fun,N,Code,CodeRest):- nonvar(Arg), functor(Arg,FunArg,Arity), Arg =.. [_|ArgsArg], ( (Sols = [sol([Arg2|_],_)|_], nonvar(Arg2), functor(Arg2,FunArg,Arity)) -> (cat_atoms('_',FunArg,FunTail), cat_atoms(Fun,FunTail,FunNew), same_length(Args,OtherArgs), Goal =.. [Fun,Arg|OtherArgs], append(OtherArgs,ArgsArg,ArgsNew), SubGoal =.. [FunNew|ArgsNew], append(Args,ArgsArg,ArgsOld), (Code = [(Goal :- SubGoal)|CodeMid]), mh_arg(FunArg,Arity,Sols,[sol(ArgsOld,SubGoals)],Fun,FunNew,N, CodeMid,CodeRest)) ; Goal =.. [Fun,Arg|Args], (Code = [Clause|CodeMid]), (SubGoals = [] -> (Clause = Goal) ; (goal_list_to_seq(SubGoals,SubGoalSeq), Clause = (Goal :- SubGoalSeq))), mh_nonzero(Sols,Fun,N,CodeMid,CodeRest) ). mh_arg(FunMatch,Arity,[sol([Arg|Args],SubGoals)|Sols],SolsSub,Fun,FunNew, N,Code,CodeRest):- Arg =.. [FunMatch|ArgsSub], % formerly cut here - standard order ensures length(ArgsSub,Arity), % correctness for if_h in both cases !,append(Args,ArgsSub,ArgsNew), mh_arg(FunMatch,Arity,Sols,[sol(ArgsNew,SubGoals)|SolsSub],Fun,FunNew,N, Code,CodeRest). mh_arg(_,_,Sols,SolsSub,Fun,FunNew,N,Code,CodeRest):- NMinusOne is N-1, mh(NMinusOne,SolsSub,FunNew,Code,CodeMid), mh_nonzero(Sols,Fun,N,CodeMid,CodeRest). % ------------------------------------------------------------------------------ % write_clause(Head:, Goals:s, Column:) % ------------------------------------------------------------------------------ % writes clause with head Head and sequence Goals of subgoals % ------------------------------------------------------------------------------ write_clause(Head,Body,Col):- \+ \+ ( lettervars_track(Head+Body), nl, tab(Col), write(Head), write_clause_act(Body,Col) ). write_clause_act([],_):- write('.'). write_clause_act([G|Gs],Col):- write((:-)), write_clause_goals(Gs,G,Col). write_clause_goals([],Goal,Col):- nl, NewCol is Col+2, tab(NewCol), write_goal(Goal,NewCol), write('.'). write_clause_goals([Goal2|Goals],Goal1,Col):- nl, NewCol is Col+2, tab(NewCol), write_goal(Goal1,NewCol), write(','), write_clause_goals(Goals,Goal2,Col). write_goal(\+ Goal,Col):- !, write('\\+ '), write('( '), NewCol is Col+5, write_goal(Goal,NewCol), nl, tab(Col), tab(3), write(')'). write_goal((Goal1;Goal2),Col):- !, write('( '), NewCol is Col + 2, write_goal(Goal1,NewCol), nl, tab(Col), write('; '), write_goal(Goal2,NewCol), nl, tab(Col), write(')'). write_goal((Goal1,Goal2),Col):- !, write_goal(Goal1,Col), write(','), nl, tab(Col), write_goal(Goal2,Col). write_goal(Goal,_):- write(Goal). % lettervars_track(Term:) % ------------------------------------------------------------------------------ % instantiates shared variables in Term to constants V1,V2,...; % instantiates unshared variables to constant '_' % ------------------------------------------------------------------------------ lettervars_track(Term):- vars_of(Term,[],Vars), eliminate_single_vars(Vars,0). % ------------------------------------------------------------------------------ % 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). % ------------------------------------------------------------------------------ % eliminate_single_vars(Vars:s, N:) % ------------------------------------------------------------------------------ % multiple occurences in Vars are set to numbers beginning with N, while % single occurences are instantiated to constant '_' % ------------------------------------------------------------------------------ eliminate_single_vars([],_). eliminate_single_vars([Var|Vars],N):- var(Var) -> ( select_eq(Var,Vars,VarsLeft) -> (cat_atoms('V',N,Var), M is N+1, eliminate_single_vars(VarsLeft,M)) ; Var = '_', eliminate_single_vars(Vars,N) ) ; eliminate_single_vars(Vars,N). % ============================================================================== % Debugger / Top Level I/O % ============================================================================== % ------------------------------------------------------------------------------ % show_type(Type:) % ------------------------------------------------------------------------------ % Displays information about Type, including appropriate features, immediate % subtypes, supertypes, and constraints. Continues by allowing to browse % super or subtypes % ------------------------------------------------------------------------------ show_type(Type):- nl, write('TYPE: '), write(Type), immed_subtypes(Type,SubTypes), nl, write('SUBTYPES: '), write(SubTypes), ( setof(T,T2^(sub_type(T,Type), T \== Type, \+ (sub_type(T2,Type), T2 \== Type, T2 \== T, sub_type(T,T2))),SuperTypes) -> true ; SuperTypes = [] ), nl, write('SUPERTYPES: '), write(SuperTypes), (current_predicate(cons,(_ cons _)) -> ((Type cons Cons goal _) -> true ; Type cons Cons) ; Cons = none), nl, write('IMMEDIATE CONSTRAINT: '), write(Cons), add_to(Type,Tag,bot,[],IqsIn), deref(Tag,bot,Ref,SVs), extensionalise(Ref,SVs,IqsIn), check_inequal(IqsIn,IqsOut), nl, write('MOST GENERAL SATISFIER: '), pp_fs(Ref-SVs,IqsOut,5). % ------------------------------------------------------------------------------ % show_cons(Type:) %------------------------------------------------------------------------------- show_cons(Type):- immed_cons(Type,Cons), nl, write('Immediate Constraint for type: '),write(Type), nl, write(Cons). % ------------------------------------------------------------------------------ % mgsat(Desc:) % ------------------------------------------------------------------------------ % prints out most general satisfiers of Desc % ------------------------------------------------------------------------------ mgsat(Desc):- nl, write('MOST GENERAL SATISFIER OF: '), write(Desc), nl, \+ \+ (add_to(Desc,Tag,bot,[],Iqs), deref(Tag,bot,Ref,SVs), extensionalise(Ref,SVs,Iqs), check_inequal(Iqs,CheckedIqs), pp_fs(Ref-SVs,CheckedIqs), nl, query_proceed). % ------------------------------------------------------------------------------ % iso_desc(Desc1:, Desc2:) % ------------------------------------------------------------------------------ % checks if Desc1 and Desc2 create extensionally identical structures % ------------------------------------------------------------------------------ iso_desc(D1,D2):- add_to(D1,Tag1,bot,[],IqsMid), add_to(D2,Tag2,bot,IqsMid,_), iso(Tag1-bot,Tag2-bot). % ------------------------------------------------------------------------------ % rec(Words:s) % ------------------------------------------------------------------------------ % basic predicate to parse Words; prints out recognized categories % one at a time % ------------------------------------------------------------------------------ rec(Words):- nl, write('STRING: '), nl, number_display(Words,0), ttynl, rec(Words,Tag,SVs,Iqs), nl, write('CATEGORY: '),nl, ttyflush, pp_fs(Tag-SVs,Iqs), nl, query_proceed. % ------------------------------------------------------------------------------ % rec(Words:s,Desc:) % ------------------------------------------------------------------------------ % Like rec/1, but solution FSs must satisfy Desc % ------------------------------------------------------------------------------ rec(Words,Desc):- nl, write('STRING: '), nl, number_display(Words,0), ttynl, rec(Words,Tag,SVs,Iqs,Desc), nl, write('CATEGORY: '),nl, ttyflush, pp_fs(Tag-SVs,Iqs), nl, query_proceed. % ------------------------------------------------------------------------------ % rec_best(+WordsList:list(s),Desc) % ------------------------------------------------------------------------------ % Parses every list of words in WordsList until one succeeds, satisfying Desc, % or there are no more lists. If one succeeds, then rec_best/2 will backtrack % through all of its solutions that satisfy Desc, but not through the % subsequent lists of words in WordsList. rec_best([],_) :- fail. rec_best([Ws|WordsList],Desc) :- if(rec(Ws,Tag,SVs,Iqs,Desc), (nl,write('STRING: '), nl,number_display(Ws,0), nl,write('CATEGORY: '),nl,ttyflush, pp_fs(Tag-SVs,Iqs), nl,query_proceed), rec_best(WordsList,Desc)). % ------------------------------------------------------------------------------ % rec_list(+WordsList:list(s),Desc) % ------------------------------------------------------------------------------ % Parses every list of words in WordsList until one succeeds, satisfying Desc, % or there are no more lists. Unlike rec_best/2, rec_list/2 will backtrack % through all of the solutions of a list that succeeds, and then continue % parsing the subsequent lists of words in WordsList. rec_list([],_) :- fail. rec_list([Ws|WordsList],Desc) :- rec(Ws,Tag,SVs,Iqs,Desc), nl,write('STRING: '), nl,number_display(Ws,0), nl,write('CATEGORY: '),nl,ttyflush, pp_fs(Tag-SVs,Iqs), nl,query_proceed ; rec_list(WordsList,Desc). % ------------------------------------------------------------------------------ % rec_list(+WordsList:list(s),Desc,SolnsList:list(s)) % ------------------------------------------------------------------------------ % Like rec_list/2, but collects the solutions in a list of lists, one for each % list of words in WordsList. Each solution is a pair, fs(FS,Iqs). % ------------------------------------------------------------------------------ rec_list([],_,[]). rec_list([Ws|WordsList],Desc,[Solns|SolnsList]) :- bagof(fs(DTag-DSVs,IqsOut),(rec(Ws,Tag,SVs,IqsIn,Desc), fully_deref_prune(Tag,SVs,DTag,DSVs,IqsIn, IqsOut)), Solns), rec_list(WordsList,Desc,SolnsList). % ------------------------------------------------------------------------------ % lex(Word:) % ------------------------------------------------------------------------------ % prints out all categories for Word, querying user in between % ------------------------------------------------------------------------------ lex(Word):- lex(Word,Tag,SVs,IqsIn), nl, write('WORD: '), write(Word), nl, write('ENTRY: '), extensionalise(Tag,SVs,IqsIn), check_inequal(IqsIn,IqsOut), pp_fs(Tag-SVs,IqsOut), nl, query_proceed. % ------------------------------------------------------------------------------ % query(GoalDesc:) % ------------------------------------------------------------------------------ % given a goal description GoalDesc, finds most general satisfier of it % and then calls it as a goal % ------------------------------------------------------------------------------ query(GoalDesc):- \+ \+ (nl, satisfy_dtrs_goal(GoalDesc,Args,[],Goal,[],IqsMid), solve(Goal,[],IqsMid,IqsMid2), deref_list(Args,ArgsOut), extensionalise_list(ArgsOut,IqsMid2), check_inequal(IqsMid2,IqsOut), duplicates_list(ArgsOut,IqsOut,[],_,[],_,0,_), pp_goal(Goal,[],VisMid,0), nl, pp_iqs(IqsOut,VisMid,_,0), nl, query_proceed). % ------------------------------------------------------------------------------ % mg_sat_goal(GoalDesc,Goal,IqsIn,IqsOut) eval % ------------------------------------------------------------------------------ % Goal is most general satisfier of GoalDesc % (also used for functional descriptions) % ------------------------------------------------------------------------------ mg_sat_goal((GDesc1;GDesc2),(G1;G2),IqsIn,IqsOut):- !, mg_sat_goal(GDesc1,G1,IqsIn,IqsMid), mg_sat_goal(GDesc2,G2,IqsMid,IqsOut). mg_sat_goal(!,!,Iqs,Iqs):-!. mg_sat_goal((GDesc1,GDesc2),(G1,G2),IqsIn,IqsOut):- !, mg_sat_goal(GDesc1,G1,IqsIn,IqsMid), mg_sat_goal(GDesc2,G2,IqsMid,IqsOut). mg_sat_goal(prolog(Hook),prolog(Hook),Iqs,Iqs) :- !. mg_sat_goal(GoalDesc,Goal,IqsIn,IqsOut):- GoalDesc =.. [Rel|ArgDescs], mg_sat_list(ArgDescs,Args,IqsIn,IqsOut), Goal =.. [Rel|Args]. % ------------------------------------------------------------------------------ % mg_sat_list(GoalDescs,Goals,IqsIn,IqsOut) % ------------------------------------------------------------------------------ % maps mg_sat_goal on GoalDescs % ------------------------------------------------------------------------------ mg_sat_list([],[],Iqs,Iqs). mg_sat_list([ArgDesc|ArgDescs],[Ref-bot|Args],IqsIn,IqsOut):- add_to(ArgDesc,Ref,bot,IqsIn,IqsMid), mg_sat_list(ArgDescs,Args,IqsMid,IqsOut). % ------------------------------------------------------------------------------ % macro(MacroName:) % ------------------------------------------------------------------------------ % prints out possible instantiations of macro named MacroName % ------------------------------------------------------------------------------ macro(MacroName):- MacroName = VarName, \+ \+ ((VarName macro Desc), add_to(Desc,Tag,bot,[],IqsMid), satisfy_dtrs_goal(VarName,MacroArgs,[],MacroSat,IqsMid,IqsMid2), deref_list([Tag-bot|MacroArgs],ArgsOut), extensionalise_list(ArgsOut,IqsMid2), check_inequal(IqsMid2,IqsMid3), duplicates_list(ArgsOut,IqsMid3,[],_,[],_,0,_), nl, write('MACRO: '), nl, tab(4), pp_goal(MacroSat,[],VisMid,4), nl, write('ABBREVIATES:'), nl, tab(4), pp_fs(Tag-bot,VisMid,VisOut,4), nl, pp_iqs(IqsMid3,VisOut,_,4), nl, query_proceed). insert_vars(MacroName,VarName):- MacroName =.. [Rel|Args], insert_vars_list(Args,ArgsVars), VarName =.. [Rel|ArgsVars]. insert_vars_list([],[]). insert_vars_list([X|Xs],[(_,X)|XsVar]):- insert_vars_list(Xs,XsVar). % ------------------------------------------------------------------------------ % empty % ------------------------------------------------------------------------------ % displays empty categories % ------------------------------------------------------------------------------ empty:- empty_cat(Tag,SVs,IqsIn), extensionalise(Tag,SVs,IqsIn), check_inequal(IqsIn,IqsOut), nl, write('EMPTY CATEGORY: '), pp_fs(Tag-SVs,IqsOut,4), nl, query_proceed. % ------------------------------------------------------------------------------ % edge(N:, M:) % ------------------------------------------------------------------------------ % prints out edges from N to M, querying user in between % ------------------------------------------------------------------------------ edge(I) :- clause(edge(M,I,N,Tag,SVs,Iqs,Dtrs,RuleName),true), % not indexed nl, write('COMPLETED CATEGORY SPANNING: '), write_out(M,N), nl, edge_act(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName). edge(M,N):- (M =< N -> nl, write('COMPLETED CATEGORIES SPANNING: '), write_out(M,N), nl, clause(edge(M,I,N,Tag,SVs,Iqs,Dtrs,RuleName),true), nl, edge_act(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName), fail ; error_msg((nl,write('edge/2: first argument must be =< second argument'))) ). % used to assert variables for Dtrs and RuleName to keep edge-size small %edge_act(_,_,_,Tag,SVs,Iqs,_,_) :- % no_interpreter, % !,pp_fs(Tag-SVs,Iqs). %edge_act(_,_,_,Tag,SVs,Iqs,Dtrs,_) :- % var(Dtrs), % !,pp_fs(Tag-SVs,Iqs), % nl,write('(Edge created while interpreter was inactive)'),nl. edge_act(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName) :- length(Dtrs,ND), print_edgeout(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND). print_edgeout(I,M,N,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(M),write(' to: '),write(N), nl,write(' string: '),write_out(M,N), nl,write(' rule: '),write(RuleName), nl,write(' # of dtrs: '),write(ND), query_edgeout(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_edgeout(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- nl,write('Action(retract,dtr-#,continue,abort)? '), nl,read(Response), query_edgeout_act(Response,I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_edgeout_act(retract,I,M,_,_,_,_,_,_,_) :- retract(edge(M,I,_,_,_,_,_,_)), % use left node M for first-arg. indexing !. query_edgeout_act(dtr-D,I,M,N,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_edgeout(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND). query_edgeout_act(continue,_,_,_,_,_,_,_,_,_) :- !. query_edgeout_act(abort,_,_,_,_,_,_,_,_,_) :- !,abort. query_edgeout_act(_,I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND) :- query_edgeout(I,M,N,Tag,SVs,Iqs,Dtrs,RuleName,ND). write_out(M,N):- parsing(Ws), all_but_first(M,Ws,WsRest), K is N-M, write_first(K,WsRest). all_but_first(0,Ws,Ws):-!. all_but_first(M,[_|Ws],WsOut):- K is M-1, all_but_first(K,Ws,WsOut). write_first(0,_):-!. write_first(N,[W|Ws]):- write(W), write(' '), K is N-1, write_first(K,Ws). % ------------------------------------------------------------------------------ % lexrule(RuleName:) % ------------------------------------------------------------------------------ % Displays lexical rule with name RuleName % ------------------------------------------------------------------------------ lex_rule(RuleName):- \+ \+ lexrule2(RuleName). lexrule2(RuleName):- (( (RuleName lex_rule Desc1 **> Desc2 if Cond morphs Morphs) ; (RuleName lex_rule Desc1 **> Desc2 morphs Morphs), Cond = none ), nl, write('LEX RULE: '), write(RuleName), add_to(Desc1,Tag1,bot,[],IqsMid), add_to(Desc2,Tag2,bot,IqsMid,IqsMid2), satisfy_dtrs_goal(Cond,Args,[],Goal,IqsMid2,IqsMid3), deref_list([Tag1-bot,Tag2-bot|Args],ArgsOut), extensionalise_list(ArgsOut,IqsMid3), check_inequal(IqsMid3,IqsMid4), duplicates_list(ArgsOut,IqsMid4,[],_,[],_,0,_), nl, write('INPUT CATEGORY: '), nl, tab(4), pp_fs(Tag1-bot,[],VisMid1,4), nl, write('OUTPUT CATEGORY: '), nl, tab(4), pp_fs(Tag2-bot,VisMid1,VisMid2,4), ( (Cond = none, VisMid3 = VisMid2) -> true ; (nl, write('CONDITION: '), nl, tab(4), pp_goal(Goal,VisMid2,VisMid3,4)) ), nl, write('MORPHS: '), numbervars(Morphs,0,_), pp_morphs(Morphs), nl, pp_iqs(IqsMid4,VisMid3,_,4), nl, query_proceed). pp_morphs((Morph,Morphs)):- !, nl, tab(4), pp_morph(Morph), pp_morphs(Morphs). pp_morphs(Morph):- nl, tab(4), pp_morph(Morph). pp_morph((P1 becomes P2)):- pp_patt(P1), write(' becomes '), pp_patt(P2). pp_morph((P1 becomes P2 when Cond)):- pp_patt(P1), write(' becomes '), pp_patt(P2), nl, tab(8), write('when '), write(Cond). pp_patt((X,Xs)):- !, pp_at_patt(X), write(','), pp_patt(Xs). pp_patt(X):- pp_at_patt(X). pp_at_patt(Atom):- atom(Atom), !, name(Atom,Codes), make_char_list(Codes,Chars), write(Chars). pp_at_patt(List):- write(List). % ------------------------------------------------------------------------------ % show_clause(PredSpec:) % ------------------------------------------------------------------------------ % Displays definite clauses in feature structure format % ------------------------------------------------------------------------------ show_clause(Spec):- \+ \+ show_clause2(Spec). show_clause2(Spec):- (( Spec = Name/Arity -> true ; Spec = Name ), (Head if Body), functor(Head,Name,Arity), satisfy_dtrs_goal(Head,Cats,CatsRest,HeadGoal,[],IqsMid), satisfy_dtrs_goal(Body,CatsRest,[],BodyGoal,IqsMid,IqsMid2), deref_list(Cats,CatsOut), extensionalise_list(CatsOut,IqsMid2), check_inequal(IqsMid2,IqsMid3), duplicates_list(CatsOut,IqsMid3,[],_,[],_,0,_), nl, write('HEAD: '), pp_goal(HeadGoal,[],Vis,6), nl, write('BODY: '), pp_goal(BodyGoal,Vis,Vis2,6), nl, pp_iqs(IqsMid3,Vis2,_,6), nl, query_proceed). % ------------------------------------------------------------------------------ % rule(RuleName:) % ------------------------------------------------------------------------------ % Displays rule with name RuleName % ------------------------------------------------------------------------------ rule(RuleName):- \+ \+ ((RuleName rule Moth ===> DtrsDesc), nl, write('RULE: '), write(RuleName), add_to(Moth,TagMoth,bot,[],IqsMid), satisfy_dtrs(DtrsDesc,DtrCats,[],Dtrs,IqsMid,IqsMid2), deref_list([TagMoth-bot|DtrCats],CatsOut), extensionalise_list(CatsOut,IqsMid2), check_inequal(IqsMid2,IqsMid3), duplicates_list(CatsOut,IqsMid3,[],_,[],_,0,_), nl, nl, write('MOTHER: '), nl, nl, tab(2), pp_fs(TagMoth-bot,[],VisMid,2), nl, nl, write('DAUGHTERS/GOALS: '), show_rule_dtrs(Dtrs,VisMid,VisMid2), nl, pp_iqs(IqsMid3,VisMid2,_,2), nl, query_proceed). show_rule_dtrs([],Vis,Vis). show_rule_dtrs([(cat> C)|Dtrs],VisIn,VisOut):- nl, nl, write('CAT '), pp_fs(C,VisIn,VisMid,5), show_rule_dtrs(Dtrs,VisMid,VisOut). show_rule_dtrs([(sem_head> C)|Dtrs],VisIn,VisOut):- nl, nl, write('SEM_HEAD '), pp_fs(C,VisIn,VisMid,10), show_rule_dtrs(Dtrs,VisMid,VisOut). show_rule_dtrs([(cats> Cs)|Dtrs],VisIn,VisOut):- nl, nl, write('CATs '), pp_fs(Cs,VisIn,VisMid,5), show_rule_dtrs(Dtrs,VisMid,VisOut). show_rule_dtrs([(goal> G)|Dtrs],VisIn,VisOut):- nl, nl, write('GOAL '), pp_goal(G,VisIn,VisMid,6), show_rule_dtrs(Dtrs,VisMid,VisOut). show_rule_dtrs([(sem_goal> G)|Dtrs],VisIn,VisOut):- nl, nl, write('SEM_GOAL '), pp_goal(G,VisIn,VisMid,10), show_rule_dtrs(Dtrs,VisMid,VisOut). pp_goal(Goal):- Goal =.. [_|Args], duplicates_list(Args,[],[],_,[],_,0,_), pp_goal(Goal,[],_,0). pp_goal(\+ Goal,VisIn,VisOut,Col):- !, write('\\+ '), write('( '), NewCol is Col+5, pp_goal(Goal,VisIn,VisOut,NewCol), nl, tab(Col), tab(3), write(')'). pp_goal((Goal1;Goal2),VisIn,VisOut,Col):- !, write('( '), NewCol is Col + 2, pp_goal(Goal1,VisIn,VisMid,NewCol), nl, tab(Col), write('; '), pp_goal(Goal2,VisMid,VisOut,NewCol), nl, tab(Col), write(')'). pp_goal((Goal1,Goal2),VisIn,VisOut,Col):- !, pp_goal(Goal1,VisIn,VisMid,Col), write(','), nl, tab(Col), pp_goal(Goal2,VisMid,VisOut,Col). pp_goal(prolog(Hook),Vis,Vis,_) :- !, write(prolog(Hook)). pp_goal(Desc1 =@ Desc2,VisIn,VisOut,Col) :- !, write('('), NewCol is Col+3, pp_fs(Desc1,VisIn,VisMid,NewCol), nl, tab(Col), write('=@'), nl, tab(NewCol), pp_fs(Desc2,VisMid,VisOut,NewCol), nl, tab(Col), write(')'). pp_goal(Goal,VisIn,VisOut,Col):- Goal =.. [Rel|Args], write(Rel), ( Args = [] -> VisOut = VisIn ; write('('), name(Rel,Name), length(Name,N), NewCol is Col+N+1, pp_goal_args(Args,VisIn,VisOut,NewCol) ). pp_goal_args([],Vis,Vis,_):- write(')'). pp_goal_args([Arg],VisIn,VisOut,Col):- !, pp_fs(Arg,VisIn,VisOut,Col), write(')'). pp_goal_args([Arg|Args],VisIn,VisOut,Col):- pp_fs(Arg,VisIn,VisMid,Col), write(','), nl, tab(Col), pp_goal_args(Args,VisMid,VisOut,Col). satisfy_dtrs((cat> Desc),[Tag-bot|DtrCatsRest],DtrCatsRest, [(cat> Tag-bot)],IqsIn,IqsOut):- !, add_to(Desc,Tag,bot,IqsIn,IqsOut). satisfy_dtrs((sem_head> Desc),[Tag-bot|DtrCatsRest],DtrCatsRest, [(sem_head> Tag-bot)],IqsIn,IqsOut):- !, add_to(Desc,Tag,bot,IqsIn,IqsOut). satisfy_dtrs((cats> Descs),[Tag-bot|DtrCatsRest],DtrCatsRest, [(cats> Tag-bot)],IqsIn,IqsOut) :- !, add_to(Descs,Tag,bot,IqsIn,IqsOut). satisfy_dtrs((goal> GoalDesc),DtrCats,DtrCatsRest, [(goal> Goal)],IqsIn,IqsOut):- !, satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut). satisfy_dtrs((sem_goal> GoalDesc),DtrCats,DtrCatsRest, [(sem_goal> Goal)],IqsIn,IqsOut):- !, satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut). satisfy_dtrs(((cat> Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest, [(cat> Tag-bot)|DtrsSats],IqsIn,IqsOut):- !, add_to(Desc,Tag,bot,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut). satisfy_dtrs(((sem_head> Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest, [(sem_head> Tag-bot)|DtrsSats],IqsIn,IqsOut):- !, add_to(Desc,Tag,bot,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut). satisfy_dtrs(((cats> Descs),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest, [(cats> Tag-bot)|DtrsSats],IqsIn,IqsOut):- !, add_to(Descs,Tag,bot,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut). satisfy_dtrs(((goal> GoalDesc),Dtrs),DtrCats,DtrCatsRest, [goal> Goal|DtrsSats],IqsIn,IqsOut):- satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsMid,Goal,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut). satisfy_dtrs(((sem_goal> GoalDesc),Dtrs),DtrCats,DtrCatsRest, [sem_goal> Goal|DtrsSats],IqsIn,IqsOut):- satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsMid,Goal,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut). satisfy_dtrs_goal((GD1,GD2),DtrCats,DtrCatsRest, (G1,G2),IqsIn,IqsOut):- !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid), satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut). satisfy_dtrs_goal((GD1;GD2),DtrCats,DtrCatsRest, (G1;G2),IqsIn,IqsOut):- !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid), satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut). satisfy_dtrs_goal((\+ GD1),DtrCats,DtrCatsRest, (\+ G1),IqsIn,IqsOut):- !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsRest,G1,IqsIn,IqsOut). satisfy_dtrs_goal(prolog(Hook),DtrCats,DtrCats,prolog(Hook),Iqs,Iqs) :- !. satisfy_dtrs_goal(AtGD,DtrCats,DtrCatsRest,AtG,IqsIn,IqsOut):- AtGD =.. [Rel|ArgDescs], same_length(ArgDescs,Args), AtG =.. [Rel|Args], satisfy_dtrs_goal_args(ArgDescs,DtrCats,DtrCatsRest,Args,IqsIn,IqsOut). satisfy_dtrs_goal_args([],DtrCats,DtrCats,[],Iqs,Iqs). satisfy_dtrs_goal_args([D|Ds],[Tag-bot|DtrCats],DtrCatsRest,[Tag-bot|Args], IqsIn,IqsOut):- add_to(D,Tag,bot,IqsIn,IqsMid), satisfy_dtrs_goal_args(Ds,DtrCats,DtrCatsRest,Args,IqsMid,IqsOut). % ============================================================================== % Pretty Printing % ============================================================================== % ------------------------------------------------------------------------------ % pp_fs(FS:,Iqs:s) % ------------------------------------------------------------------------------ % pretty prints FS with inequations Iqs % ------------------------------------------------------------------------------ pp_fs(FS,Iqs):- \+ \+ ( duplicates(FS,Iqs,[],_,[],_,0,_), nl, pp_fs(FS,[],VisOut,0), nl, pp_iqs(Iqs,VisOut,_,0)). pp_fs(FS,Iqs,N):- \+ \+ ( duplicates(FS,Iqs,[],_,[],_,0,_), nl, tab(N), pp_fs(FS,[],VisOut,N), nl, pp_iqs(Iqs,VisOut,_,N)). % ------------------------------------------------------------------------------ % duplicates(FS:, Iqs:s, DupsIn:s, DupsOut:s, % VisIn:s, VisOut:s, NumIn:, NumOut:) % ------------------------------------------------------------------------------ % DupsOut is the result of adding the duplicate references % in FS and Iqs to those in DupsIn. VisIn are those nodes already % visited and VisOut are those visited in FS. NumIn is % the current number for variables and NumOut is the % next available after numbering only the shared refs in FS. % ------------------------------------------------------------------------------ duplicates(FS,Iqs,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :- duplicates_fs(FS,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid), duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). duplicates_fs(FS,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):- deref_pp(FS,Ref,SVs), ( member_eq(Ref,DupsIn) -> DupsOut = DupsIn, VisOut = VisIn, NumOut = NumIn ; (member_eq(Ref,VisIn) -> (DupsOut = [Ref|DupsIn], VisIn = VisOut, Ref = NumIn, NumOut is NumIn + 1) ; ((SVs = a_ _) -> DupsIn = DupsOut, VisOut = [Ref|VisIn], NumOut = NumIn ; (SVs =.. [_|Vs], duplicates_list(Vs,[],DupsIn,DupsOut,[Ref|VisIn],VisOut, NumIn,NumOut))))). duplicates_iqs([],Dups,Dups,Vis,Vis,Num,Num). duplicates_iqs([Iq|Iqs],DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :- duplicates_ineq(Iq,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid), duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). duplicates_ineq(done,Dups,Dups,Vis,Vis,Num,Num). duplicates_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),DupsIn,DupsOut,VisIn,VisOut, NumIn,NumOut):- duplicates_fs(Tag1-SVs1,DupsIn,DupsMid1,VisIn,VisMid1,NumIn,NumMid1), duplicates_fs(Tag2-SVs2,DupsMid1,DupsMid2,VisMid1,VisMid2,NumMid1,NumMid2), duplicates_ineq(Ineqs,DupsMid2,DupsOut,VisMid2,VisOut,NumMid2,NumOut). duplicates_list([],Iqs,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :- duplicates_iqs(Iqs,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut). duplicates_list([V|Vs],Iqs,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):- duplicates_fs(V,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid), duplicates_list(Vs,Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). % ------------------------------------------------------------------------------ % pp_iqs(Iqs:s, VisIn:s, VisOut:s,Col:) % ------------------------------------------------------------------------------ % pretty-prints a list of inequations, indented Col columns %------------------------------------------------------------------------------- pp_iqs([],Vis,Vis,_). pp_iqs([ineq(Tag1,SVs1,Tag2,SVs2,Ineqs)|Iqs],VisIn,VisOut,Col) :- (Ineqs = done -> true ;write('(')), pp_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),VisIn,VisMid,Col), (Ineqs = done -> true ;write(')')), (Iqs = [] -> nl ; write(','), nl, pp_iqs(Iqs,VisMid,VisOut,Col)). pp_ineq(done,Vis,Vis,_). pp_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),VisIn,VisOut,Col) :- tab(Col),pp_fs(Tag1-SVs1,VisIn,VisMid1,Col), write(' =\\= '), NewCol is Col+7, pp_fs(Tag2-SVs2,VisMid1,VisMid2,NewCol), nl, (Ineqs = done -> true ;write(';')), pp_ineq(Ineqs,VisMid2,VisOut,Col). % ------------------------------------------------------------------------------ % pp_fs(FS:,VisIn:s, VisOut:s, Col:) % ------------------------------------------------------------------------------ % prints FS where VisOut is the result of adding all of the % referents of substructures in FS to VisIn % Col is where printing begins for FS % ------------------------------------------------------------------------------ pp_fs(FS,VisIn,VisOut,Col):- deref_pp(FS,Ref,SVs), ( var(Ref) -> true % print ref if shared (nonvar) ; write('['), write(Ref), write(']'), ( member_eq(Ref,VisIn) -> true ; write(' ') ) ), ( member_eq(Ref,VisIn) -> VisOut = VisIn ; (SVs = a_ X) -> (no_write_type_flag(a_ X) -> true ; write(a_ X) ), VisOut = [Ref|VisIn] ; SVs =.. [Type|Vs], % print FS if not already visited approps(Type,FRs), ( no_write_type_flag(Type) -> pp_vs_unwritten(FRs,Vs,[Ref|VisIn],VisOut,Col) ; write(Type), pp_vs(FRs,Vs,[Ref|VisIn],VisOut,Col) ) ). :- dynamic no_write_type_flag/1. :- dynamic no_write_feat_flag/1. write_types:- write_type(_). write_feats:- write_feat(_). write_type(Type):- retractall(no_write_type_flag(Type)). write_feat(Feat):- retractall(no_write_feat_flag(Feat)). no_write_type(Type):- retractall(no_write_type_flag(Type)), assert(no_write_type_flag(Type)). no_write_feat(Feat):- retractall(no_write_feat_flag(Feat)), assert(no_write_feat_flag(Feat)). % ------------------------------------------------------------------------------ % deref_pp(FS1:, FS2:) % ------------------------------------------------------------------------------ % FS2 is the result of dereferencing FS1 where Ref might % be constant due to printing refs % ------------------------------------------------------------------------------ deref_pp(Ref-SVs,RefOut,SVsOut):- (nonvar(Ref), \+ atomic(Ref)) -> deref_pp(Ref,RefOut,SVsOut) ; RefOut = Ref, SVsOut = SVs. % ------------------------------------------------------------------------------ % pp_vs(FRs:, Vs:, Dups:s, % VisIn:s, VisOut:s, Col:) % ------------------------------------------------------------------------------ % prints Vs at Col % ------------------------------------------------------------------------------ pp_vs([],[],Vis,Vis,_). pp_vs([F:_|FRs],[V|Vs],VisIn,VisOut,Col):- ( no_write_feat_flag(F), VisMid = VisIn -> true ; nl, tab(Col), write_feature(F,LengthF), NewCol is Col + LengthF +1, pp_fs(V,VisIn,VisMid,NewCol) ), pp_vs(FRs,Vs,VisMid,VisOut,Col). pp_vs_unwritten([],[],Vis,Vis,_). pp_vs_unwritten([F:_|FRs],[V|Vs],VisIn,VisOut,Col):- ( no_write_feat_flag(F), VisMid = VisIn -> true ; write_feature(F,LengthF), NewCol is Col + LengthF +1, pp_fs(V,VisIn,VisMid,NewCol) ), pp_vs(FRs,Vs,VisMid,VisOut,Col). write_feature(F,LengthF):- name(F,NameF), count_and_capitalize(NameF,0,LengthF), write(' '). count_and_capitalize([],Length,Length). count_and_capitalize([L|Ls],LengthIn,Length):- capitalize(L,LCap), write(LCap), LengthInPlus1 is LengthIn + 1, count_and_capitalize(Ls,LengthInPlus1,Length). capitalize(X,XCap):- ( (name(a,[Name_a]), name(z,[Name_z]), Name_a =< X, X =< Name_z) -> name('A',[Name_A]), Gap is Name_A - Name_a, NameXCap is X + Gap, name(XCap,[NameXCap]) ; name(XCap,[X]) ). % ============================================================================== % Utilities % ============================================================================== % ------------------------------------------------------------------------------ % cat_atoms/3 % ------------------------------------------------------------------------------ cat_atoms(A1,A2,A3):- name(A1,L1), name(A2,L2), append(L1,L2,L3), name(A3,L3). % ------------------------------------------------------------------------------ % esetof(X:Alpha, Goal:, Xs:) % ------------------------------------------------------------------------------ % setof returning empty list if no solutions % ------------------------------------------------------------------------------ esetof(X,Goal,Xs) :- if(setof(X,Goal,Xs), true, (Xs = [])). % ------------------------------------------------------------------------------ % member_eq(X:, Xs:s) % ------------------------------------------------------------------------------ % X is strictly == equal to a member of list Xs % ------------------------------------------------------------------------------ member_eq(X,[Y|Ys]):- X==Y ; member_eq(X,Ys). % ------------------------------------------------------------------------------ % member_ref_eq(X:, Xs:s) %------------------------------------------------------------------------------- % Ref-_ belongs to SortDom %------------------------------------------------------------------------------- member_ref_eq(Ref,SortDom) :- %exactly this reference belongs member(SRef-_,SortDom), Ref == SRef. % ------------------------------------------------------------------------------ % select_eq(X:, Xs:s, XsLeft:s) % ------------------------------------------------------------------------------ % X is strictly == equal to a member of list Xs with XsLeft left over % ------------------------------------------------------------------------------ select_eq(X,[Y|Ys],Zs):- X==Y, Zs = Ys ; Zs = [Y|Zs2], select_eq(X,Ys,Zs2). % ------------------------------------------------------------------------------ % 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). % ------------------------------------------------------------------------------ % reverse_count(ListIn:,Acc:,ListOut:, % CountIn:,CountOut:) % ------------------------------------------------------------------------------ % using accumulators, reverses ListIn into ListOut, with initial segment % Acc; CountIn is current count (of Acc) and CountOut is result; call % by: reverse_count(ListIn,[],ListOut,0,Count) % ------------------------------------------------------------------------------ reverse_count([],Xs,Xs,Count,Count). reverse_count([X|Xs],Ys,Zs,CountIn,Count):- CountInPlus1 is CountIn+1, reverse_count(Xs,[X|Ys],Zs,CountInPlus1,Count). % ------------------------------------------------------------------------------ % query_proceed % ------------------------------------------------------------------------------ % prompts user for n. response, otherwise proceeds % ------------------------------------------------------------------------------ query_proceed:- ttynl, write('ANOTHER? '), ttyflush, read(n). % ------------------------------------------------------------------------------ % number_display/2 % ------------------------------------------------------------------------------ number_display([],M):- write(M). number_display([W|Ws],N):- write(N), write(' '), write(W), write(' '), SN is N + 1, number_display(Ws,SN). % ------------------------------------------------------------------------------ % error_msg(Goal:) % ------------------------------------------------------------------------------ % tells user, solves Goal, then goes back to old file being told % ------------------------------------------------------------------------------ error_msg(Goal):- telling(FileName), tell(user), Goal, told, tell(FileName), fail. % ------------------------------------------------------------------------------ % if_error(Msg,Cond) % ------------------------------------------------------------------------------ % if condition Cond holds, provides Msg as error message; always succeeds % ------------------------------------------------------------------------------ if_error(Msg,Cond):- telling(FileName), tell(user), ( Cond, ttynl, write_list([' **ERROR: '|Msg]), ttynl, ttynl, fail ; told, tell(FileName) ). % ------------------------------------------------------------------------------ % if_warning_else_fail(Msg,Cond) % ------------------------------------------------------------------------------ % if Cond holds, provides warning message Msg, otherwise fails % ------------------------------------------------------------------------------ if_warning_else_fail(Msg,Cond):- if_warning(Msg,Cond), Cond. % ------------------------------------------------------------------------------ % if_warning(Msg,Cond) % ------------------------------------------------------------------------------ % if condition Cond holds, prints out Msg; always succeeds % ------------------------------------------------------------------------------ if_warning(Msg,Cond):- telling(FileName), tell(user), ( Cond, write_list([' *Warning: '|Msg]), ttynl,ttynl, fail ; told, tell(FileName) ). % ------------------------------------------------------------------------------ % write_list(Xs) % ------------------------------------------------------------------------------ % writes out elements of Xs with spaces between elements % ------------------------------------------------------------------------------ write_list([]). write_list([X|Xs]):- write(X), write(' '), write_list(Xs). % ------------------------------------------------------------------------------ % query_user(Query) % ------------------------------------------------------------------------------ % writes Query and then tries to read a y. from user % ------------------------------------------------------------------------------ query_user(QueryList):- ttynl, ttynl, write_list(QueryList), read(y). % ------------------------------------------------------------------------------ % duplicated(X,Xs) % ------------------------------------------------------------------------------ % holds if X occurs more than once in Xsd % ------------------------------------------------------------------------------ duplicated(X,[X|Xs]):- member(X,Xs). duplicated(X,[_|Xs]):- duplicated(X,Xs). % ------------------------------------------------------------------------------ % feat_cycle(S:, Fs:) % ------------------------------------------------------------------------------ % holds if following the path Fs in the appropriateness definitions % leads from S to S. calls an auxiliary function which avoids infinite % loops and tracks the features so far followed in reverse with an accumulator % ------------------------------------------------------------------------------ feat_cycle(S,Fs):- feat_cycle2(S,S,[S],[],Fs). % ------------------------------------------------------------------------------ % feat_cycle2(S1:)>, % FsIn:, FsOut:) % ------------------------------------------------------------------------------ % assumes following reverse of FsIn led to S2 from S1, visiting % Ss along the way. FsOut is the result of appending a path that will % get from S2 back to S1 to the reverse of FsIn % ------------------------------------------------------------------------------ feat_cycle2(S1,S2,_Ss,FsIn,FsOut):- approp(F,S2,S1), reverse([F|FsIn],FsOut). feat_cycle2(S1,S2,Ss,FsIn,FsOut):- approp(F,S2,S3), \+ member(S3,Ss), feat_cycle2(S1,S3,[S2|Ss],[F|FsIn],FsOut). % ============================================================================== % Generator % ============================================================================== % ------------------------------------------------------------------------------ % split_dtrs(+Dtrs:s, -Head:, % -SemGoalBefore:, -SemGoalAfter:, % -DtrsBefore:, -DtrsAfter:s) % ------------------------------------------------------------------------------ % splits the RHS of a chain rule into Head, SemGoalBefore the Head, SemGoalAfter % the Head, DtrsBefore the Head, and DtrsAfter the Head % ------------------------------------------------------------------------------ split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,sem_goal> SemGoalAfter, DtrsAfter), Head,SemGoalBefore,SemGoalAfter,empty,DtrsAfter) :- !. split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,sem_goal> SemGoalAfter), Head,SemGoalBefore,SemGoalAfter,empty,empty) :- !. split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,DtrsAfter), Head,SemGoalBefore,empty,empty,DtrsAfter) :- !. split_dtrs((sem_goal> SemGoalBefore,sem_head> Head), Head,SemGoalBefore,empty,empty,empty) :- !. split_dtrs((sem_head> Head,sem_goal> SemGoalAfter,DtrsAfter), Head,empty,SemGoalAfter,empty,DtrsAfter) :- !. split_dtrs((sem_head> Head,sem_goal> SemGoalAfter), Head,empty,SemGoalAfter,empty,empty) :- !. split_dtrs((sem_head> Head,DtrsAfter),Head,empty,empty,empty,DtrsAfter) :- !. split_dtrs((sem_head> Head),Head,empty,empty,empty,empty) :- !. split_dtrs((Dtr,RestDtrs),Head,SemGoalBefore,SemGoalAfter, (Dtr,DtrsBefore),DtrsAfter) :- !, split_dtrs(RestDtrs,Head,SemGoalBefore,SemGoalAfter,DtrsBefore,DtrsAfter). % ------------------------------------------------------------------------------ % Run-time generation support % ------------------------------------------------------------------------------ % ------------------------------------------------------------------------------ % gen(+Cat:) % gen(+Tag:, +SVs:, +Iqs:) % ------------------------------------------------------------------------------ % top-level user calls to generate a sentence from a descriptor Cat % or a FS specified by Tag, SVs, Iqs % ------------------------------------------------------------------------------ gen(Cat) :- add_to(Cat,Tag,bot,[],Iqs), gen(Tag,bot,Iqs). gen(Tag,SVs,Iqs) :- % secret_noadderrs, nl, write('CATEGORY: '), nl, ttyflush, pp_fs(Tag-SVs,Iqs), nl, gen(Tag,SVs,Iqs,Words), nl, write('STRING: '), nl, write_list(Words), nl, query_proceed. %, % secret_adderrs % ------------------------------------------------------------------------------ % gen(+Tag:, +SVs:, +IqsIn:s, -Words:s) % ------------------------------------------------------------------------------ % top-level functional interface for the generator % generates the list of Words from the semantic specification of Tag-SVs,Iqs % ------------------------------------------------------------------------------ gen(Tag,SVs,IqsIn,Words) :- % fully_deref_prune(Tag,SVs,NewTag,NewSVs,IqsIn,IqsPrunned), generate(Tag,SVs,IqsIn,IqsOut,Words,[]), extensionalise(Tag,SVs,IqsOut), check_inequal(IqsOut,_). % ------------------------------------------------------------------------------ % generate(+Tag:, +SVs:, +IqsIn:s, -IqsOut:s, % +Words:s, +RestWords:s) % ------------------------------------------------------------------------------ % recursively generates the difference list Words-RestWords from the root % Tag-SVs,IqsIn % ------------------------------------------------------------------------------ generate(Tag,SVs,IqsIn,IqsOut,Words,RestWords) if_h [solve(GoalIndex,[GoalPivot],IqsIn,IqsMid), check_inequal(IqsMid,IqsMid2), non_chain_rule(PivotTag,bot,Tag,SVs,IqsMid2,IqsOut,Words, RestWords)] :- semantics(Pred), functor(GoalIndex,Pred,2), arg(1,GoalIndex,Tag-SVs), arg(2,GoalIndex,IndexTag-bot), functor(GoalPivot,Pred,2), arg(1,GoalPivot,PivotTag-bot), arg(2,GoalPivot,IndexTag-bot). % ------------------------------------------------------------------------------ % generate_list(+Sort:, +Vs:, +IqsIn:s, -IqsOut:s, % -Words:s, +RestWords:s) % ------------------------------------------------------------------------------ % generates a list of words Words-RestWords from a variable list of descriptions % Sort(Vs) % ------------------------------------------------------------------------------ generate_list(e_list,_,Iqs,Iqs,Words,Words) :- !. generate_list(Sort,[HdFS,TlFS],IqsIn,IqsOut,Words,RestWords) :- sub_type(ne_list,Sort), !,deref(HdFS,DtrTag,DtrSVs), generate(DtrTag,DtrSVs,IqsIn,IqsDtr,Words,MidWords), deref(TlFS,_,TlSVs), TlSVs =.. [TlSort|TlVs], generate_list(TlSort,TlVs,IqsDtr,IqsOut,MidWords,RestWords). generate_list(Sort,_,_,_,_,_) :- error_msg((nl,write('error: cats> value with sort, '),write(Sort), write(' is not a valid list argument'))). % ------------------------------------------------------------------------------ % Compiler % ------------------------------------------------------------------------------ :- dynamic current_chain_length/1. current_chain_length(4). % ------------------------------------------------------------------------------ % chain_length(N:) % ------------------------------------------------------------------------------ % asserts chain_length/1 to N -- controls depth of chain rules application % ------------------------------------------------------------------------------ chain_length(N):- retractall(current_chain_length(_)), assert(current_chain_length(N)). % ------------------------------------------------------------------------------ % non_chain_rule(+PivotTag:, % +PivotSVs:, +RootTag:, +RootSVs:, % +IqsIn:s, -IqsOut:s, % -Words:s, -RestWords:s) % ------------------------------------------------------------------------------ % compiles nonheaded grammar rules, lexical entries and empty categories into % non_chain_rule predicates which unifies the mother against the % PivotTag-PivotSVs FS, generates top-down the RHS, and connects the mother FS % to the next chain rule % the result Words-RestWords is the final list of words which includes the list % NewWords-RestNewWords corresponding to the expansion of the current rule % ------------------------------------------------------------------------------ non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs,IqsIn,IqsOut, Words,RestWords) if_b SubGoals :- current_predicate(empty,empty(_)), empty(Desc), compile_desc(Desc,PivotTag,PivotSVs,IqsIn,IqsMid,SubGoals, [check_inequal(IqsMid,IqsMid2), current_chain_length(Max), \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsMid2), chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsMid2, IqsOut,Words,Words,Words,RestWords)]). non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs,IqsIn,IqsOut, Words,RestWords) if_b SubGoals :- (secret_noadderrs,fail % turn off adderrs for lexical compilation ; current_predicate('--->', (_ ---> _)), (WordStart ---> DescStart), curr_lex_rule_depth(LRMax), gen_lex_close(0,LRMax,WordStart,DescStart,WordOut,DescOut,[],IqsLex), append(IqsLex,IqsIn,IqsMid), compile_desc(DescOut,PivotTag,PivotSVs,IqsMid,IqsMid2,SubGoals, [check_inequal(IqsMid2,IqsMid3), current_chain_length(Max), \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsMid3), chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsMid3, IqsOut,[WordOut|NewWords],NewWords,Words, RestWords)]) ; secret_adderrs,fail). % turn on again non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs,IqsIn,IqsOut, Words,RestWords) if_b PGoals :- current_predicate(rule, (_ rule _)), (_RuleName rule Mother ===> Dtrs), \+ split_dtrs(Dtrs,_,_,_,_,_), % i.e., not a chain rule compile_desc(Mother,PivotTag,PivotSVs,IqsIn,IqsMother, PGoals,[check_inequal(IqsMother,IqsMotherCkd), current_chain_length(Max), \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs, IqsMotherCkd) |PGoalsDtrs]), compile_gen_dtrs(Dtrs,IqsMotherCkd,IqsDtrs,HeadWords,RestHeadWords, PGoalsDtrs, [chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsDtrs, IqsOut,HeadWords,RestHeadWords,Words, RestWords)]). % ------------------------------------------------------------------------------ % chain_rule(+PivotTag:, +PivotSVs:, +RootTag:, +RootSVs:, % +IqsIn:s, -IqsOut:s, +HeadWords:s, % +RestHeadWords:s, -Words:s, RestWords:s) % ------------------------------------------------------------------------------ % compiles headed grammar rules into chain_rule predicates which unify the head % agains the PivotTag-PivotSVS FS, generates top-down the rest of the RHS, % and connects the mother FS to the next chain rule % the result is the list Words-RestWords which includes the sublist % HeadWords-RestHeadWords corresponding to the head % ------------------------------------------------------------------------------ chain_rule(_,_,PivotTag,PivotSVs,RootTag,RootSVs,IqsIn,IqsOut, Words,RestWords,Words,RestWords) if_b [ud(PivotTag,PivotSVs,RootTag,RootSVs,IqsIn,IqsOut)]. chain_rule(N,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsIn,IqsOut, HeadWords,RestHeadWords,Words,RestWords) if_b [N < Max|PGoalsSGBefore] :- current_predicate(rule,(_ rule _)), (_RuleName rule Mother ===> Dtrs), split_dtrs(Dtrs,Head,SGBefore,SGAfter,DtrsBefore,DtrsAfter), ((SGBefore == empty) -> IqsSGBefore = IqsIn, PGoalsHead = PGoalsSGBefore ; compile_body(SGBefore,[],[],IqsIn,IqsSGBefore,PGoalsSGBefore,PGoalsHead)), compile_desc(Head,PivotTag,PivotSVs,IqsSGBefore,IqsHead,PGoalsHead, [check_inequal(IqsHead,IqsHeadCkd)|PGoalsMother]), ((SGAfter == empty) -> IqsSGAfter = IqsHeadCkd, PGoalsSGAfter = PGoalsMother ; compile_body(SGAfter,[],[],IqsHeadCkd,IqsSGAfter,PGoalsMother, PGoalsSGAfter)), compile_desc(Mother,MotherTag,bot,IqsSGAfter,IqsMother,PGoalsSGAfter, [check_inequal(IqsMother,IqsMotherCkd), SN is N + 1, \+ \+ chained(SN,Max,MotherTag,bot,RootTag,RootSVs, IqsMotherCkd) |PGoalsLeft]), compile_gen_dtrs(DtrsBefore,IqsMotherCkd,IqsDtrsBefore,NewWords,HeadWords, PGoalsLeft,PGoalsRight), compile_gen_dtrs(DtrsAfter,IqsDtrsBefore,IqsDtrsAfter, RestHeadWords,RestNewWords,PGoalsRight, [chain_rule(SN,Max,MotherTag,bot,RootTag,RootSVs, IqsDtrsAfter,IqsOut,NewWords,RestNewWords,Words, RestWords)]). % ------------------------------------------------------------------------------ % compile_gen_dtrs(+Dtrs:, +IqsIn:s, -IqsOut:s, % -Words:s, -RestWords:s, % -Goals:s, -GoalsRest:s) % ------------------------------------------------------------------------------ % compiles the top-down expansion of a sequence Dtrs of RHS items % (daughters or goals) % ------------------------------------------------------------------------------ compile_gen_dtrs(empty,IqsIn,IqsIn,Words,Words,PGoals,PGoals) :- !. compile_gen_dtrs((cat> Dtr),IqsIn,IqsOut,Words,RestWords, PGoalsDtr,PGoalsRest) :- !,compile_desc(Dtr,Tag,bot,IqsIn,IqsDtr,PGoalsDtr, [check_inequal(IqsDtr,IqsDtrCkd), generate(Tag,bot,IqsDtrCkd,IqsOut,Words,RestWords) |PGoalsRest]). compile_gen_dtrs((cat> Dtr,RestDtrs),IqsIn,IqsOut,Words,RestWords, PGoalsDtr,PGoalsRest) :- !,compile_desc(Dtr,Tag,bot,IqsIn,IqsDtr,PGoalsDtr, [check_inequal(IqsDtr,IqsDtrCkd), generate(Tag,bot,IqsDtrCkd,IqsRest,Words,WordsMid) |PGoalsDtrs]), compile_gen_dtrs(RestDtrs,IqsRest,IqsOut,WordsMid,RestWords, PGoalsDtrs,PGoalsRest). compile_gen_dtrs((goal> Goal),IqsIn,IqsOut,Words,Words, PGoalsBody,PGoalsRest) :- !,compile_body(Goal,[],[],IqsIn,IqsOut,PGoalsBody,PGoalsRest). compile_gen_dtrs((goal> Goal,RestDtrs),IqsIn,IqsOut,Words,RestWords, PGoalsBody,PGoalsRest) :- !,compile_body(Goal,[],[],IqsIn,IqsBody,PGoalsBody,PGoalsDtrs), compile_gen_dtrs(RestDtrs,IqsBody,IqsOut,Words,RestWords, PGoalsDtrs,PGoalsRest). compile_gen_dtrs((cats> Dtrs),IqsIn,IqsOut,Words,RestWords, PGoalsDtrs,PGoalsRest) :- !,compile_desc(Dtrs,Tag,bot,IqsIn,IqsList,PGoalsDtrs, [check_inequal(IqsList,IqsListCkd), deref(Tag,bot,_,SVs), SVs =.. [Sort|Vs], generate_list(Sort,Vs,IqsListCkd,IqsOut,Words,RestWords) |PGoalsRest]). compile_gen_dtrs((cats> Dtrs,RestDtrs),IqsIn,IqsOut,Words,RestWords, PGoalsDtrs,PGoalsRest) :- !,compile_desc(Dtrs,Tag,bot,IqsIn,IqsList,PGoalsDtrs, [check_inequal(IqsList,IqsListCkd), deref(Tag,bot,_,SVs), SVs =.. [Sort|Vs], generate_list(Sort,Vs,IqsListCkd,IqsGen,Words,NewWords) |PGoalsRestDtrs]), compile_gen_dtrs(RestDtrs,IqsGen,IqsOut,NewWords,RestWords, PGoalsRestDtrs,PGoalsRest). % ------------------------------------------------------------------------------ % chained(+PivotTag:, +PivotSVs:, +RootTag:, % +RootSVs:, +IqsIn:s, -IqsOut:s) % ------------------------------------------------------------------------------ % checks whether PivotTag-PivotSVs and RootTag-RootSVs can be connected through % a chain of grammar rules % ------------------------------------------------------------------------------ chained(_,_,PivotTag,PivotSVs,RootTag,RootSVs,Iqs) if_b [ud(PivotTag,PivotSVs,RootTag,RootSVs,Iqs,_)]. chained(N,Max,PivotTag,PivotSVs,RootTag,RootSVs,IqsIn) if_b [N Body), split_dtrs(Body,HeadIn,_,_,_,_), compile_desc(HeadIn,PivotTag,PivotSVs,IqsIn,IqsHead,PGoals, [check_inequal(IqsHead,IqsHeadCkd)|PGoalsPivot]), compile_desc(Mother,NewPTag,bot,IqsHeadCkd,IqsMother,PGoalsPivot, [check_inequal(IqsMother,IqsMotherCkd), SN is N + 1, chained(SN,Max,NewPTag,bot,RootTag,RootSVs,IqsMotherCkd)]). % ------------------------------------------------------------------------------ % gen_lex_close(+N:, +Max:, +WordIn:, +MotherIn:, % +DtrsIn:s, +IqsIn:s, -IqsOut:s, % -MotherOut:, -DtrsOut:s) % ------------------------------------------------------------------------------ % computes the closure of lexical entries under lexical rules to get additional % lexical grammar rules MotherOut ===> DtrsOut % ------------------------------------------------------------------------------ gen_lex_close(_,_,Word,Desc,Word,Desc,Iqs,Iqs). gen_lex_close(N,Max,WordStart,DescStart,WordEnd,DescEnd,IqsIn,IqsOut) :- current_predicate(lex_rule,(_ lex_rule _)), N < Max, add_to(DescStart,TagIn,bot,IqsIn,IqsMid), ( (_RuleName lex_rule DescIn **> DescOut morphs Morphs), Cond = true ; (_RuleName lex_rule DescIn **> DescOut if Cond morphs Morphs) ), deref(TagIn,bot,DTagIn,DSVs), add_to(DescIn,DTagIn,DSVs,IqsMid,IqsMid2), mg_sat_goal(Cond,Goal,IqsMid2,IqsMid3), solve(Goal,[],IqsMid3,IqsMid4), check_inequal(IqsMid4,IqsMid5), morph(Morphs,WordStart,WordOut), SN is N + 1, gen_lex_close(SN,Max,WordOut,DescOut,WordEnd,DescEnd,IqsMid5,IqsOut). % ------------------------------------------------------------------------------ :- nl,write(' ALE Version 3.1.1; November, 1998 Copyright (C) 1998, Bob Carpenter and Gerald Penn All rights reserved'),nl, nointerp, nosubtest, parse, assert(lexicon_consult).