<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">% ==============================================================================
% 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 *-&gt; 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,===&gt;).
:-op(1150,xfx,---&gt;).
:-op(1150,xfx,macro).
:-op(1150,xfx,+++&gt;).
:-op(1150,fx,empty).
:-op(1175,xfx,rule).
:-op(1175,xfx,lex_rule).
:-op(1160,xfx,morphs).
:-op(1125,xfx,'**&gt;').
:-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:&lt;type&gt; sub Types:&lt;type&gt;s intro FRs:&lt;fv&gt;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:&lt;type&gt; sub_def Types:&lt;type&gt;s intro FRs:&lt;fv&gt;s
% ------------------------------------------------------------------------------
%  Same as sub except these are asserted by the default type preprocessors
% ------------------------------------------------------------------------------

% Type:&lt;type&gt; subs Types:&lt;types&gt;s intro FRs:&lt;fv&gt;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)
  -&gt; ( T sub_def Ts
     ; T sub Ts,
       \+ T sub_def _)
   ; (T sub_def Ts
      -&gt; true
       ; T sub Ts).
     

% ------------------------------------------------------------------------------
% Type:&lt;type&gt; cons Cons:&lt;desc&gt; goal Goal:&lt;goal&gt;                             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:&lt;type&gt;)                                                         eval
% ------------------------------------------------------------------------------
% Type is a type
% ------------------------------------------------------------------------------
type(Type):- 
    Type subs _.
type(a_ _).

% ------------------------------------------------------------------------------
% immed_subtypes(Type:&lt;type&gt;, SubTypes:&lt;type&gt;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:&lt;type&gt;, TypeSub:&lt;type&gt;)                                 eval
% ------------------------------------------------------------------------------
% TypeSub is immediate subtype of Type 
% ------------------------------------------------------------------------------
imm_sub_type(Type,TypeSub):-
  immed_subtypes(Type,TypeSubs),
  member(TypeSub,TypeSubs).

% ------------------------------------------------------------------------------
% immed_cons(Type:&lt;type&gt;,Cons:&lt;desc&gt;)
% ------------------------------------------------------------------------------
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
   -&gt; Cons = none
   ;(Type cons Cons goal _ -&gt; true ; Type cons Cons)).
  
% ------------------------------------------------------------------------------
% sub_type(Type:&lt;type&gt;, TypeSub:&lt;type&gt;)                                    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:&lt;type&gt;, Type2:&lt;type&gt;, TypeLUB:&lt;type&gt;)                   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 @&lt; 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:&lt;types&gt;, SsTemp:&lt;types&gt;, SsMin:&lt;types&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;type&gt;s, S:&lt;type&gt;, Ss2:&lt;type&gt;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:&lt;type&gt;s, Type:&lt;type&gt;)                                
% ------------------------------------------------------------------------------
% Type is unification of Types
% ------------------------------------------------------------------------------
unify_types([],bot).
unify_types([Type|Types],TypeUnif):-
  unify_types(Types,Type,TypeUnif).

% ------------------------------------------------------------------------------
% unify_types(Types:&lt;type&gt;s, Type:&lt;type&gt;, TypeUnif:&lt;type&gt;)                
% ------------------------------------------------------------------------------
% 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:&lt;sort)
% ------------------------------------------------------------------------------
% Sort is an extensional sort.  Extensional sorts are assumed to be maximal.
% ------------------------------------------------------------------------------


% ==============================================================================
% Appropriateness
% ==============================================================================

% ------------------------------------------------------------------------------
% feature(F:&lt;feat&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;type&gt;, Feat:&lt;feat&gt;, TypeRestr:&lt;type&gt;)                     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:&lt;feat&gt;, -Type:&lt;type&gt;)                                      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:&lt;feat&gt;, Type:&lt;type&gt;, TypeRestr:&lt;type&gt;)                       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:&lt;type&gt;, FRs:&lt;feat_val&gt;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:&lt;type&gt;,Fs:&lt;feat&gt;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:&lt;fs&gt;, FS2:&lt;fs&gt;, IqsIn:&lt;ineq&gt;s, IqsOut:&lt;ineq&gt;s)                     eval
% ------------------------------------------------------------------------------
% unifies FS1 and FS2 (after dereferencing); 
% ------------------------------------------------------------------------------
ud(FS1,FS2,IqsIn,IqsOut):-
  deref(FS1,Ref1,SVs1), deref(FS2,Ref2,SVs2),
  ( (Ref1 == Ref2) -&gt; (IqsOut = IqsIn)
                    ; u(SVs1,SVs2,Ref1,Ref2,IqsIn,IqsOut)
  ).

% ud(FS:&lt;fs&gt;,Tag:&lt;ref&gt;,SVs:&lt;svs&gt;,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s)
% ------------------------------------------------------------------------------
% 5-place version of ud/4
% ------------------------------------------------------------------------------

ud(FS1,Tag2,SVs2,IqsIn,IqsOut) :-
  deref(FS1,RefOut1,SVsOut1), deref(Tag2,SVs2,RefOut2,SVsOut2),
  ( (RefOut1 == RefOut2) -&gt; (IqsOut = IqsIn)
                          ; u(SVsOut1,SVsOut2,RefOut1,RefOut2,IqsIn,IqsOut)
  ).

% ud(Tag1:&lt;ref&gt;,SVs1:&lt;svs&gt;,Tag2:&lt;ref&gt;,SVs2:&lt;svs&gt;,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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) -&gt; (IqsOut = IqsIn)
                          ; u(SVsOut1,SVsOut2,RefOut1,RefOut2,IqsIn,IqsOut)
  ).

% ------------------------------------------------------------------------------
% deref(FSIn:&lt;fs&gt;, RefOut:&lt;ref&gt;, SVsOut:&lt;svs&gt;)
% ------------------------------------------------------------------------------
% RefOut-SVsOut is result of dereferencing FSIn at top level
% ------------------------------------------------------------------------------
deref(Ref-Vs,RefOut,VsOut):-
  ( var(Ref) -&gt; (RefOut = Ref, VsOut = Vs)
              ; deref(Ref,RefOut,VsOut)
  ).

% ------------------------------------------------------------------------------
% deref_list(RefsIn:&lt;ref&gt;s, RefsOut:&lt;ref&gt;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:&lt;ref&gt;,SVsIn:&lt;svs&gt;, RefOut:&lt;ref&gt;, SVsOut:&lt;svs&gt;)
% ------------------------------------------------------------------------------
% RefOut-SVsOut is result of dereferencing FSIn at top level
% ------------------------------------------------------------------------------
deref(Ref,Vs,RefOut,VsOut):-
  ( var(Ref) -&gt; (RefOut = Ref, VsOut = Vs)
              ; deref(Ref,RefOut,VsOut)
  ).

% ------------------------------------------------------------------------------
% fully_deref_prune(RefIn:&lt;ref&gt;,SVsIn:&lt;svs&gt;, RefOut:&lt;ref&gt;, SVsOut:&lt;svs&gt;, 
%                   IqsIn:&lt;ineq&gt;s, IqsOut:&lt;ineq&gt;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)
   -&gt; ((InFlag2 = out)           % both are out
       -&gt; 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))  
         -&gt; 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))
       -&gt; 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_ _) -&gt; (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:&lt;ref&gt;,SVsIn:&lt;svs&gt;, RefOut:&lt;ref&gt;, SVsOut:&lt;svs&gt;)
% ------------------------------------------------------------------------------
% RefOut-SVsOut is result of recursively dereferencing FSIn;
% destroys RefIn-SVsIn by overwriting Tags
% ------------------------------------------------------------------------------
fully_deref(Tag,SVs,TagOut,SVsOut):-
  ( nonvar(Tag) -&gt; fully_deref_act(Tag,SVs,TagOut,SVsOut)
                 ; Tag = (fully(TagOut,SVsOut)-SVsOut),
                   ((SVs = a_ X) -&gt; 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:&lt;svs&gt;,SVs2:&lt;svs&gt;,Ref1:&lt;ref&gt;,Ref2:&lt;ref&gt;,IqsIn:&lt;ineq&gt;s,
%   IqsOut:&lt;ineqs&gt;)                                                        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)
    -&gt; (Ref1 = Ref2,
        map_feats_eq(FRs1,Vs1,Vs2,IqsIn,IqsOut,SubGoals))
     ; approps(Type2,FRs2),                % Type1 \== Type2,
       ( (Type2 = Type3)
         -&gt; (Ref1 = Ref2-SVs2,
             map_feats_subs(FRs1,FRs2,Vs1,Vs2,IqsIn,IqsOut,SubGoals))
          ; ((Type1 = Type3)
             -&gt; (Ref2 = Ref1-SVs1,
                 map_feats_subs(FRs2,FRs1,Vs2,Vs1,IqsIn,IqsOut,SubGoals))
              ; (Ref1 = Tag3-SVs3, Ref2 = Ref1, % Type1\==Type3,Type2 \== Type3
		 (((FRs2 = []),(FRs1 = []))
		  -&gt; (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:&lt;type&gt;,ExclType1:&lt;type&gt;,ExclType2:&lt;type&gt;,Tag:&lt;ref&gt;,SVs:&lt;sv&gt;s,
%       IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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:&lt;type&gt;,Tag:&lt;ref&gt;,SVs:&lt;sv&gt;s,Goals:&lt;goal&gt;s,Rest:&lt;goal&gt;s,IqsIn:&lt;ineq&gt;s,
%    IqsOut,&lt;ineq&gt;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:&lt;type&gt;s,Tag:&lt;ref&gt;,SVs:&lt;sv&gt;s,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,
%          SubGoals:&lt;goal&gt;s,SubGoalsRest:&lt;goal&gt;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:&lt;type&gt;,VisIn:&lt;type&gt;s,VisOut:&lt;type&gt;s,TopIn:&lt;type&gt;s,
%          TopOut:&lt;type&gt;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)
  -&gt; (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:&lt;feat&gt;s,Vs1:&lt;fs&gt;s,Vs2:&lt;fs&gt;s,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,
%              Goals:&lt;goal&gt;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:&lt;feat&gt;s, FRs2:&lt;feat&gt;s, Vs1:&lt;fs&gt;s, Vs2:&lt;fs&gt;s, 
%                IqsIn:&lt;ineq&gt;s, IqsOut:&lt;ineq&gt;s, Goals:&lt;goal&gt;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:&lt;feat&gt;, FRs:&lt;feat&gt;s, V:&lt;fs&gt;, Vs:&lt;fs&gt;s, 
%                FRsOut:&lt;feat&gt;s, VsOut:&lt;fs&gt;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:&lt;feat&gt;s,FRs2:&lt;feat&gt;s,FRs3:&lt;feat&gt;s,Vs1:&lt;fs&gt;s,Vs2:&lt;fs&gt;s,
%                 Vs3:&lt;fs&gt;s,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,Goals:&lt;goal&gt;s,
%                 GoalsRest:&lt;goal&gt;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(&lt;,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(&gt;,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:&lt;feat&gt;s, FRsNew:&lt;feat&gt;s, Vs:&lt;fs&gt;s, VsNew:&lt;fs&gt;s, 
%               IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,Gs:&lt;goal&gt;s,GsRest:&lt;goal&gt;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)
    -&gt; (SubGoals = SubGoalsRest,
        IqsOut = IqsIn)
     ; ((TypeRestrNew = a_ X)
        -&gt; (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)
%  -&gt; 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)
%  -&gt; 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 **&gt; DescOut morphs Morphs),
    Cond = true
  ; (_LexRuleName lex_rule DescIn **&gt; 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:&lt;seq(&lt;morph&gt;)&gt;, 
%             CharsIn:&lt;list(&lt;char&gt;)&gt;, CharsOut:&lt;list(&lt;char&gt;)&gt;)
% ------------------------------------------------------------------------------
% 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) 
    -&gt; true
     ; morph_chars(Morphs,CharsIn,CharsOut).
morph_chars(Morph,CharsIn,CharsOut):-
  morph_template(Morph,CharsIn,CharsOut).

% ------------------------------------------------------------------------------
% morph_template(Morph:&lt;morph&gt;, CharsIn:&lt;chars&gt;, CharsOut:&lt;chars&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;pattern&gt;,Chars:&lt;list(&lt;char&gt;)&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;atomic_pattern&gt;,List:&lt;list(&lt;char&gt;)&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;list(&lt;ascii&gt;)&gt;, CharList:&lt;list(&lt;char&gt;)&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;desc&gt;, Tag:&lt;tag&gt;, SVs:&lt;svs&gt;, IqsIn:&lt;ineq&gt;s, IqsOut:&lt;ineq&gt;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 -&gt; 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 -&gt; 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)
    -&gt; IqsOut = IqsMid
     ; ((IqOut \== done)
        -&gt; IqsOut = [IqOut|IqsMid]
         ; (suppress_adderrs 
            -&gt; 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
      -&gt; 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
      -&gt; 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:&lt;desc&gt;s,FSs:&lt;fs&gt;s,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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:&lt;desc&gt;s,FSs:&lt;fs&gt;s,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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:&lt;path&gt;,TagIn:&lt;tag&gt;,SVsIn:&lt;svs&gt;,TagOut:&lt;tag:,SVsOut:&lt;svs&gt;,
%         IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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
      -&gt; 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:&lt;type&gt;,SVs:&lt;svs&gt;,Ref:&lt;ref&gt;,IqsIn:&lt;ineq&gt;s,
%             IqsOut:&lt;ineq&gt;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
    -&gt; (same_length(FRs2,Vs2),
        SubGoals = [],
        IqsOut = IqsIn)
   ; ((FRs2 = [])        % if Type2 is atomic, then we can use MGSat for Type3
      -&gt; (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 = [])
           -&gt; SVs3 = Type3
            ; (SVs4 =.. [Type3|Vs3],
               SVs3 = SVs4)),
          Ref = (Tag3-SVs3))
  )),
  SVs2 =.. [Type2|Vs2].

% ------------------------------------------------------------------------------
% add_to_typecons(Type:&lt;type&gt;,ExclType:&lt;type&gt;,Tag:&lt;ref&gt;,SVs:&lt;sv&gt;s,
%                 IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,SubGoals:&lt;goal&gt;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:&lt;feat&gt;,SVs:&lt;SVs&gt;,Ref:&lt;ref&gt;,V:&lt;fs&gt;,
%         IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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:&lt;fs&gt;, FS2:&lt;fs&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;fs_seq&gt;)
% ------------------------------------------------------------------------------
% takes structure &lt;fs_seq&gt; 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)
    -&gt; 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:&lt;ref&gt;, SVs:&lt;svs&gt;, Iqs:&lt;iqs&gt;)
%-------------------------------------------------------------------------------
% 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:&lt;ext&gt;s,ExtQ:&lt;ext&gt;s,Ref:&lt;ref&gt;,SVs:&lt;svs&gt;,FSs:&lt;fs&gt;s,
%           Ineqs:&lt;ineq&gt;s,Iqs:&lt;iq&gt;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_ _)
  -&gt; 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:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;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)
    -&gt; check_inequal_conjunct(IqInRest,IqOut,Result)
     ; ((SVs1 = a_ X) % fold in results of unify_type/3 and atom extensionality
        -&gt; ((SVs2 = a_ Y)
            -&gt; ((X==Y)
                -&gt; check_inequal_conjunct(IqInRest,IqOut,Result) 
                 ; ((\+ \+(X=Y))
                    -&gt; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest),
                        check_inequal_conjunct(IqInRest,IqOutRest,Result))
                     ; (Result = succeed)))
             ; (functor(SVs2,Sort2,_),
                ((Sort2 \== bot)
                 -&gt; Result = succeed
                  ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest),
                     check_inequal_conjunct(IqInRest,IqOutRest,Result)))))
         ; ((SVs2 = a_ _)
            -&gt; (functor(SVs1,Sort1,_),
                ((Sort1 \== bot)
                 -&gt; 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,_)
                 -&gt; (check_sub_seq(SVs1,SVs2,IqInRest,IqOut,Result)
                     -&gt; 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:&lt;type&gt;,Vs:&lt;vs&gt;,Tag:&lt;var&gt;,SVs:&lt;svs&gt;,Right:&lt;int&gt;,N:&lt;int&gt;,
%            Dtrs:&lt;ints&gt;,DtrsRest:&lt;var&gt;,NextRight:&lt;int&gt;,
%            IqsIn:&lt;iqs&gt;,IqsOut:&lt;iqs&gt;)
% ------------------------------------------------------------------------------
% 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&gt; value with sort, '),write(Sort),
            write(' is not a valid list argument'))).

% ------------------------------------------------------------------------------
% match_list_rest(Sort&lt;type&gt;,Vs:&lt;vs&gt;,Right:&lt;int&gt;,NewRight:&lt;int&gt;,
%                 DtrsRest:&lt;ints&gt;,DtrsRest2:&lt;var&gt;,IqsIn:&lt;iqs&gt;,IqsOut:&lt;iqs&gt;)
% ------------------------------------------------------------------------------
% 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&gt; value with sort, '),write(Sort),
            write(' is not a valid list argument'))).


% ==============================================================================
% Chart Parser
% ==============================================================================

% ------------------------------------------------------------------------------
% rec(+Ws:&lt;word&gt;s, Tag:&lt;var_tag&gt;, SVs:&lt;svs&gt;, Iqs:&lt;ineq&gt;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:&lt;word&gt;s, Tag:&lt;var_tag&gt;, SVs:&lt;svs&gt;, Iqs:&lt;ineq&gt;s, ?Desc:&lt;desc&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;word&gt;s, Right:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;int&gt;, Right:&lt;int&gt;, Tag:&lt;var_tag&gt;, SVs:&lt;svs&gt;, 
%                Iqs:&lt;ineq&gt;s,Dtrs:&lt;fs&gt;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)
   -&gt; 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)
   -&gt; 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 &gt;= 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:&lt;int&gt;,Right:&lt;int&gt;,Tag:&lt;var_tag&gt;,SVs:&lt;svs&gt;,Iqs:&lt;ineq&gt;s,
%          Dtrs:&lt;int&gt;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,&lt;,&gt;,LReln,RReln,[],[]),
  subsumed_act(RReln,LReln,EI,Tag,SVs,Iqs,Dtrs,RuleName,Left,Right).

subsumed_act(&gt;,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(#,&lt;,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 &lt; 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 &gt; 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(&lt;,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)) 
   -&gt; (Sort = (a_ X),Vs=[])
    ; SVs =.. [Sort|Vs]),
  ((ESVs = (a_ X)) 
   -&gt; (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(&lt;,#,_,#,#,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !.
subsume_type_act(&lt;,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(&gt;,_,#,#,#,_,_,_,_,_,_,_,_,_,_,_,_,_) :- !.
subsume_type_act(&gt;,_,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 =,&lt;,&gt;, or # based on subsumption comparison of Sort1 and Sort2
% ------------------------------------------------------------------------------
sub_type_reln(Sort,ESort,Reln) :-
  sub_type(Sort,ESort),
  !,(sub_type(ESort,Sort) -&gt; (Reln = '=')   % can't use unification for =
                           ; (Reln = '&lt;')). % because of poss. atom subsumption
sub_type_reln(Sort,ESort,&gt;) :-
  sub_type(ESort,Sort),
  !.
sub_type_reln(_,_,#).


% edge_discard(LReln:&lt;var&gt;/#,I:&lt;int&gt;,Tag:&lt;var_tag&gt;,SVs:&lt;sv&gt;s,Iqs:&lt;ineq&gt;s,
%             Dtrs:&lt;int&gt;s,RuleName,Left:&lt;int&gt;,Right:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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(&lt;,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:&lt;int&gt;,I:&lt;int&gt;,Tag:&lt;var_tag&gt;,SVs:&lt;svs&gt;,Iqs:&lt;ineq&gt;s,
%              Dtrs:&lt;int&gt;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)
   -&gt; 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 &gt;= 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 &gt; 1,
  NMinus1 is N-1,
  nth_index(Is,NMinus1,I,DLeft,DRight,DTag,DSVs,DIqs,DDtrs,DRule).


% ==============================================================================
% Functional Description Resolution/Compilation
% ==============================================================================

% fsolve(Fun:&lt;fun&gt;,Ref:&lt;ref&gt;,SVs:&lt;svs&gt;,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s)
% ------------------------------------------------------------------------------
%  Solve function constraint, Fun, along with its argument descriptions.
% ------------------------------------------------------------------------------
fsolve(_,_,_,_,_) if_b [fail] :-
  \+ current_predicate(+++&gt;,+++&gt;(_,_)).
fsolve(Fun,Tag,SVs,IqsIn,IqsOut) if_b Goals :-
  current_predicate(+++&gt;,+++&gt;(_,_)),
  (FHead +++&gt; 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:&lt;goal&gt;s,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s)
% ------------------------------------------------------------------------------
% Gs is list of goals to be called
% ------------------------------------------------------------------------------
solve([],Iqs,Iqs).
solve([Goal|TailGoals],IqsIn,IqsOut):-
  solve(Goal,TailGoals,IqsIn,IqsOut).

% ------------------------------------------------------------------------------
% solve(Goal:&lt;goal&gt;, TailGoals:&lt;goal&gt;s, IqsIn:&lt;ineq&gt;s, IqsOut:&lt;ineq&gt;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:&lt;goals&gt;,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,PGoals:&lt;prolog_goals&gt;,
%              PGoalsRest:&lt;prolog_goals&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;goal&gt;s, GoalsSeq:&lt;goal_seq&gt;)
% ------------------------------------------------------------------------------
%
% ------------------------------------------------------------------------------
goal_list_to_seq([],true).
goal_list_to_seq([G|Gs],GsSeq) :-
  ((G = true)
   -&gt; 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:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;word&gt;, Tag:&lt;var_tag&gt;, SVs:&lt;svs&gt;, IqsOut:&lt;ineq&gt;s)               mh(0)
% ------------------------------------------------------------------------------
% Word has category Tag-SVs
% ------------------------------------------------------------------------------
(lex(Word,Tag,SVs,IqsOut) if_h) :-
  (WordStart ---&gt; 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:&lt;word&gt;,TagIn:&lt;var_tag&gt;, SVsIn:&lt;svs&gt;,
%           WordOut:&lt;word&gt;,TagOut:&lt;var_tag&gt;, SVsOut:&lt;svs&gt;, IqsIn:&lt;ineq&gt;s,
%           IqsOut:&lt;ineq&gt;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 &lt; 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:&lt;var_tag&gt;, SVs:&lt;svs&gt;, Iqs:&lt;ineq&gt;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(&lt;Tag:&lt;var_tag&gt;, SVs:&lt;svs&gt;, Iqs:&lt;ineq&gt;s, Left:&lt;int&gt;, Right:&lt;int&gt;,
%           N:&lt;int&gt;)                                                       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 ===&gt; 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&gt; 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&gt; 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&gt; 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) -&gt;
          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&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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) -&gt;
         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&gt; or cats&gt; spec is found
% ------------------------------------------------------------------------------
compile_dtrs_rest((cat&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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&gt; 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:&lt;desc&gt;, FS:&lt;fs&gt;, IqsIn:&lt;ineq&gt;s, IqsOut:&lt;ineq&gt;s, 
%              Goals:&lt;goal&gt;s, GoalsRest:&lt;goal&gt;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)
   			         -&gt; 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) -&gt; 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:&lt;desc&gt;, Tag:&lt;ref&gt;, SVs:&lt;svs&gt;, IqsIn:&lt;ineq&gt;s, 
%              IqsOut:&lt;ineq&gt;s, Goals:&lt;goal&gt;s, GoalsRest:&lt;goal&gt;s)
% ------------------------------------------------------------------------------
% 7-place version of compile_desc/6
% ------------------------------------------------------------------------------
compile_desc(X,Tag2,SVs2,IqsIn,IqsOut,[(var(X)
      			               -&gt; 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) -&gt; 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:&lt;path&gt;,FSIn:&lt;fs&gt;,FSOut:&lt;fs&gt;,
%                 IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,
%                 Goals:&lt;goal&gt;s, GoalsRest:&lt;goal&gt;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:&lt;path&gt;,RefIn:&lt;ref&gt;,SVsIn:&lt;svs&gt;,FSOut:&lt;fs&gt;,
%                 IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,
%                 Goals:&lt;goal&gt;s, GoalsRest:&lt;goal&gt;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:&lt;fun&gt;,FS:&lt;fs&gt;,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,
%             Goals:&lt;goal&gt;s,GoalsRest:&lt;goal&gt;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:&lt;fun&gt;,Ref:&lt;ref&gt;,SVs:&lt;svs&gt;,IqsIn:&lt;ineq&gt;s,IqsOut:&lt;ineq&gt;s,
%             Goals:&lt;goal&gt;s,GoalsRest:&lt;goal&gt;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:&lt;file&gt;)
% ------------------------------------------------------------------------------
% 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) -&gt; % current_stream(File,_,S),
                          % seek(S,-1,current,_), % reset end_of_file
                          alec_catch(Code)
                        ; (Code = end_of_file)).

term_expansion((WordStart ---&gt; Desc),[(WordStart ---&gt; 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))
  -&gt; 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(('---&gt;')/2), abolish((sub)/2), 
  abolish((if)/2), abolish((macro)/2), 
  abolish((ext)/1), abolish((cons)/2),
  abolish((intro)/2),
  abolish((semantics)/1),
  abolish(('+++&gt;')/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 _) -&gt;
           [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 _) -&gt;
           [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) -&gt;
     (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(_)
   -&gt;( 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 -&gt;
   (Xs = (BotTypes intro BotIntros) -&gt;    % 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 _) -&gt; 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 _)) -&gt; assertz((_ sub _ :- fail)) ; true),
 (\+current_predicate(intro,(_ intro _)) -&gt; 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([]))
  -&gt; (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 _)) -&gt;
            [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 _))
    -&gt; 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(('---&gt;')/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 -&gt;
  alec_announce('Compiling lexical rules...'),
  ( [no,lexical,rules,found] if_warning_else_fail
        (\+ current_predicate(lex_rule,lex_rule(_,_)))
    -&gt; (Code = CodeRest)
     ; ([lexical,rule,RuleName,lacks,morphs,specification] if_error
          ((RuleName lex_rule _ **&gt; _ if _)
          ;(RuleName lex_rule _ **&gt; _)),
        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(('---&gt;')/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
  -&gt; (CodeStart = [(:- multifile (lex)/4),(:- dynamic (lex)/4)|Code])
   ; (CodeStart = Code)),
  abolish((lex)/4),
  secret_noadderrs,
  (parsing -&gt;
  alec_announce('Compiling lexicon...'),
  ( [no,lexicon,found] if_warning_else_fail
      (\+ current_predicate('---&gt;',(_ ---&gt; _)))
    -&gt; (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 = [_|_]
   -&gt; 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 = [_|_]
   -&gt; 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
  -&gt; (CodeStart = [(:- multifile (empty_cat)/3),
                   (:- dynamic (empty_cat)/3)|Code])
   ; (CodeStart = Code)),
  abolish((empty_cat)/3),
  secret_noadderrs,
  (parsing -&gt; (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(_,_)))
    -&gt; (Code = CodeRest)
  ; [rule,RuleName,has,no,'cat&gt;','cats&gt;',or,'sem_head&gt;',specification]
      if_error ((RuleName rule _ ===&gt; Body),
                \+ cat_member(Body),
                \+ cats_member(Body),
	        \+ sem_head_member(Body)),
    [rule,RuleName,has,multiple,'sem_head&gt;',specifications]
      if_error ((RuleName rule _ ===&gt; Body),
	        multiple_heads(Body)),
    [rule,RuleName,has,wrongly,placed,'sem_goal&gt;',specifications]
      if_error ((RuleName rule _ ===&gt; Body),
                bad_sem_goal(Body)),
    (parsing -&gt; multi_hash(0,(rule)/6,Code,CodeGen)
              ; (CodeGen = Code)),
  (generating -&gt;
   (( [no,chain,rules,found] if_warning_else_fail
         (\+ ((_ rule _ ===&gt; Body), split_dtrs(Body,_,_,_,_,_)))
      -&gt; (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 _ ===&gt; Body), \+ split_dtrs(Body,_,_,_,_,_)),
          \+ current_predicate(empty,empty(_)),
          \+ current_predicate('---&gt;',(_ ---&gt; _)))
      -&gt; (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 -&gt;
  alec_announce('Compiling semantics directive...'),
  (  [no,semantics,specification,found] if_warning_else_fail
      (\+ current_predicate(semantics,semantics(_)))
  -&gt; (Code = CodeRest)
  ; semantics(Pred), functor(Goal,Pred,2),
    ([no,Pred,definite,clause,found] if_warning_else_fail
      (\+ (current_predicate(if,(_ if _)), (Goal if _)))
    -&gt; (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(('+++&gt;')/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(+++&gt;,+++&gt;(_,_)))
  -&gt; (Code = [(fun(_) :- !,fail)|CodeRest])
  ;  (setof(Functor/Arity,F^((F +++&gt; _),        % 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&gt; _)).
cat_member((cat&gt; _, _)):-!.
cat_member((_,Body)):-
  cat_member(Body).

% ------------------------------------------------------------------------------
% sem_head_member(+Dtrs:&lt;desc&gt;s)
% ------------------------------------------------------------------------------
% true if Dtrs has at least one sem_head&gt; member
% ------------------------------------------------------------------------------
sem_head_member((sem_head&gt; _)).
sem_head_member((sem_head&gt; _,_)):-!.
sem_head_member((_,Body)):-
  sem_head_member(Body).

% ------------------------------------------------------------------------------
% sem_goal_member(+Dtrs:&lt;desc&gt;s)
% ------------------------------------------------------------------------------
% true if Dtrs has at least one sem_goal&gt; member
% ------------------------------------------------------------------------------
sem_goal_member((sem_goal&gt; _)).
sem_goal_member((sem_goal&gt; _,_)):-!.
sem_goal_member((_,Body)):-
  sem_goal_member(Body).

% ------------------------------------------------------------------------------
% cats_member(Dtrs)
% ------------------------------------------------------------------------------
% true if Dtrs has at least one cats member
% ------------------------------------------------------------------------------
cats_member((cats&gt; _)).
cats_member((cats&gt; _, _)):- !.  % doesn't check for cats&gt; [] or elist!
cats_member((_,Body)):-
  cats_member(Body).

% ------------------------------------------------------------------------------
% multiple_heads(+Dtrs:&lt;desc&gt;s)
% ------------------------------------------------------------------------------
% checks whether Dtrs has multiple sem_head&gt; members
% ------------------------------------------------------------------------------
multiple_heads((sem_head&gt; _,Dtrs)) :- !,
  sem_head_member(Dtrs).
multiple_heads((_,Dtrs)) :-
  multiple_heads(Dtrs).

% ------------------------------------------------------------------------------
% bad_sem_goal(+Dtrs:&lt;desc&gt;s)
% ------------------------------------------------------------------------------
% checks whether Dtrs has wrongly placed sem_goal&gt; members
% ------------------------------------------------------------------------------
bad_sem_goal(Dtrs) :-       % there's a sem_head
  split_dtrs(Dtrs,_,_,_,DtrsBefore,DtrsAfter), !,
  (sem_goal_member(DtrsBefore)
   -&gt; true
    ; sem_goal_member(DtrsAfter)).
bad_sem_goal(Dtrs) :-       % there's no sem_head
  sem_goal_member(Dtrs).

% ------------------------------------------------------------------------------
% if_h(Goal:&lt;goal&gt;, SubGoals:&lt;goal&gt;s)                                      +user
% ------------------------------------------------------------------------------
% accounts for multi-hash goals with no subgoals given
% ------------------------------------------------------------------------------
Goal if_h [] :-
  Goal if_h.

% ------------------------------------------------------------------------------
% multi_hash(N:&lt;int&gt;, Fun/Arity:&lt;fun_sym&gt;/&lt;int&gt;,Code:&lt;goals&gt;,CodeRest:&lt;goals&gt;)
% ------------------------------------------------------------------------------
% 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&gt;0
% ------------------------------------------------------------------------------

multi_hash(N,(Fun)/Arity,Code,CodeRest):-
  length(Args,Arity),
  Goal =.. [Fun|Args],
  ( setof(sol(Args,SubGoals), if_h(Goal,SubGoals), Sols)
    -&gt; 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 = []
    -&gt; (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 = []
   -&gt; (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))
    -&gt; (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 = []
     -&gt; (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:&lt;single_goal&gt;, Goals:&lt;single_goal&gt;s, Column:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;term&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;term&gt;, VarsIn:&lt;var&gt;s, VarsOut:&lt;var&gt;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:&lt;var&gt;s, N:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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)
    -&gt; ( select_eq(Var,Vars,VarsLeft)
         -&gt; (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:&lt;type&gt;)
% ------------------------------------------------------------------------------
% 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)
    -&gt; true
  ; SuperTypes = []
  ),
  nl, write('SUPERTYPES: '), write(SuperTypes),
  (current_predicate(cons,(_ cons _))
   -&gt; ((Type cons Cons goal _)
       -&gt; 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:&lt;type&gt;)
%-------------------------------------------------------------------------------
show_cons(Type):-
  immed_cons(Type,Cons),
  nl, write('Immediate Constraint for type: '),write(Type),
  nl, write(Cons).

% ------------------------------------------------------------------------------
% mgsat(Desc:&lt;desc&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;desc&gt;, Desc2:&lt;desc&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;word&gt;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:&lt;word&gt;s,Desc:&lt;desc&gt;)
% ------------------------------------------------------------------------------
% 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(&lt;word&gt;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(&lt;word&gt;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(&lt;word&gt;s),Desc,SolnsList:list(&lt;fs(FS,Iqs)&gt;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:&lt;word&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;goal_desc&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;name&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;int&gt;, M:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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 =&lt; N
  -&gt; 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 =&lt; 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:&lt;name&gt;)
% ------------------------------------------------------------------------------
% Displays lexical rule with name RuleName
% ------------------------------------------------------------------------------
lex_rule(RuleName):-
  \+ \+
  lexrule2(RuleName).

lexrule2(RuleName):-
  (( (RuleName lex_rule Desc1 **&gt; Desc2 if Cond morphs Morphs)
   ; (RuleName lex_rule Desc1 **&gt; 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)
     -&gt; 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:&lt;predspec&gt;)
% ------------------------------------------------------------------------------
% Displays definite clauses in feature structure format
% ------------------------------------------------------------------------------
show_clause(Spec):-
  \+ \+ show_clause2(Spec).

show_clause2(Spec):-
  (( Spec = Name/Arity
     -&gt; 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:&lt;name&gt;)
% ------------------------------------------------------------------------------
% Displays rule with name RuleName
% ------------------------------------------------------------------------------
rule(RuleName):-
  \+ \+
  ((RuleName rule Moth ===&gt; 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&gt; 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&gt; 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&gt; Cs)|Dtrs],VisIn,VisOut):-
  nl, nl, write('CATs '), pp_fs(Cs,VisIn,VisMid,5),
  show_rule_dtrs(Dtrs,VisMid,VisOut).
show_rule_dtrs([(goal&gt; 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&gt; 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 = []
    -&gt; 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&gt; Desc),[Tag-bot|DtrCatsRest],DtrCatsRest,
             [(cat&gt; Tag-bot)],IqsIn,IqsOut):-
  !, add_to(Desc,Tag,bot,IqsIn,IqsOut).
satisfy_dtrs((sem_head&gt; Desc),[Tag-bot|DtrCatsRest],DtrCatsRest,
             [(sem_head&gt; Tag-bot)],IqsIn,IqsOut):-
  !, add_to(Desc,Tag,bot,IqsIn,IqsOut).
satisfy_dtrs((cats&gt; Descs),[Tag-bot|DtrCatsRest],DtrCatsRest,
             [(cats&gt; Tag-bot)],IqsIn,IqsOut) :-
  !, add_to(Descs,Tag,bot,IqsIn,IqsOut).
satisfy_dtrs((goal&gt; GoalDesc),DtrCats,DtrCatsRest,
             [(goal&gt; Goal)],IqsIn,IqsOut):-
  !, satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut).
satisfy_dtrs((sem_goal&gt; GoalDesc),DtrCats,DtrCatsRest,
             [(sem_goal&gt; Goal)],IqsIn,IqsOut):-
  !, satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut).
satisfy_dtrs(((cat&gt; Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest,
             [(cat&gt; Tag-bot)|DtrsSats],IqsIn,IqsOut):-
  !, add_to(Desc,Tag,bot,IqsIn,IqsMid),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut).
satisfy_dtrs(((sem_head&gt; Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest,
             [(sem_head&gt; Tag-bot)|DtrsSats],IqsIn,IqsOut):-
  !, add_to(Desc,Tag,bot,IqsIn,IqsMid),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut).
satisfy_dtrs(((cats&gt; Descs),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest,
             [(cats&gt; Tag-bot)|DtrsSats],IqsIn,IqsOut):-
  !, add_to(Descs,Tag,bot,IqsIn,IqsMid),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,IqsMid,IqsOut).
satisfy_dtrs(((goal&gt; GoalDesc),Dtrs),DtrCats,DtrCatsRest,
              [goal&gt; 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&gt; GoalDesc),Dtrs),DtrCats,DtrCatsRest,
              [sem_goal&gt; 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:&lt;fs&gt;,Iqs:&lt;ineq&gt;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:&lt;fs&gt;, Iqs:&lt;ineq&gt;s, DupsIn:&lt;ref&gt;s, DupsOut:&lt;ref&gt;s, 
%            VisIn:&lt;ref&gt;s, VisOut:&lt;ref&gt;s, NumIn:&lt;int&gt;, NumOut:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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)
    -&gt; DupsOut = DupsIn, VisOut = VisIn, NumOut = NumIn
     ; (member_eq(Ref,VisIn)
        -&gt; (DupsOut = [Ref|DupsIn], VisIn = VisOut, 
            Ref = NumIn, NumOut is NumIn + 1)
         ; ((SVs = a_ _)
            -&gt; 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:&lt;ineq&gt;s, VisIn:&lt;var&gt;s, VisOut:&lt;var&gt;s,Col:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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 -&gt; true
   ;write('(')),
  pp_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),VisIn,VisMid,Col),
  (Ineqs = done -&gt; true
   ;write(')')),
  (Iqs = []
   -&gt; 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 -&gt; true
   ;write(';')),
  pp_ineq(Ineqs,VisMid2,VisOut,Col).

% ------------------------------------------------------------------------------
% pp_fs(FS:&lt;fs&gt;,VisIn:&lt;var&gt;s, VisOut:&lt;var&gt;s, Col:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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) -&gt; true                            % print ref if shared (nonvar)
  ; write('['), write(Ref), write(']'),
    ( member_eq(Ref,VisIn) -&gt; true
    ; write(' ')
    )
  ),
  ( member_eq(Ref,VisIn) 
    -&gt; VisOut = VisIn
     ; (SVs = a_ X)
       -&gt; (no_write_type_flag(a_ X)
           -&gt; true
            ; write(a_ X)
          ),
          VisOut = [Ref|VisIn]
        ; SVs =.. [Type|Vs],              % print FS if not already visited
          approps(Type,FRs),
          ( no_write_type_flag(Type)
            -&gt; 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:&lt;fs&gt;, FS2:&lt;d_fs&gt;)
% ------------------------------------------------------------------------------
% 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))
   -&gt; deref_pp(Ref,RefOut,SVsOut)
    ; RefOut = Ref, SVsOut = SVs.

% ------------------------------------------------------------------------------
% pp_vs(FRs:&lt;fs&gt;, Vs:&lt;vs&gt;, Dups:&lt;var&gt;s, 
%        VisIn:&lt;var&gt;s, VisOut:&lt;var&gt;s, Col:&lt;int&gt;)
% ------------------------------------------------------------------------------
% prints Vs at Col 
% ------------------------------------------------------------------------------
pp_vs([],[],Vis,Vis,_).
pp_vs([F:_|FRs],[V|Vs],VisIn,VisOut,Col):-
  ( no_write_feat_flag(F),
    VisMid = VisIn 
  -&gt; 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
  -&gt; 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 =&lt; X, X =&lt; Name_z)
    -&gt; 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:&lt;goal&gt;, Xs:&lt;list(Alpha)&gt;)
% ------------------------------------------------------------------------------
% setof returning empty list if no solutions
% ------------------------------------------------------------------------------
esetof(X,Goal,Xs) :-
  if(setof(X,Goal,Xs),
     true,
     (Xs = [])).

% ------------------------------------------------------------------------------
% member_eq(X:&lt;term&gt;, Xs:&lt;term&gt;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:&lt;term&gt;, Xs:&lt;term&gt;s)
%-------------------------------------------------------------------------------
% Ref-_ belongs to SortDom
%-------------------------------------------------------------------------------
member_ref_eq(Ref,SortDom) :-   %exactly this reference belongs
  member(SRef-_,SortDom),
  Ref == SRef.

% ------------------------------------------------------------------------------
% select_eq(X:&lt;term&gt;, Xs:&lt;term&gt;s, XsLeft:&lt;term&gt;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:&lt;list&gt;, Ys:&lt;list&gt;)
% ------------------------------------------------------------------------------
% checks that Xs and Ys are same length; instantiating if necessary
% ------------------------------------------------------------------------------
same_length([],[]).
same_length([_|Xs],[_|Ys]):-
  same_length(Xs,Ys).

% ------------------------------------------------------------------------------
% transitive_closure(Graph:&lt;graph&gt;, Closure:&lt;graph&gt;)
% ------------------------------------------------------------------------------
% Warshall's Algorithm (O'Keefe, Craft of Prolog, p. 172)
% Input: Graph = [V1-Vs1,...,VN-VsN]
%   describes the graph G = &lt;Vertices, Edges&gt; where
%      * Vertices = {V1,..,VN} and
%      * VsI = {VJ | VI -&gt; 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:&lt;list&gt;,Acc:&lt;list&gt;,ListOut:&lt;list&gt;,
%               CountIn:&lt;int&gt;,CountOut:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;goal&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;type&gt;, Fs:&lt;path&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;type), S2:&lt;type), Ss:&lt;list(&lt;type&gt;)&gt;, 
%             FsIn:&lt;path&gt;, FsOut:&lt;path&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;desc&gt;s, -Head:&lt;desc&gt;,
%            -SemGoalBefore:&lt;desc&gt;, -SemGoalAfter:&lt;desc&gt;,
%            -DtrsBefore:&lt;desc&gt;, -DtrsAfter:&lt;desc&gt;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&gt; SemGoalBefore,sem_head&gt; Head,sem_goal&gt; SemGoalAfter,
            DtrsAfter),
           Head,SemGoalBefore,SemGoalAfter,empty,DtrsAfter) :- !.
split_dtrs((sem_goal&gt; SemGoalBefore,sem_head&gt; Head,sem_goal&gt; SemGoalAfter),
           Head,SemGoalBefore,SemGoalAfter,empty,empty) :- !.
split_dtrs((sem_goal&gt; SemGoalBefore,sem_head&gt; Head,DtrsAfter),
           Head,SemGoalBefore,empty,empty,DtrsAfter) :- !.
split_dtrs((sem_goal&gt; SemGoalBefore,sem_head&gt; Head),
           Head,SemGoalBefore,empty,empty,empty) :- !.
split_dtrs((sem_head&gt; Head,sem_goal&gt; SemGoalAfter,DtrsAfter),
           Head,empty,SemGoalAfter,empty,DtrsAfter) :- !.
split_dtrs((sem_head&gt; Head,sem_goal&gt; SemGoalAfter),
           Head,empty,SemGoalAfter,empty,empty) :- !.
split_dtrs((sem_head&gt; Head,DtrsAfter),Head,empty,empty,empty,DtrsAfter) :- !.
split_dtrs((sem_head&gt; 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:&lt;desc&gt;)
% gen(+Tag:&lt;tag&gt;, +SVs:&lt;svs&gt;, +Iqs:&lt;ineq&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;tag&gt;, +SVs:&lt;svs&gt;, +IqsIn:&lt;ineq&gt;s, -Words:&lt;word&gt;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:&lt;tag&gt;, +SVs:&lt;svs&gt;, +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;s,
%          +Words:&lt;word&gt;s, +RestWords:&lt;word&gt;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:&lt;sort&gt;, +Vs:&lt;vs&gt;, +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;s,
%               -Words:&lt;word&gt;s, +RestWords:&lt;word&gt;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&gt; 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:&lt;int&gt;)
% ------------------------------------------------------------------------------
% 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:&lt;tag&gt;,
%                +PivotSVs:&lt;svs&gt;, +RootTag:&lt;tag&gt;, +RootSVs:&lt;svs&gt;,
%                +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;s,
%                -Words:&lt;word&gt;s, -RestWords:&lt;word&gt;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('---&gt;', (_ ---&gt; _)),
  (WordStart ---&gt; 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 ===&gt; 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:&lt;tag&gt;, +PivotSVs:&lt;svs&gt;, +RootTag:&lt;tag&gt;, +RootSVs:&lt;svs&gt;,
%            +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;s, +HeadWords:&lt;word&gt;s,
%            +RestHeadWords:&lt;word&gt;s, -Words:&lt;word&gt;s, RestWords:&lt;word&gt;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 &lt; Max|PGoalsSGBefore] :-
  current_predicate(rule,(_ rule _)),
  (_RuleName rule Mother ===&gt; Dtrs),
  split_dtrs(Dtrs,Head,SGBefore,SGAfter,DtrsBefore,DtrsAfter),
  ((SGBefore == empty)
  -&gt; 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)
  -&gt; 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:&lt;desc&gt;, +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;s,
%                  -Words:&lt;word&gt;s, -RestWords:&lt;word&gt;s,
%                  -Goals:&lt;goal&gt;s, -GoalsRest:&lt;goal&gt;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&gt; 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&gt; 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&gt; Goal),IqsIn,IqsOut,Words,Words,
                 PGoalsBody,PGoalsRest) :-
  !,compile_body(Goal,[],[],IqsIn,IqsOut,PGoalsBody,PGoalsRest).
compile_gen_dtrs((goal&gt; 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&gt; 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&gt; 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:&lt;tag&gt;, +PivotSVs:&lt;svs&gt;, +RootTag:&lt;tag&gt;,
%         +RootSVs:&lt;svs&gt;, +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;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&lt;Max|PGoals] :-
  current_predicate(rule,(_ rule _)),
  (_Rule rule Mother ===&gt; 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:&lt;int&gt;, +Max:&lt;int&gt;, +WordIn:&lt;word&gt;, +MotherIn:&lt;desc&gt;,
%               +DtrsIn:&lt;desc&gt;s, +IqsIn:&lt;ineq&gt;s, -IqsOut:&lt;ineq&gt;s,
%               -MotherOut:&lt;desc&gt;, -DtrsOut:&lt;desc&gt;s)
% ------------------------------------------------------------------------------
% computes the closure of lexical entries under lexical rules to get additional
% lexical grammar rules MotherOut ===&gt; 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 &lt; Max,
  add_to(DescStart,TagIn,bot,IqsIn,IqsMid),
  ( (_RuleName lex_rule DescIn **&gt; DescOut morphs Morphs),
    Cond = true
  ; (_RuleName lex_rule DescIn **&gt; 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).

</pre></body></html>