% [Documentation]
% ==============================================================================
% ALE -- Attribute Logic Engine
% ==============================================================================
% Version 3.3 --- alpha version
% Developed under: SICStus Prolog, Version 3.8.6

% Authors:

% Bob Carpenter
% ---------------------------
% SpeechWorks Research
% 55 Broad St.
% New York, NY 10004
% USA
% carp@colloquial.com
%
% Gerald Penn
% --------------------------------
% Department of Computer Science
% University of Toronto
% 10 King's College Rd.
% Toronto M5S 3G4
% Canada
% gpenn@cs.toronto.edu
%
% Copyright 1992-1995, Bob Carpenter and Gerald Penn
% Copyright 1998,1999,2001, Gerald Penn

% BUG FIX  12 JAN 1993 '|' changed to ',' in compile_body(!,.. -- Carpenter

% Extensional types added, using predicates from general constraint
%  resolver - extensionality checked in rules before every edge assertion
%  1/26/93 - G. Penn

% Added iso/2, plus code for compiling extensionality check.
%  2/2/93 - G. Penn

% Bug corrected:  extensionalise hung on cyclic feature structures.
%  2/15/93 - G. Penn

% Added inequations:  checked in rules before edge insertion and after every
%  recognised daughter description.  Inequation checking partially compiled, in
%  the manner of iso/2.
%  2/24/93 - G. Penn

% Added prolog-style inequation checking to procedural attachments.
%  2/25/93 - G. Penn

% Bug corrected: extensionalise did not handle feature structures with
%  shared structures
%  2/26/93 - G. Penn

% Interpreter added
%  2/26/93 - G. Penn

% Inequation pruning added (at time of full dereferencing)
%  3/3/93 - G. Penn

% Bug corrected: daughters list for parse tree was reversed
%  3/4/93 - G. Penn

% Structure-sharing marked in mother, daughters, and inequations in
%  interpreted mode.  Break command uses prolog "break".
%  3/4/93 - G. Penn

% Bug corrected: reload did not load .extensional.pl
%  3/4/93 - G. Penn

% Bug corrected: interpreter did not assert edges with variable tags.
%  3/4/93 - G. Penn

% Bug corrected: edge/2 printed nothing in non-interpreted mode, and did not
%  print inequations in interpreted mode.
%  3/6/93 - G. Penn

% Edge indices removed, and "trace" information incorporated into edge.  In
%  non-interpreted mode, extra information is uninstantiated.  Edge/2 will not
%  provide interpreter information for edges created while interpreter was
%  inactive
%  3/6/93 - G. Penn

% Inequation data-structure converted from ineq(Tag1-SVs1,Tag2-SVs2,Rest) to
%  ineq(Tag1,SVs1,Tag2,SVs2,Rest).
%  3/6/93 - G. Penn

% Bug corrected: extensionalise_list did not unify eligible structures from
%  different FSs in the given list
%  3/6/93 - G. Penn

% Extensionalise and extensionalise_list now extensionalise a given list of
%  inequations also (they don't check their consistency, however).
%  3/6/93 - G. Penn

% Bug corrected: nth_elt hung with input N <= 0.
%  3/12/93 - G. Penn

% Edges now indexed by a unique number, and daughters now stored by edge index.
%  3/12/93 - G. Penn

% General constraints added to types
%  3/17/93 - G. Penn

% Bug corrected: current_predicate needed to test existence of cons first in
%  compile_cons
%  3/29/93 - G. Penn

% Bug corrected: ud did not unify IqsIn and Out when tags were identical
%  3/29/93 - G. Penn

% Bug corrected: inequations were threaded through negated predicates in
%  compile_body
%  3/29/93 - G. Penn

% Bug corrected: quiet_interpreter mode not reset after parse is finished
%  (now reset by build and by clear).
%  3/29/93 - G. Penn

% cats> category added.  WARNING: Daughter indices not properly recorded for
%  initial cats> elements.
%  4/5/93 - G. Penn

% =\= converted to unary operator with general descriptions.  =@ added to
%  dcs language.
%  4/7/93 - G. Penn

% Bug corrected: find_exts_list terminating condition had too many arguments
%  4/13/93 - G. Penn

% Bug corrected: duplicates_list was passed the wrong FS in add_to
%  4/14/93 - G. Penn

% Bug corrected: lexical items were fully dereferenced and pruned before
%  lexical rules applied.  Now, after.
%  4/17/93 - G. Penn

% Empty categories now undergo lexical rules.
%  4/17/93 - G. Penn

% Bug corrected: add_to(Type,... used cut to prevent false error messages, but
%  also prevented backtracking to satisfy disjunctive constraints on Type.
%  4/17/93 - G. Penn

% Bug corrected: noadd option on query_edge_act did not have enough anonymous
%  arguments
%  4/19/93 - G. Penn

% Bug corrected: compile_body included the code for =@ on the solve list
%  rather than the prolog goal list.
%  4/19/93 - G. Penn

% Bug corrected: daughters of edges were not being printed with re-entrancy
%  intact, since edges were recorded by index and recalled from memory as
%  needed (which broke tag sharing).  Daughters are now printed with accurate
%  re-entrancy, although structure sharing between a daughter and a parent is
%  not indicated still.  Also, daughters of daughters, etc. are now available
%  from any parent edge.
%  4/24/93 - G. Penn

% Bug corrected: in pp_vs(_unwritten), when no_write_feat_flag(F) was detected,
%  the difference list for visited nodes was unlinked
%  4/24/93 - G. Penn

% Bug corrected: =\= had an operator precedence value higher than that of :,
%  and both =\= and : had precedence values lower than ==.
%  5/2/93 - G. Penn

% Bug corrected: extensionalise hung on cyclic feature structures
%  7/20/93 - G. Penn

% general hooks to prolog added (of the form prolog(Goal)).
%  7/20/93 - G. Penn

% option added to suppress error messages from add_to - disjunctive type
%  constraints can yield to many incompatible type messages before the
%  appropriate disjunct is found.  A check is also now made that every
%  word with a lexical description has a lexical entry.
%  7/20/93 - G. Penn

% rec/1 flushes buffer after printing CATEGORY (to allow more accurate timing
%  of rec/4).
%  7/20/93 - G. Penn

% disposed of unnecessary interpreter control code in interp.pl and renamed
%  secret_interp to secret_verbose.
%  10/26/93 - G. Penn

% Suppressing adderrs now automatic for compile_lex.  It remains an option
%  for other top-level predicates which usse add_to.  "Secret" versions of
%  control predicates added.
%  10/26/93 - G. Penn

% Bug corrected: cons/2 and cons/3 were not declared as dynamic.  Thus, the
%  user could not use certain top-level predicates such as show_type and
%  show_cons in signatures where no constraints existed.
%  10/26/93 - G. Penn

% Suppressing adderrs now automatic for compile_empty also.
%  11/20/93 - G. Penn

% Bug corrected: suppress_adderrs checks were not accompanied by fail.
%  11/23/93 - G. Penn

% dynamic no_interpreter added.  Helps non-interpreted mode not to be
%  impeded by interpreter code.
%  12/15/93 - G. Penn

% error message now given if extensional type in signature is not maximal.
%  12/15/93 - G. Penn

% Cuts switched from before retracts to after retracts where only one retract
%  should be done since retract can succeed on backtracking (just to be safe -
%  cuts in other predicates probably prevented any errors before).
%  1/4/94 - G. Penn

% =.. replaced by functor(... when only functor was needed.
%  3/19/94 - G. Penn

% Bug corrected: SVsOut = changed to SVsOut =.. in prune_deref
%  3/19/94 - G. Penn

% fully(TagOut) changed to fully(TagOut,SVsOut), so that prune_deref does
%  not have to redereference the SVs-structure for TagOut.
%  3/19/94 - G. Penn

% Bug corrected: suppress_adderrs was not dynamically declared.
%  3/22/94 - G. Penn

% Bug corrected: missing ! in cats_member check for cats> [].
%  8/1/94 - G. Penn

% Bug corrected: maximality check always failed because every type subsumes
%  itself.  And I'm also really bummed out at the baseball strike that
%  started today since it's the first time the Yankees have had a shot at the
%  pennant in 13 years.
%  8/12/94 - G. Penn

% ----------------------------------------
% Ale 2.0.1 patches

% Hello message now says Version 2.0.1 instead of Beta.
% 12/22/94 - G. Penn

% match_list and match_list_rest error messages missing set of parentheses.
% 12/22/94 - G. Penn

% missing extensionalise_list definition added.
% 12/22/94 - G. Penn

% Compiler did not flush continuants before adding prolog hooks.
%  NOTE - TAIL-RECURSIVE solve PLUS HOOKS LEADS TO UNEXPECTED BEHAVIOUR IN
%  SOME CASES
% 12/23/94 - G. Penn

% Missing abolishes added to compiler code.
% 12/23/94 - G. Penn

% Empty appropriateness definition inserted when no features exist to
%  avert SICStus existence error.
% 12/23/94 - G. Penn

% Missing cut added to compile_dtrs_rest in the final cats> clause.
% 12/23/94 - G. Penn

% 1/8/95 - Bob Carpenter
% Made Quintus compatible by bracketing if_h/1 and renaming append/3

% =====================================================================
% Errors Corrected 2.0.2
% =====================================================================

% 1/23/95 - Bob Carpenter
% Reported by Adam Przepiorkowski
% problem is that featval can be non-deterministic with constraints
% removed faulty cuts in add_to/5 to allow backtracking due to constraints
%    also conditioned error message
% removed cut after featval/6 in 2nd clause of pathval/7
%   conditioned error message

% =====================================================================
% ALE 2.0.2z
% =====================================================================

% atoms (# _) have been added as extensional types, subsumed by bottom,
%  subsuming nothing, with no appropriate features, and no constraints.
%  As a result, bottom must have no appropriate features or constraints.
% 11-17-95 - G. Penn

% check_sub_seq compiler modified to add fail predicate if there are no
%  non_atomic extensional types.  Before, it only added fail predicate if
%  there were no extensional types.  check_sub_seq is never used with
%  atoms; and the main if_h check_sub_seq compiler clause depends on this
%  fact.
% 12-26-95 - G. Penn

% atom functor changed from #/1 to a_/1.  Because #/2 was already defined,
%  there was a problem with getting prolog to recognize hashed predicates
%  such as unify_type_#(X,Y,Z) as 'unify_type_#'(X,Y,Z) and not #(unify_type_,
%  (X,Y,Z)).  As a result, there can be no type called 'a_'.
% 12-26-95 - G. Penn

% =====================================================================
% Patches integrated from ALE 2.0.3
% =====================================================================

% Added reload/1 in order to load grammar source too (which needs to be there).
% 3/1/97 - G. Penn

% Added a clause for prolog hooks to satisfy_dtrs_goal/6 and pp_goal/4 so that
%  top-level show clauses can display them.
% 3/1/97 - G. Penn

% Added deref_list/2 to deref before calls to extensionalise_list/2.
% Added deref calls before extensionalise calls in show_type/1, mgsat/1,
%  query/1, macro/1, lex_rule/1, show_clause/1 and rule/1
% 3/1/97 - G. Penn

% Added extensionalisation check to compile_body just before =@ calls.
% 3/1/97 - G. Penn

% Added extensionalise/2 predicate for people to use inside hooks.
% 3/5/97 - G. Penn

% =====================================================================
% ALE 3.0
% =====================================================================

% 4/1/96 - Octav Popescu
% Changed compile_body/6 to take an extra argument that's used to compute the
% Goals list as a difference list

% Missing comma added to abolish(add_to_typcons,6) predicate in compile_gram/1.
% 4/5/96 - G. Penn

% 5/1/96 - Octav Popescu
% Added generator based on semantic head-driven generation algorithm
% (Shieber et al, 1990)

% 5/1/96 - Octav Popescu
% Added a test to check_inequal/2 for the case the inequations list is
% uninstantiated

% 5/1/96 - Octav Popescu
% Added test to compile_lex_rules/0 to signal lack of 'morphs' specification
% in a lexical rule

% 5/15/96 - Octav Popescu
% Added indexing and index compilation of the lexicon for generation

% 5/15/96 - Octav Popescu
% Changed to display the new version and add the banner to the version/0 message

% 7/15/96 - Octav Popescu
% Removed some ":" and added some " " to message errors to make them uniform

% Bug corrected: changed call to duplicates_list/8 from Args to
%  ArgsOut in query/1 to take advantage of earlier dereferencing.
% 4/13/97 - G. Penn

% Added missing multiple_heads/1 and sem_head_member/1 definitions
% 5/5/97 - G. Penn

% Removed dynamic cons declarations (which are erased by abolish/2 anyway) and
%  inserted current_predicate/2 declarations to protect top-level show
%  predicates and compile-time error messages which call cons.
% 5/5/97 - G. Penn

% 5/5/97 - Octav Popescu
% Removed 'var' test from check_inequal/2 and prune/2 to allow for first
%  argument indexing

% 5/7/97 - Octav Popescu
% Modified chained/6 and collect_entries/1 to avoid infinite loops generated by
%  the lack of a 'var' test in check_inequal/2

% 6/2/97 - Octav Popescu
% Introduced sem_goal> tags

% 6/10/97 - Octav Popescu
% Added tests for wrongly placed sem_goal> tags

% Changed operator precedence of mgsat/1 to 1125 (from 1150).
% 6/14/97 - G. Penn

% maximal_defaults and bottom_defaults added:  now if type is mentioned
%  as subtype, or introduces features, but is not mentioned as super, assume
%  sub [] (maximal_defaults); if type is mentioned as supertype, but not as
%  subtype, assume bot sub (bottom_defaults).
%  6/15/97 - G. Penn

% intro is now autonomous.  Only one of _ intro _ or _ sub _ intro _ is
%  allowed per type.
%  6/15/97 - G. Penn

% subsumption testing added, with interpreter interface.  Commands subtest
%  and nosubtest toggle testing (run-time option and predicate).
%  6/15/97 - G. Penn

% functional constraints added to description language.
%  6/15/97 - G. Penn

% =@ flagged in type constraints.  More compiler-time error messages added
%  to compiler code.
%  6/15/97 - G. Penn

% Bug corrected: mgsat/1 tried to print description out after having added
%  it to bottom - big trouble if it involved variables and created a cyclic
%  feature structure.
%  6/15/97 - G. Penn

% Bug corrected: bottom_defaults should not add a default for atoms.
%  9/15/97 - G. Penn

% Added edge/1 to display edge by index.
%  9/16/97 - G. Penn

% Changed name of next option of query_edgeout/9 to continue, and of discard
%  option of query_discard/10 to noadd.  Added abort options to levels of
%  interpreter that didn't have them. Changed query_proceed in edge/2 to fail.
%  9/17/97 - G. Penn

% setof's removed from maximal_defaults.
%  9/17/97 - G. Penn

% Bug corrected:  T subs Ts did not behave correctly for uninstantiated T
%  9/17/97 - G. Penn

% Bug corrected: a_ X clauses in add_to_typeact and uact didn't bind reference
%  tags correctly.
%  9/23/97 - G. Penn

% Bug corrected: homomorphism condition check modified to handle non-grounded
%  atomic value restrictions.
%  9/23/97 - G. Penn

% Bug corrected: missing set of paren's in map_new_feats_introduced and
%  map_new_feats_find resulting in an improper list for atoms.
%  9/23/97 - G. Penn

% Removed extra lex_rule abolish from compile_lex_rules.
%  9/24/97 - G. Penn

% Bug corrected: maximal_defaults wasn't looking in _ sub Ss intro _ for
%  maximal members of Ss.
%  9/24/97 - G. Penn

% Bug corrected: pp_fs wasn't grounding VisOut for atoms
%  9/24/97 - G. Penn

% Added dynamic declaration for num/1.
%  9/25/97 - G. Penn

% Added abolish_preds/0.
%  9/25/97 - G. Penn

% Reordered type/1 clauses, cleaned up add_to's functional desc. handling,
%  and removed several extraneous extensionality checks on atoms.
%  9/27/97 - G. Penn

% Bug corrected:  current_predicate check added for if/2 in compile_cons.
%  9/27/97 - G. Penn

% Bug corrected:  Ref added to visited list for atoms also.
%  9/27/97 - G. Penn

% Moved secret_noadderrs/0 call in compile_rules past multi-hashing of rule/6.
%  10/5/97 - G. Penn

% Added parse, generate, and parse_and_gen modes.  Still only relative to one
%  grammar.  parse_and_gen is the default.  Wrote ale_gen.pl and ale_parse.pl
%  glue.
%  10/5/97 - G. Penn

% Bug corrected: parentheses misplaced when parsing/generating modes were
%  added.
%  11/4/97 - G. Penn

% Added warning for ground atoms in appropriateness declarations.
%  11/4/97 - G. Penn

% Bug corrected: add_to/4 and compile_desc/6 had bad cut in inequation
%  clause.  Replaced with ->.
%  12/5/97 - G. Penn

% Modified edge_assert/8 and edge/2 to use rule-name and dtr info regardless
%  of interpreter setting.
%  12/7/97 - G. Penn

% Stripped out version bannering - if you reload ALE, you get two banners.
% Also made parsing only the startup mode.
%  12/10/97 - G. Penn

% Rewrote match_list/11 so that initial cats> daughters are accessible through
%  Dtrs list to the interpreter.  Also involved adding an e_list check to
%  compile_dtrs and compile_dtrs_rest that now requires goal_list_to_seq
%  conversion.
% 12/10/97 - G. Penn

% Bug corrected:  multi_hash on fsolve/5 must be done regardless of whether
%  +++>/2 exists.
% 12/10/97 - G. Penn

% Bug corrected:  fsolve/5, fun/1 and +++>/2 added to abolish_preds
% 12/10/97 - G. Penn

% Removed unused substring/4.
% 12/11/97 - G. Penn

% ALE now turns character_escapes off.
% 12/11/97 - G. Penn

% compile_iso and compile_check now called from inside compile_extensional.
% 2/1/98 - G. Penn

% Bug corrected: rewrote fsolve/5 (now fsolve/4) to compile further and
%  avoid infinite loops in compile_fun/6.
% 2/1/98 - G. Penn

% Bug corrected: added fail-clause for solve/4 for when no if/2 statements are
%  defined.
% 2/1/98 - G. Penn

% Bug corrected: moved compile_fun/0 to just after compile_sig - constraints
%  must have access to fun/1.
% 2/1/98 - G. Penn

% Translated abolish/2 calls to abolish/1 ISO standard.
% 2/28/98 - G. Penn

% ======================================================================
% ALE 3.1
% ======================================================================

% Eliminated unused edge_dtrs/4 predicate
% 3/18/98 - G. Penn

% Switched order of edge index and left node for 1st-arg. indexing during
%  parsing
% 3/18/98 - G. Penn

% Translated !; to ->; and if/3 wherever possible.
% 3/20/98 - G. Penn

% Bug corrected:  misplaced cut in fun/1 clause of add_to/5
% 3/20/98 - G. Penn

% Bug corrected: misplaced cut in mh_arg/8
% 3/20/98 - G. Penn

% =.. replaced by functor/3 and arg/3 calls except where all args are needed.
% 3/20/98 - G. Penn

% Added missing compile_approp/1
% 3/21/98 - G. Penn

% Bug corrected: misplaced paren in compile_lex/0
% 3/21/98 - G. Penn

% Replaced intermediate files with term-expansion-based compiler.
% 3/21/98 - G. Penn

% Bug corrected: misplaced paren in compile_sub_type/2
% 3/21/98 - G. Penn

% Bug corrected: missing existential quantifier in setof/3 call of compile_fun
% 3/22/98 - G. Penn

% Bug corrected: removed redundant "lexical desc. for W is unsatisfiable" error
% 3/22/98 - G. Penn

% Rewrote lex/4 to use if/3.
% 3/24/98 - G. Penn

% Rearranged compiler code dependencies and abolish/1 calls, so that alec_throw
%  compilation and abolish/1 of compiled predicates is performed as locally
%  as possible.  This restores incremental compilation predicates.
% 3/28/98 - G. Penn

% Changed alec_throw to '.alec_throw' and added touch/1 call to file-reading
%  versions of compile-time predicates to ensure existence of '.alec_throw'
% 3/28/98 - G. Penn

% Added portray_message/1 hook to suppress .alec_throw compilation messages
% 3/28/98 - G. Penn

% Added "multiple constraint declaration error" to compile_cons_act/0.
%  Added current_predicate check to compile_cons for when cons is not
%  defined.
% 3/30/98 - G. Penn

% Converted ucons/7 and add_to_typecons/6 to compile-time predicates.  Added
%  ct/7 compilation in place of carrying around large list of TypeConsPairs.
% 3/30/98 - G. Penn

% Added 5-place and 6-place versions of ud/4 to build less structure on heap
% 4/5/98 - G. Penn

% Added 7-place version of compile_desc/6 to build less structure on heap.
%  Also added 7-place version of compile_fun/6 and 8-place version of
%  compile_pathval/7.
% 4/5/98 - G. Penn

% Changed fsolve/4 to fsolve/5 - split Ref and SVs to build less structure on
%  heap
% 4/5/98 - G. Penn

% Eliminated :- true in compiled code, and first-arg indexed goal_list_to_seq
% 4/5/98 -  G. Penn

% Replaced conc/3 with append/3 from library(lists).
% 4/9/98 - G. Penn

% Replaced make_seq/2 with goal_list_to_seq/2.
% 4/9/98 - G. Penn

% Disposed of unused make_list/2.
% 4/9/98 - G. Penn

% Replaced member/2, select/3, same_length/2, memberchk/2, reverse/2 with
%  definitions from library(lists).
% 4/9/98 - G. Penn

% Replaced ord_union/3 with definition from library(ordsets).
% 4/9/98 - G. Penn

% Added new clause to add_to/5 and compile_desc/6,7 for fast unification of
% unbound variables
% 4/13/98 - G. Penn

% Added MGSat compilation for map_new_feats_find and map_new_feats_introduced,
%  and for add_to_type and u when adding/unifying on one/two FSs with atomic
%  types.
% 4/12/98 - G. Penn

% Changed add_to_typeact so that Type2 is first argument, in case we need
%  to trap special cases of SVs.
% 4/13/98 - G. Penn

% Changed lexicon compilation from compiling to consulting.  Also added more
%  portray_message hooks to trap consulting messages.
% 4/15/98 - G. Penn

% Added lex_assert/0 and lex_compile/0 directives.  Also added dynamic
%  declaration in asserted case.  Extended option's control to empty
%  categories.
% 4/17/98 - G. Penn

% Added multifile declaration to asserted case for lex/4 and empty_cat/3
%  compilation.
% 4/20/98 - G. Penn

% Created lex_act/6 predicate for lex/4 to call from term_expansion/2 hook for
%  update_lex/1.  Added update_lex/1 (which handles empty cats also),
%  retract_lex/1, retractall_lex/1, retract_empty/0, and retractall_empty/0.
% 4/20/98 - G. Penn

% Bug corrected: generation code for cats> was calling subtype/2 instead of
%  sub_type/2
% 6/15/98 - G. Penn

% Bug corrected: clause added to ct/7 for when cons/2 is not defined.
% 6/16/98 - G. Penn

% Switched order of number_display/2 clauses and added cut to handle variable
%  first arguments (for interpreted generator)
% 6/18/98 - G. Penn

% Added export_words/2
% 6/23/98 - G. Penn

% Added rec/5 and rec/2 to enforce description on solution FS
% 6/23/98 - G. Penn

% Added rec_best/2, which produces all of the parses for the first list in a
%  a list of lists of words that has any solutions that match an input Desc,
%  rec_list/2, which produces all of the parses for every list in a
%  list of lists of words, and rec_list/3, which is like rec_list/2 but
%  collects solutions as fs(FS,Iqs) pairs in a list of lists.
% 6/23/98 - G. Penn

% ALE now turns character escapes on.  Code generation modified to print
%  '\+' and '=\=' correctly.
% 6/23/98 - G. Penn

% Moved approps(Type3,FRs3) call in uact/10 to just before map_feats_unif
%   call - otherwise not needed.
% 6/24/98 - G. Penn

% Moved touch('.alec_throw') calls from compile_XYZ/1 predicates to
%  compile_XYZ/0 predicates.
% 6/25/98 - G. Penn

% Added default maximal type specs for value restrictions and ext/1 types.
% 6/25/98 - G. Penn

% Removed extra space from "Compiling most general satisfiers..." message
%  and "Compiling sub-types..." message
% 6/29/98 - G. Penn

% Bug corrected: rec_best/2's recursive call was to rec_list/2.
% 6/30/98 - G. Penn

% Added lex and gen prefix operators to match rec, query etc.
% 6/30/98 - G. Penn

% Added domain exception to edge/2 to enforce M=
% 6/30/98 - G. Penn

% Moved mode-specific compilation messages inside parsing/generating checks.
% 6/30/98 - G. Penn

% Rewrote generator.
% 7/1/98 - G. Penn

% Changed name of lex(icon)_assert to lex(icon)_consult.
% 7/2/98 - G. Penn

% Bug corrected:  macro calls could not backtrack in add_to because -> was
%  used instead of if/3
% 7/7/98 - G. Penn

% Bug corrected: value restrictions from autonomous intro/2 declarations
%  were not generating default maximal type specs.  Line break also added
%  at end of 'assuming' messages.
% 7/7/98 - G. Penn

% Bug corrected: a_ subtype/feature spec error did not check for autonomous
%  intros.  bot feature spec error did not check for autonomous intros.
% 7/16/98 - G. Penn

% Bug corrected: maximal_defaults was not filtering out a_/1 value restrictions
%  or extensional types.
% 7/16/98 - G. Penn

% Bug corrected: turned off adderrs for enforcement of description argument of
% rec/2,5.
% 7/13/98 - G. Penn

% Bug corrected: missing clauses for =@ in pp_goal/4.
% 7/19/98 - G. Penn

% Bug corrected: missing clause for prolog hooks in mg_sat_goal/4
% 7/19/98 - G. Penn

% Bug corrected: several top-level predicates assumed atomic attached goals
%  when collecting FS's to dereference.  Now they use satisfy_dtrs_goal/6
%  instead of mg_sat_goal/4.
% 7/19/98 - G. Penn

% Split chain_rule/8 and chained/4 into separate phases.
% 7/19/98 - G. Penn

% Removed abolish(generate/6) call from compile_grammar/1 - that is done in
%  compile_grammar_act/0.
% 7/19/98 - G. Penn

% Changed non_chain_rule/8, chained/7 and chain_rule/12 to if_b to keep unification
% cases as first clauses after multi-hashing
% 7/19/98 - G. Penn

% Changed edge access to clause/2 calls - bypasses call stack.
% 7/20/98 - G. Penn

% Changed maximal_defaults so that 'assuming' message prints types w/o carriage
% returns.  Modified bottom_defaults message to something parallel.
% 7/31/98 - G. Penn

% Changed carriage returns on if_warning messages.
% 7/31/98 - G. Penn

% Bug corrected: fast variable binding could leave SVs unbound in some
%  disjunctive descriptions.
% 8/6/98 - G. Penn

% Bug corrected: clause/2 misspelled in subsumed/7
% 8/11/98 - G Penn

% ======================================================================
% ALE 3.2
% ======================================================================

% Renamed alec_catch_act/2 to alec_catch_hook/2.
% 9/7/98 - G. Penn

% Added multifile declaration for term_expansion/2 and alec_catch_hook/2.
% 9/7/98 - G. Penn

% Bug corrected:  sub_type(Type,Type) clause was matching a_ atoms.  Now use
%  subs/2 directly, rather than type/2.
% 10/24/98 - G. Penn

% Added compile-time analysis of variable binding to eliminate var/1 shallow
%  cuts in generated code where possible.
% 11/19/98 - G. Penn

% Added compile-time analysis of descriptions to eliminate fresh variable
%  allocation in procedural calls where possible.
% 11/20/98 - G. Penn

% Removed solve/4 meta-interpreter.  Clauses are now compiled into Prolog
%  clauses with their names preceded by 'fs_'.  Also added query_goal/4,
%  query_goal/6 and pp_query_goal/4 for query/1 and gen_lex_close/9 to call,
%  since there is no longer a close correspondence between preparing a goal
%  for printing and preparing a goal for calling (actually, there never
%  was - the printing prep. code did not work in some cases for calling
%  prep.).
% 11/22/98 - G. Penn

% Bug corrected: (3.1.1) maximal_defaults added a sub_def entry for bot
%  if it was used as an appropriate value restriction or as an extensional
%  type.
% 11/22/98 - G. Penn

% Quiet interpreter mode removed.  edge/8 always records daughters.
% 1/24/99 - G. Penn

% Cleaned up edge_assert/8 and pulled no_subsumption/0 check out to add_edge.
% 1/24/99 - G. Penn

% Added upward closure error message.
% 2/5/99 - G. Penn

% Added non-negative error message for edge/2
% 2/6/99 - G. Penn

% Bug corrected: node was unhooked in empty category indices - can be bound
%  from Left arg. of rule/6.
% 3/6/99 - G. Penn

% Bug corrected: compile_desc/11 was binding its FS variable with Tag-SVs and
%  inequational descriptions, which led to wasted structure on the heap.
% 3/6/99 - G. Penn

% Bug corrected: current_predicate check in empty_cat/7 needed to assert
%  alec_closed_rules for rule compiler.
% 3/7/99 - G. Penn

% Implemented EFD-Closure parsing algorithm.  Repairs ALE's problem with
%  empty category combination, as well as with non-ISO compliance of SICStus
%  (and probably SWI) with respect to asserted predicates.  Tabulate FSs at
%  compile-time to avoid Tag-SVs copying in compiled code.  Cleaned up fresh
%  argument binding and compile_desc/11's FS binding.
% 3/10/99 - G. Penn

% Implemented on-heap parsing to minimise edge copying.
% 3/10/99 - G. Penn

% Added FS palettes to avoid having to compile large FS's in compiled code.
% 3/11/99 - G. Penn

% Changed sub_type/2 and unify_type/3 compilation to consulting.  Doing the
%  same for approp/3 had net effect of slowing compilation down.  System is
%  slightly slower at run-time, presumably because of match_list list checks.
% 3/11/99 - G. Penn

% Modified on-heap chart to use custom edge/8 structures.
% 4/8/99 - G. Penn

% Removed unused member_ref_eq/2.
% 4/9/99 - G. Penn

% Bug corrected: FS palettes need to save inequation tags.
% 4/9/99 - G. Penn

% Rewrote extensionalisation code.
% 4/14/99 - G. Penn

% Bug corrected: query_goal/7 left Dtrs unbound on disjunctions.
% 4/20/99 - G. Penn

% Bug corrected: mg_sat_goal/5 left Iqs unbound on disjunctions.
% 4/20/99 - G. Penn

% Bug corrected: incorrect spacing for =@ in pp_goal/5.
% 4/20/99 - G. Penn

% Added shallow cuts.
% 4/21/99 - G. Penn

% Bug corrected: match_cat_to_next_cat/9 lost empty cat inequations with cats>
% 5/7/99 - G. Penn

% Bug corrected: non_chain_rule/8 code was being consulted.
% 5/8/99 - G. Penn

% Bug corrected: multi_hash/4 reversed order of clauses with same first-arg
%  index by using accumulator in mh_arg/9.  Changed to mh_arg/10 with diff.
%  list to preserve order
% 5/9/99 - G. Penn

% Rewrote subsumption checking code.
% 5/20/99 - G. Penn

% Bug corrected: mh_arg was not capturing variable arguments before decomposing
%  to match hashed argument position.  Added nonvar/1 check.
% 5/21/99 - G. Penn

% Added two-place shallow cuts.
% 5/22/99 - G. Penn

% Bug corrected: cats> Dtrs were bound to rule Dtrs.
% 5/22/99 - G. Penn

% Bug corrected: changed order of all clauses matching shallow cut args so that
%  they are matched before disjunctions.
% 5/22/99 - G. Penn

% Bug corrected: changed edge/2 to check for M
%  empty cats.  Also added no_interpreter check.
% 5/22/99 - G. Penn

% Bug corrected: empty/0 didnt print nl after '# of dtrs:' line, and dtr-#
%  option didnt handle continue option properly.
% 5/22/99 - G. Penn

% Changed 't's to empty_assoc/1 calls.
% 5/23/99 - G. Penn

% Bug corrected: match_list_rest was not defined with a Chart argument.
% 5/23/99 - G. Penn

% Bug corrected: placed to_rebuild/1 lookup inside clause call
% 5/23/99 - G. Penn

% Changed compile_subsume to check first for parsing flag.
% 5/23/99 - G. Penn

% Bug corrected: show_type failed if there were constraints, but not on the
%  type shown.
% 5/23/99 - G. Penn

% Added type/1 call to show_type so that it can iterate through types if
%  uninstantiated.
% 5/23/99 - G. Penn

% (ALE 3.2.1) Updated for SICStus 3.8.6 - added discontiguous declarations
%  and changed lexrule compilation to consulting because of 256-variable
%  limit (always was there on paper, but now it's enforced!).
% 12/11/01 - G. Penn

% ======================================================================
% ALE 3.3
% ======================================================================

% Changed deref/3 and deref/4 to allow for delaying (pp_fs and fully_deref
%  bind Tag).  Eliminated now redundant deref_pp/3.
% 2/23/02 - G. Penn

% Removed Dups thread from duplicates/8 - reference tag itself keeps track
%  of this.  Also replaced Vis thread in both duplicates_ and pp_ predicates
%  with assoc lists, and unwound duplicates_list/6 calls that created their
%  own list structures.  Added Ref/SVs versions of FS predicates; changed
%  pp_fs(...Col) to pp_fs_col to avoid arity conflicts.
% 2/23/02 - G. Penn

% added when_type/3, when_approp/4, when_eq/3, compile_cond/6 and a
%  compile_body/7 clause for delaying.
% 2/7/99 - G. Penn

% Bug corrected: trigger variables must be embedded in a shallow-cut to trivally
%  succeed, not fail, when the other disjunct is chosen
% 2/9/99 - G. Penn

% Bug corrected: when_approp/3 was passing an unbound variable to the compiler as
%  the body goal rather than a call/1 predicate.  The compiler filled this in with
%  true.
% 2/9/99 - G. Penn

% Bug corrected: query_goal/4,6 were not stripping prolog/1 wrapper off hooks
%  in executable Goal.
% 3/16/02 - G. Penn

% Modified when_eq/3 so that unification can bind tags without instantiating.
% 3/17/02 - G. Penn

% Changed @=/2 compilation to use compile_descs_fresh/12.
% 3/24/02 - G. Penn

% Added support for built-in =/2 (necessary for complex antecedent constraints).
% 4/29/02 - G. Penn

% Bug corrected: empty_cat/7, fsolve/5, lex/4, and non_chain_rule/8 were using
%  current_predicate/2 to test for success rather than existence, and were undefined
%  instead of simply producing failure when user code they relied on did not exist.
% 4/29/02 - G. Penn

% Bug corrected: Rewrote immed_cons/3 and show_cons/2 to display procedural attachments
%  on constraints.
% 4/29/02 - G. Penn

% Bug corrected: duplicates_fs/5 must erase a reference from the Visited AVL before it
%  instantiates it, or else the AVL's order-invariant could be thrown off and other
%  elements become irretrievable.
% 5/1/02 - G. Penn

% Added print-hooks (portray_fs/10), and changed duplicate marking from reference
%  instantiation to a parallel AVL tree.
% 5/3/02 - G. Penn
%
% Bug corrected: query_goal/6 (now 7) was not handling narrowly quantified variables
%  properly.  query_goal/3 now calls query_goal/7.
% 5/15/02 - G. Penn

% Enhanced show_type/1 to display info on join reducibility, join preservation, unary
%  branching and procedural attachments to constraints.  Also added new top-level preds
%  join_reducible/1,3, unary_branch/2, and non_join_pres/2.
% 5/18/02 - G. Penn

% Changed show_clause/1 to display ALE source-level predicates (which may still differ
%  from user source if if/2 clauses aren't facts).  The problem is that variables like X in
%      foo(X) if bar(((X,a);(X,b))).
%  can't be resolved without backtracking through interpretations of the description if a and
%  b are not unifiable.  There are also potential problems with resolving descriptions of
%  co-routined predicate bodies without waiting for the conditionals, and side-effects
%  from prolog/1 hooks.  Eventually, information from predicate control flow analysis
%  should be displayed with show_clause/1.
% 5/18/02 - G. Penn

% Changed alec_closed_rules/1 assertion to individual alec_rule/7 assertions.
%  Changed rule/1 to display goals as in show_clause/1 above, but expanded by
%  EFD-closure.
% 5/18/02 - G. Penn

% Changed lex_rule/1 to display goals as in show_clause/1 above.  Input and output
%  descriptions are still resolved.
% 5/18/02 - G. Penn

% HACK: added consistency checking before unify_type/3 compilation to exploit typically
%  low join density of large signatures.
% 6/6/02 - G. Penn

% Bug corrected: DtrsDesc, and Iqs were unhooked in satisfy_dtrs/7.
% 6/6/02 - G. Penn

% Bug corrected: homomorphism condition warning was not generated in all cases.
% 6/7/02 - G. Penn

% ud/4,5,6 and u/6 modified to exploit symmetry of unification by generating code only
%  for pairs in the standard order.
% 6/7/02 - G. Penn

% approps/2 now compiled.
% 6/14/02 - G. Penn

% References instantiated at run-time in u/6 and add_to_type/5 when constraints present,
%  to avoid copying structure in code area.  Rewrote ct/6, map_cons/6, add_to_typecons/6,
%  ucons/7 and mgsat_cons/6 to use FS rather than Tag and SVs.
% 6/14/02 - G. Penn

% Reindexed ucons/7 and add_to_typecons/6 findall calls on new constrained/1 predicate
%  that tabulates which types are antecedents of constraints.
% 6/14/02 - G. Penn

% Bug corrected: featval/6 can no longer use add_to_typeact/8 because of change in
%  reference instantiation.  Added featval_act/10.
% 6/16/02 - G. Penn

% approps/3 now tabulates length of FRs.
% 6/16/02 - G. Penn

% Rewrote map_feats predicates to use arg/3 rather than =../2 to build SVs terms.  Saves
%  structure on the heap.  Also changed u/6 and add_to_type/5 to if_b/2 predicates since
%  driving off the first argument of unify_type/3 automatically sorts them.
% 6/16/02 - G. Penn

% Rewrote functional description component so that any definite clause can be used as a
%  function provided that it has a 'fun name(-,-,..,+).' declaration to identify the
%  result argument position.  The older 'name(Arg1,...,Argn) +++> Result' now implicitly
%  defines an n+1-ary relation 'name(Arg1,...,Argn,Result) if true.'
% 6/18/02 - G. Penn

% Bug corrected: lex/4 compilation was calling fully_deref_prune/6 after lex_close/10,
%  but lex_rule/8 terminates with a call to it already.
% 6/18/02 - G. Penn

% Bug corrected: ord_add_element/3 and ord_intersect/2 were not loaded by ALE.
% 6/18/02 - G. Penn

% Added run-time lex_goal/4 hook to parser (build/3) and generator (non_chain_rule/8).
% 6/18/02 - G. Penn

% Bug corrected: rule/7 generated no code in the absence of PS rules.  compile_rules_act/0 also
%  modified so that rule/7 compilation will still be made, and current_predicate/2 guards on rule/2
%  added where appropriate.
% 6/18/02 - G. Penn

% Bug corrected: fun/1 added to abolished preds in abolish_preds/0.
% 6/20/02 - G. Penn

% Bug corrected: when_type/3 wasn't handling bot correctly when FS was a_/1 atom - now trap bot
%  and don't delay - when_a_/3 needs to push delay into Prolog level if FS is already a_/1 atom, and
%  when_a_chk/3 needs to decompose delay into Prolog delays if FS is already a_/1 atom.  when_eq/3
%  must decompose identical extensionally typed pairs to fire on time.
% 6/23/02 - G. Penn

% Added restriction that a_/1 value restrictions contain acyclic terms.
% 6/24/02 - G. Penn

% Rewrote query_goal/1,5 mechanism to eliminate redundant code, to handle narrow variables in
%  queries properly, for safety with co-routining, and to provide an entry point (query_cond0/4)
%  for co-routining to the source-level debugger.  Now uses a Zip variable to assemble Args list
%  properly in face of co-routining.
% 6/27/02 - G. Penn

% Bug corrected: query_goal0/6 did not dereference FS before add_to/3 call in =/2 clause.
% 6/27/02 - G. Penn

% Bug corrected: compile_cond_desc/11 assumed that FS was exactly FIntro when condition unblocks -
%  we only know FS's type is subsumed by FIntro.
% 6/27/02 - G. Penn

% Pushed inequations into co-routining layer.
% 6/27/02 - G. Penn

% Bug corrected: query_goal0/6 clause for negation did not call query_goal0/6 recursively
%  with enough anonymous arguments.
% 7/8/02 - G. Penn

% Added pp_residue/7 for printing residues.  Rewrote top-level query/1, rec/1, rec/2, rec_best/2,
%  and rec_list/2 to use it.  rec_list/3 now returns bag of soln/2, where second arg is residue.
%  gen/1 and gen/2 now print initial and final categories, with final category linked by
%  duplicate references to residue.
% 7/25/02 - G. Penn

% Bug corrected: split_emptys_rules/4 was looking for rule/? rather than
%  alec_rule/? terms.
% 7/29/02 - G. Penn

% Declared if_h/1,2 multifile (by popular demand).
% 7/30/02 - G. Penn

% Changed ale_debug/1 assertion in end_of_file expansion to assertz/1 call
%  to preserve order of consulted files.
% 8/14/02 - G. Penn

% Bug corrected: ct/4 was binding RHS variable to Cons goal Goal.
% 8/15/02 - G. Penn

% Bug corrected: Calls to query_goal/1 cannot simply instantiate Zip at the end of
%  the call because some suspensions may later unblock and zip the Args lists together
%  differently or bind NBody differently.  Instead, we should use instantiated Zip to
%  indicate that we don't care about argument lists or pretty-printing goal.  Added
%  query_cond/9 clause for bound Zip variable for these cases, and a var(Zip) check for
%  the old one.
% 8/15/02 - G. Penn

% Removed =@ check in constraint bodies.  There's plenty in the body that could go wrong,
%  and we're not going to check for all of it --- too expensive.
% 8/15/02 - G. Penn

% Bug corrected: variables of functional descriptions were unhooked by findall/3.
% 8/31/02 - G. Penn

% Bug corrected: RHS parsing in ct/4 was missing parentheses around goal/2 operator.
% 9/4/02 - G. Penn

% touch/1 modified to check for readable File before creating - in directories
%  with multiple users and badly set default file permissions, the old way resulted
%  in a write-permission error.  The new way is also a bit faster in a compilation
%  chain with  more than one throw.
% 9/6/02 - G. Penn

% Removed fully_deref/4 call from rec_list/3.  Unclear why it was there and not in the
%  other rec_X predicates, and it complicates the code for residuation.
% 9/6/02 - G. Penn

% Bug corrected: added Residue argument to rec/3 and rec/4 - need this because Chart is
%  now on the heap, and needs to be kept outside the scope of call_residue/2.
% 9/6/02 - G. Penn

% Bug corrected: changed the scope of \+\+ in top-level rec_X predicates
%  to keep the co-routining layer free of chart suspensions on exit by query_proceed/0.
% 9/19/02 - G. Penn

% Bug corrected: nv_replace_hook/5 was missing base case for non-narrow variables.
% 9/21/02 - G. Penn

% Added prolog/2 goals, where first argument is an assoc. list of narrow variable replacements.
%  Now if user wants to replace narrow vars in a hook, he can do it himself, so removed call to
%  nv_replace_hook/3.
% 9/29/02 - G. Penn

% Bug corrected: assoc. lists weren't initialised in gen/1 and gen/2.
% 9/29/02 - G. Penn

% Made FreshNVs binding contingent on var(Zip) in query_cond/9.
% 9/29/02 - G. Penn

% Cleaned up compile_ext/2.
% 10/7/02 - G. Penn

% Bug corrected: retract_lex_one/1 could remove wrong (but unifiable) entry - now uses dynamic
%  clause reference, and checks for dynamic declaration.
% 10/10/02 - G. Penn

% Cleaned up residue printing and added it to remaining predicates.  Now we factor out inequations
%  for printing and subsumption checking.
% 10/10/02 - G. Penn

% rule/1 was finding MGSat of mother before those of daughters - switched to stay closer to
%  parsing semantics.
% 10/10/02 - G. Penn

% Bug corrected: when_a_/3, when_a_chk/3, when_eq0/3 and ineq_disj/4 were not delaying on nonvar(SVs)
%  - can generate exception or error during fully_deref/4 traversal.
% 10/10/02 - G. Penn

% Bug corrected: build_complex_iqs_act/4 did not handle nonvar keys (happens when some but not all
%  disjuncts in a decomposed inequation fail).
% 10/10/02 - G. Penn

% Bug corrected: resgoal_args/3 missing clause for when_eq0/4.
% 10/10/02 - G. Penn

% Changed inequations from ineq(FS1,FS2,Rest) to ineq(Tag1,SVs1,Tag2,SVs2,Rest) to establish
%  invariant whereby suspended inequations only hold between dereferenced structures.
% 10/10/02 - G. Penn

% Removed inequations from extensionalisation code - we couldn't use them anyway.  FSs that
%  exist only in inequations or other suspended goals are still not extensionalised.
% 10/10/02 - G. Penn

% Bug corrected: function result arguments in fun/1 specs identified by + rather than -.
% 10/11/02 - G. Penn

% Eliminated lex_goal/2 in favour of goal/2 hooks on lexical entries and lexical rules.
% 10/11/02 - G. Penn

% Added portray_unif_failure/6, portray_path_failure/5, portray_feat_failure/4,
%  portray_macro_failure/4, portray_addtype_failure/4, portray_undef_type/4, portray_desc_failure/4
%  portray_featpath_failure/5, portray_edge_discard/9, portray_edge_retract/8, portray_incoming_edge/7
%  portray_edge/8, portray_dtr_edge/8, portray_lex/4, portray_type_info/8, portray_mgsat/4,
%  portray_cat/5, portray_ale_goal/2, portray_ale_macro/5, portray_empty/6, portray_lex_rule/10,
%  portray_ale_clause/2, and portray_rule/4 hooks.
% 10/14/02 - G. Penn

% Added error message for when nullary function looks like type.  Added another error message for
%  when function has more than one result argument specified in the same specification.
% 10/17/02 - G. Penn

% Bug corrected: a_/1 atom identity check was made on nullary functions rather than unary functions.
% 11/2/02 - G. Penn

% Removed term_expansion/2 hook for +++>/2 --- now handled by compile_fun_assert/0 and compile_dcs/2.
% Also added warning for overlapping definitions by +++>/2 and if/2.
% 11/2/02 - G. Penn

% Converted passing of end_of_file/0 in term_expansion/2 hook to failure so that other expansion
%  hooks (such as in CHR) can have a crack.
% 11/2/02 - G. Penn

% Bug corrected: lex/1 called lex/4 instead of lex/3.
% 11/15/02 - G. Penn

% Bug corrected: macro/1 was not instantiating the association list, AssocIn.
% 11/18/02 - G. Penn

% Added Dtrs argument to portray_empty/6 hook.
% 11/22/02 - G. Penn

% Added resgoal_args_wgoal/3 to hunt down residue FSs inside delayed goals.
% 11/22/02 - G. Penn

% Added unintroduced feature check to add_to/3.
% 11/22/02 - G. Penn

% Bug corrected: lazy referencing in add_to_type/3 and u/4 violated invariant assumed in
%  when_approp/3 - new structure values must be either variables, or completely well-formed
%  (including appropriateness).  Reprioritised structure-binding in map_mgsat/1 and created
%  new access predicate bind_mgsat/4 to take care of compile-time binding check.
% 11/24/02 - G. Penn

% Bug corrected: compile_dtrs/19 was not threading PGoals properly in case of final remainder/2
%  daughter.
% 11/27/02 - G. Penn

% Changed cats> list error message to reflect that e_list and ne_list are the two valid types
%  of argument.
% 11/27/02 - G. Penn

% Bug corrected: missing cuts in list cases of pp_desc/8.
% 11/27/02 - G. Penn

% Added resgoal_args_wgoal/3 hooks for ud/2,3,4 and deref/3,4, and pp_res_wgoal/8 hooks for
%  ud/2,3,4 and the query_cond/9 prefix added by non-zipped delayed goals.
% 12/2/02 - G. Penn

% Bug corrected: residue_args/3 call in pp_fs_res_col/4 misnamed Ref as Tag.
% 12/2/02 - G. Penn

% Added resgoal_args_wgoal/3 and pp_res_wgoal/8 hooks for when_type/3, and changed spacing
%  in pp_res_wgoal/8 hooks for ud/2,3,4.
% 12/2/02 - G. Penn

% Bug corrected: Added extra argument to filter_goals/3 to add varlist key to frozen goals, in
%  keeping with the format used by call_residue/2.  It might be possible to get rid of these
%  keys in call_residue/2 ASAP rather than do this, since we aren't using them for anything.
% 12/5/02 - G. Penn

% Added cuts to show_rule_dtrs/7 clauses to eliminate useless choice point.
% 12/5/02 - G. Penn

% mgsat warning in add_to/3 was missing a column argument in pp_fs/9 and
%  pp_iqs/8.
% 12/17/02 - G. Penn

% newline added after ENTRY: to display type more appropriately.
% 2/14/03 - G.. Penn

% Bug corrected: compile_lex_act failed in absence of parsing/0 flag.
% 5/10/03 - G. Penn

% Bug corrected: compiler predicates calling compile_body/10 with FS palettes
%  have to separately retract their FS palettes.  Changed retract_fs_palettes/0
%  to retract_fs_palettes/1 and fspal_ref/1 to fspal_ref/2 for indicating the
%  source.
% 5/10/03 - G. Penn

% Bug corrected: FS palette was unhooking lexical goal variables from lexical
%  entry.  Changed lex/3 to lex/2, and now bind FS at run-time when goal
%  variables are instantiated at compile-time.
% 5/26/03 - G. Penn

% Changed if_error/2 to use exception handler for signature compilation error
%  messages.  Other errors use error_msg/1 for now.
% 6/8/03 - G. Penn

% Changed if_warning/2 and if_warning_else_fail/2 to use print_message/2 facility
%  for signature compilation warning messages.
% 6/8/03 - G. Penn

% Changed check for unknown lexical items to breadth-first - now integrated with
%  reverse_count_lex_check/5 (formerly reverse_count/5).
% 6/9/03 - G. Penn

% Changed rec/4 and rec/5 to tabulate solution indices with solution/1.
% 6/9/03 - G. Penn

% Added write_list/2 with explicit stream reference for ale_warning/1 hooks.
% 6/9/03 - G. Penn

% Declared ext/1 as a prefix operator.
% 7/8/03 - G. Penn

% Bug corrected: compile_ext_sub_assert/0 was being called after alec(iso)
%  and alec(check) phases, which need its ext_sub_structs/6 clauses.
% 7/11/03 - G. Penn

% Changed extensional/1 to dynamic predicate.
% 7/11/03 - G. Penn

% Switched to matrix-based signature compiler.
% 7/16/03 - G. Penn

% Changed map_minimal/3 to map_minimal/2 to use new sig compiler.
% 7/16/03 - G. Penn

% Bug corrected: unsatisfiable lex entry message should issue newline after
%  message, not before.
% 7/25/03 - G. Penn

% Bug corrected: approp/3 should call intro/2 to determine whether to add
%  failure clause - ensure_sub_intro/0 guarantees existence of this pred.
% 7/25/03 - G. Penn

% Bug corrected: implicit_mins/1, implicit_maxs/1 and unary_branch/2 warnings
%  did not have ALE wrapper.
% 7/25/03 - G. Penn

% Added no_lex/0 exception for rec/4,5 when no lexicon exists.
% 7/25/03 - G. Penn

% Exception handling added for run-time rec/1,2, lex/1, rec_list/2 and
%  rec_best/2 calls.
% 7/25/03 - G. Penn

% Updated maximal/1 to new signature compiler.
% 7/29/03 - G. Penn

% Changed matrix-based signature compiler to ZCQ data structure
% 8/5/03 - G. Penn

% Moved call_det/2 here from debugger/interp.pl to replace exactly_once/3
%  implementation.  Changed duplicate_ext/2 to duplicate_ext/1.
% 8/5/03 - G. Penn

% NOTE: must resolve whether to close empty cat's under lexical rules
% Perhaps we should add an option to the interpreter to "go," stopping only
%   at subsumption-based assert/retract decisions
% Add check for cut-free goals in PS rules - they take scope over rule code,
%  and are prohibited in the manual
% Add benchmarking code written for Kathy B.
% Add named empty categories
% Add proc. attachments to lexical entries (and empty cats, macros?)
% Add more compile-time checking of compatibility
%  in things like rules, relations, lexical rules and constraints (things that
%  compile to code instead of FS's).  These should disable with the new user
%  control predicates also.
% Add list (and other) pretty-printer.
% Add statistical scoring mechanism.
% Make mini-interpreter record lexical rule and lexical origins of derived
%  lexical entries in chart
% Add subsumes/2 built-in to relational language/Prolog

% Make sure to reflect these changes in source-level debugger where approp.
% Aggregate type info in descriptions at each node in order to avoid redundant
%  type inferencing in compiled code - prob. other optimizations are possible
%  too, although must be balanced against transparency of description
%  execution.
% Also compile extensionalise further and everywhere else that functor and
%  arg are used
% remove check_inequal
% maybe add assert option to get around hard limit on number of vars. in
%  compiled predicates - ultimately should do something better like
%  automatically detecting when limit is exceeded and adding clauses like
%  add_to_type3 and featval/4.  The hard limit is actually on temporary
%  variables.
% get rid of compile_desc/6 - probably will have to change DS to do this right
%  in order to get featval to return a split Tag,SVs
% add indexing mechanism for generation lexicon and parsing chart.  Also
%  index first arguments of definite clauses by type.

% RCS banners
% $Id: ale.pl,v 1.12 2004/01/06 20:31:57 mhaji Exp $
%
% $Log: ale.pl,v $
% Revision 1.12  2004/01/06 20:31:57  mhaji
% link to co-routining compilation predicates
%
% Revision 1.11  2003/12/20 18:46:16  mhaji
% added links
%
% Revision 1.10  2003/12/19 23:03:00  mhaji
% added links
%
% Revision 1.9  2003/12/19 17:29:38  mhaji
% added links
%
% Revision 1.8  2003/12/19 00:11:58  mhaji
% added links
%
% Revision 1.7  2003/12/17 17:33:52  mhaji
% links to ref
%
% Revision 1.6  2003/12/12 21:45:11  mhaji
% *** empty log message ***
%
% Revision 1.5  2003/12/09 18:12:03  mhaji
% put link in description compiler
%
% Revision 1.4  2003/12/01 00:23:47  gpenn
% Corrected typos in copyright.
%
% Revision 1.3  2003/11/30 20:02:28  mhaji
% added chapter on compiling complex-antecedent constraints
%
% Revision 1.2  2003/10/29 18:00:34  mhaji
% added link to matrix multiplication formula in reference manual
%
% Revision 1.1.1.1  2003/10/10 21:02:46  mhaji
% ALE files
%
% Revision 1.9  1998/07/16 16:50:02  gpenn
% 3.1 beta bug patches
%
% Revision 1.7  1998/03/07 18:38:30  gpenn
% Bug corrections, internal notes
% Stripped out version bannering
% mini-interpreter now always carries dtr and rule info
% match_list bug corrected
% more warnings, removed some unused code
% now turns off character_escapes
% placed compile_iso and compile_check under compile_extensional
% translated abolish/2 calls to abolish/1 ISO standard
%
% Revision 1.6  1997/10/23 15:47:45  gpenn
% Added parsing and generating modes.  Still handles only one
% grammar per session.  ale_gen.pl and ale_parse.pl can glue two
% sessions together for translation.
%
% Revision 1.5  1997/09/27 21:43:36  gpenn
% Added edge subsumption w/ interpreter interface, functional
% descriptions, autonomous intro declaration, default declarations
% for maximal types and types immediately subsumed by bottom.
% Also cleaned up interpreter, and modified treatment of atoms to
% allow non-ground terms.
%
% Revision 1.4  1997/06/10 19:07:57  octav
% Added sem_goal> tags.
%
% Revision 1.2  1997/05/05 19:54:00  gpenn
% bug fix of 1.1
%

:- multifile portray_message/2.
:- dynamic ale_compiling/1, ale_debugging/0, ale_debug/1.

% SHOULD MAKE THIS MODULE-SPECIFIC
portray_message(warning,no_match(abolish(_))). % suppress abolish/1 warnings
portray_message(warning,ale(Msg)) :-
  format(user_error,'{ALE: Warning: ',[]),
  ale_warning(Msg),
  format(user_error,'}~n',[]),
  flush_output(user_error).

portray_message(informational,M) :-
  portray_message_inf(M).

portray_message_inf(loading(_Depth,_Mode,AbsFileName)) :-
  ale_compiling(AbsFileName),   % suppress compiler throws
  !.
portray_message_inf(loaded(_Depth,_Mode,AbsFileName,user,_,_)) :-
  ale_compiling(AbsFileName),
  !.
% for backwards compat with older SICStus versions
portray_message_inf(loading(_,AbsFileName)) :-
  ale_compiling(AbsFileName).
portray_message_inf(loaded(_,AbsFileName,user,_,_)) :-
  ale_compiling(AbsFileName).

:- prolog_flag(character_escapes,_,on).

:- use_module(library(terms),[subsumes_chk/2,term_variables/2,cyclic_term/1,
      variant/2,term_hash/2]).
:- use_module(library(lists),[member/2,append/3,select/3,same_length/2,
      memberchk/2,reverse/2,is_list/1]).
:- use_module(library(ordsets),[ord_union/3,ord_intersection/3,ord_add_element/3,
ord_intersect/2,ord_subtract/3]).
:- use_module(library(ugraphs),[vertices_edges_to_ugraph/3,top_sort/2,
add_vertices/3,transpose/2,vertices/2]).
:- use_module(library(assoc),[assoc_to_list/2,ord_list_to_assoc/2,get_assoc/5,
                              put_assoc/4,empty_assoc/1,get_assoc/3,map_assoc/3,
      del_assoc/4]).
:- use_module(library(system),[file_exists/2]).

:- dynamic no_interpreter/0.
:- dynamic no_subsumption/0.
:- dynamic subsume_ready/0.
:- dynamic go/1.
:- dynamic suppress_adderrs/0.
:- dynamic parsing/0, generating/0.
:- dynamic lexicon_consult/0.
:- dynamic show_res/0.

:- multifile if_b/2, if_h/2, if_h/1.

:- discontiguous if_h/1.
:- discontiguous if_h/2.
:- discontiguous if_b/2.

parse :-
  retractall(generating),
  asserta(parsing),
  nl,write('compiler will produce code for parsing only'),
  nl.

generate :-
  retractall(parsing),
  asserta(generating),
  nl,write('compiler will produce code for generation only'),
  nl.

parse_and_gen :-
  asserta(parsing),
  asserta(generating),
  nl,write('compiler will produce code for parsing and generation'),
  nl.

lex_consult :-
  asserta(lexicon_consult),
  nl,write('compiler will assert lexicon'),
  nl.

lex_compile :-
  retractall(lexicon_consult),
  nl,write('compiler will compile lexicon'),
  nl.

%-------------------------------------------------------------------------------
% interp/0
% [User's Manual]
%-------------------------------------------------------------------------------
interp :-
  retractall(no_interpreter),
  nl, write('interpreter is active'),
  nl.

nointerp :-
  asserta(no_interpreter),
  nl, write('interpreter is inactive'),
  nl.

%-------------------------------------------------------------------------------
% subtest/0
% [User's Manual]
%-------------------------------------------------------------------------------
subtest :-
  retractall(no_subsumption),
  compile_subsume,
  nl, write('edge/empty category subsumption checking active'),
  nl.
nosubtest :-
  asserta(no_subsumption),
  nl, write('edge/empty category subsumption checking inactive'),
  nl.

show_residue :-
  asserta(show_res),
  nl, write('blocked goals will be displayed'),
  nl.
hide_residue :-
  retractall(show_res),
  nl, write('blocked goals will be hidden'),
  nl.

clear :-
  retractall(to_rebuild(_)),
  retractall(solution(_)),
  retractall(edge(_,_,_,_,_,_,_)),
  retractall(parsing(_)),
  retractall(num(_)), % edge index
  retractall(go(_)).  % interpreter go flag

noadderrs :-
  asserta(suppress_adderrs),
  nl, write('Errors from adding descriptions will be suppressed.'),
  nl.
adderrs :-
  retractall(suppress_adderrs),
  nl, write('Errors from adding descriptions will be displayed.'),
  nl.

secret_noadderrs :-
  asserta(suppress_adderrs).
secret_adderrs :-
  retractall(suppress_adderrs).

% ==============================================================================
% Operators
% ==============================================================================

% ------------------------------------------------------------------------------
% SRK Descriptions
% ------------------------------------------------------------------------------
:-op(600,fx,a_).  % formerly 375
:-op(375,fx,@).
:-op(700,xfx,=@).
%:-op(700,xfx,==).
:-op(775,fx,=\=).
%:-op(800,xfy,:).  % now use standard 550
%:-op(1000,xfy,',').
%:-op(1100,xfy,';').

% ------------------------------------------------------------------------------
% Signatures
% ------------------------------------------------------------------------------

:-op(800,xfx,goal).
:-op(900,xfx,cons).
:-op(800,xfx,intro).
:-op(900,xfx,sub).
:-op(1150,fx,ext).

% ------------------------------------------------------------------------------
% Grammars
% ------------------------------------------------------------------------------
:-op(1125,xfy,then).
:-op(1150,xfx,===>).
:-op(1150,xfx,--->).
:-op(1150,xfx,macro).
:-op(1150,xfx,+++>).
:-op(1150,fx,fun).
:-op(1150,fx,empty).
:-op(1175,xfx,rule).
:-op(1175,xfx,lex_rule).
:-op(1160,xfx,morphs).
:-op(1125,xfx,'**>').
:-op(950,xfx,when).
:-op(900,xfx,becomes).
% 5/1/96 Octav - added operator for semantics/1 predicate
:-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).
:-op(800,xfx,new_if_warning_else_fail).
:-op(800,xfx,new_if_warning).
:-op(800,xf,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
% [User's Manual] [Reference Manual]
% ==============================================================================

% Type:type sub Types:types intro FRs:fvs                             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:type cons Cons:desc goal Goal:goal                             user
% ------------------------------------------------------------------------------
% Cons is the general description which must be satisfied by all structures of
%  type Type, and Goal is an optional procedural attachment which also must
%  be satisfied when present.  An absent constraint is equivalent to 'bot',
%  and an absent goal is equivalent to 'true'.
% ------------------------------------------------------------------------------

% ------------------------------------------------------------------------------
% type(?Type:type)                                   eval
% [User's Manual]
% ------------------------------------------------------------------------------
% Type is a type.  Enumerated in topological order.
% ------------------------------------------------------------------------------
type(bot).
type(a_ _).
type(T) :-
  current_predicate(type_num,type_num(_,_)),
  clause(type_num(T,_),true).

% ------------------------------------------------------------------------------
% non_a_type(?Type:type)                                                  eval
% ------------------------------------------------------------------------------
% Type is a type other than a a_/1 atom.  Enumerated in topological order.
% ------------------------------------------------------------------------------
non_a_type(bot).
non_a_type(T) :-
  current_predicate(type_num,type_num(_,_)),
  clause(type_num(T,_),true).

% ------------------------------------------------------------------------------
% immed_subtypes(?Type:type, ?SubTypes:types)                           eval
% ------------------------------------------------------------------------------
% SubTypes is set of immediate subtypes of Type (SubTypes cover Type)
% ------------------------------------------------------------------------------
immed_subtypes(Type,SubTypes):-
  current_predicate(sub,(_ sub _))
  -> ( Type sub SubTypes intro _ -> true
     ; Type sub SubTypes -> true
     ; SubTypes = []
     )
  ; SubTypes = [].

% ------------------------------------------------------------------------------
% imm_sub_type(?Type:type, ?TypeSub:type)                               eval
% ------------------------------------------------------------------------------
% TypeSub is immediate subtype of Type
% ------------------------------------------------------------------------------
imm_sub_type(Type,TypeSub):-
  immed_subtypes(Type,TypeSubs),
  member(TypeSub,TypeSubs).

% ------------------------------------------------------------------------------
% immed_cons(?Type:type, ?Cons:desc)                                    eval
% ------------------------------------------------------------------------------
immed_cons(Type,Cons,Goal) :-
  type(Type),               % KNOWN BUG: ALE WON'T CATCH A CONSTRAINT DEFINED FOR
  (current_predicate(cons,(_ cons _))  %  AN ATOM UNTIL THE COMPILER IS RUN
   -> (Type cons Cons goal Goal -> true ; Type cons Cons, Goal = true)
   ; Cons = none, Goal = none).

% ------------------------------------------------------------------------------
% sub_type(Type:type, TypeSub:type)            eval
% [User's Manual]
% ------------------------------------------------------------------------------
% TypeSub is subtype of Type
% ------------------------------------------------------------------------------
sub_type(T,S) :-
    var(T) -> unify_type(T,S,S) % KNOWN BUG: if S is a_/1 atom, T does not
                                %  iterate through its generalisations
                                %  (finite if argument is acyclic term)
  ; (T = (a_ X)) -> ( var(S) -> S = T
    ; (S = (a_ Y)), subsumes_chk(X,Y)
    )
  ; unify_type(T,S,S).

% ------------------------------------------------------------------------------
% unify_type/3
% unify_type(Type1:type, Type2:type, TypeLUB:type)                   mh(1)
% [User's Manual]
% ------------------------------------------------------------------------------
% The least upper bound of Type1 and Type2 is TypeLUB.
% ------------------------------------------------------------------------------
(unify_type(bot,T,T) if_h [type(T)]).
(unify_type(a_ X,bot,a_ X) if_h).  % a_/1 cases
(unify_type(a_ X,a_ X,a_ X) if_h).
(unify_type(Arg1,Arg2,TypeLUB) if_h) :-
  clause(stmatrix_dim(Dim),true),
  for_loop(1,N1,Dim),
    clause(stmatrix_num(N1,Row1),true),  % for each row of the subtype matrix...
    clause(num_type(N1,Type1),true),
    ( Arg1 = Type1, TypeLUB = Type1,
      ( Arg2 = bot                       % bot case
      ; Arg2 = Type1                     % reflexive case
      )
    ; arg(2,Row1,Row1Rest), arg(1,Row1Rest,Next),  % test for subtypes and joins
      N1Plus1 is N1 + 1,
      unify_type_range(N1Plus1,Next,Arg1,Arg2,TypeLUB,Type1,Row1Rest)
    ).

% ------------------------------------------------------------------------------
% unify_type_range(+N:int,+Next:int,-Arg1:type,-Arg2:type,-TypeLUB:type,
%                  +Type1:type,+Row1:typess)
% ------------------------------------------------------------------------------
% The least upper bound of Arg1 and Arg2 is TypeLUB, one of Arg1 or Arg2 is
%  Type1, and the other is numbered N or higher in the topological order.
%  Row1 consists of all subtypes of Type1 numbered Next or higher in the
%  topological order.
% This predicate is used to enumerate types that are join-compatible with Type1,
%  by iteratively testing every type numbered between the first and last subtypes
%  of Type1 (in topological order).  Types numbered prior to the first will have
%  already been handled by symmetric closure in their row.  Types numbered after
%  the last cannot be join-compatible, because joins are subtypes, and therefore
%  occur prior to (or equal with) the last.
% ------------------------------------------------------------------------------
unify_type_range(N,N,Arg1,Arg2,TypeLUB,Type1,Row) :-
  !,clause(num_type(N,Type2),true),  % subtype case
  ( TypeLUB = Type2, ( Arg1 = Type1, Arg2 = Type2
                     ; Arg2 = Type1, Arg1 = Type2)
  ; arg(2,Row,RowRest), arg(1,RowRest,Next),
    NPlus1 is N + 1,
    unify_type_range(NPlus1,Next,Arg1,Arg2,TypeLUB,Type1,RowRest)
  ).
unify_type_range(N2,_Next,Arg1,Arg2,TypeLUB,Type1,Row1) :-
  clause(stmatrix_num(N2,Row2),true),
  ord_intersection(Row1,Row2,RowLUB), % join reduction case
  arg(1,RowLUB,NLUB), % if empty, then fail - not compatible
  ( clause(stmatrix_num(NLUB,RowLUB),true)  % ow. first should be minimal
  -> clause(num_type(NLUB,TypeLUB),true),
     clause(num_type(N2,Type2),true),
     ( Arg1 = Type1, Arg2 = Type2
     ; Arg1 = Type2, Arg2 = Type1     % symmetric closure
     )
  ; map_minimal(RowLUB,Mins),  % if it isn't minimal, then this is not MSL
    raise_exception(ale(no_lub(Type1,Type2,Mins)))
  ).
unify_type_range(N2,Next,Arg1,Arg2,TypeLUB,Type1,Row) :-
  N2Plus1 is N2 + 1,  % try next element in range
  unify_type_range(N2Plus1,Next,Arg1,Arg2,TypeLUB,Type1,Row).


% ------------------------------------------------------------------------------
% for_loop(+Begin:int,-Var,+End:int)
% ------------------------------------------------------------------------------
% Iteratively bind Var to every integer between Begin and End (inclusively).
% ------------------------------------------------------------------------------
for_loop(Begin,Begin,_End).
for_loop(Begin,Var,End) :-
  End > Begin,
  NewBegin is Begin + 1,
  for_loop(NewBegin,Var,End).

% ------------------------------------------------------------------------------
% map_minimal(+Ss:types, ?SsMin:types)
% ------------------------------------------------------------------------------
% SsMin is the list of minimal types of Ss, i.e., every element of SsMin
%  belongs to Ss, and there is no element of Ss that is less than it in the
%  topological order.  Ss must be topological sorted.
% ------------------------------------------------------------------------------
map_minimal([],[]).
map_minimal([N|Ns],[T|Mins]) :-
  clause(num_type(N,T),true),        % assume topological order, so N is min
  clause(stmatrix_num(N,RowN),true), % RowN are the subtypes of N
  ord_subtract(Ns,RowN,NewNs),       % so get rid of them
  map_minimal(NewNs,Mins).

% ------------------------------------------------------------------------------
% unify_types(+Types:types, ?Type:type)                                 eval
% ------------------------------------------------------------------------------
% Type is the least upper bound of Types.
% ------------------------------------------------------------------------------
unify_types([],bot).
unify_types([Type|Types],TypeUnif):-
  unify_types(Types,Type,TypeUnif).

% ------------------------------------------------------------------------------
% unify_types(+Types:types, +Type:type, ?TypeUnif:type)
% ------------------------------------------------------------------------------
% 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).

% ------------------------------------------------------------------------------
% maximal(+Type:type)                                                     eval
% ------------------------------------------------------------------------------
% Type is a maximally specific type.
% ------------------------------------------------------------------------------
maximal(a_ X) :-
  !,ground(X).
% bot is never maximal, because of a_/1 atoms.
maximal(Type) :-
  clause(type_num(Type,N),true),
  clause(stmatrix_num(N,Row),true),
  arg(2,Row,[]).

% ------------------------------------------------------------------------------
% join_reducible(?Type)                                                     eval
% join_reducible(?Type,?Type1,?Type2)
% ------------------------------------------------------------------------------
% Type is join_reducible (to Type1 and Type2).
% ------------------------------------------------------------------------------
join_reducible(Type) :-
  \+ \+ join_reducible(Type,_,_).

join_reducible(Type,Type1,Type2) :-
  sub_type(Type1,Type),  \+ variant(Type1,Type),
  sub_type(Type2,Type),  \+ variant(Type2,Type),
  unify_type(Type1,Type2,Type).

% ------------------------------------------------------------------------------
% non_join_pres(?Type,?F)                                                   eval
% ------------------------------------------------------------------------------
% Join preservation (appropriateness homomorphism condition) fails at Type for
%  feature F.
% ------------------------------------------------------------------------------
non_join_pres(Type,F) :-
  \+ \+ non_join_pres(Type,F,_,_).

non_join_pres(Type,F,S1,S2) :-
  unify_type(S1,S2,Type),
  approp(F,Type,T3),
  ( approp(F,S1,T1)
  -> ( approp(F,S2,T2)      % F is appropriate to both S1 and S2
     -> unify_type(T1,T2,T1UnifyT2),
        \+sub_type(T3,T1UnifyT2)   % must check with sub_type/2 because
                                   %   of a_/1 atoms
     ; \+sub_type(T3,T1)    % F is appropriate to S1 only
     )
   ; ( approp(F,S2,T2)
     -> \+sub_type(T3,T2)   % F is appropriate to S2 only
      ; fail                % F is appropriate to neither - doesn't matter
     )
  ).

% ------------------------------------------------------------------------------
% unary_branch(?T, ?Type)                                                   eval
% ------------------------------------------------------------------------------
% There is a unary branch from T to Type.
% ------------------------------------------------------------------------------
unary_branch(T,Type) :-
  imm_sub_type(T,Type),
  immed_subtypes(T,[_,_]).  % Type and T are the only sub-types of T

% ------------------------------------------------------------------------------
% extensional(?Sort:sort)                                              dynamic
% ------------------------------------------------------------------------------
% Sort is an extensional sort.  Extensional sorts must be maximal.
% Created by compile_extensional.
% ------------------------------------------------------------------------------
:- dynamic extensional/1.

% ==============================================================================
% Appropriateness
% [User's Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% feature(F:feat)
% [User's Manual]
% ------------------------------------------------------------------------------
% holds if $F$ is a feature mentioned somewhere in the code
% ------------------------------------------------------------------------------
feature(Feat):-
  current_predicate(sub,(_ sub _)),
  setof(F,Type^Subs^R^FRs^((Type sub Subs intro FRs),
                           member(F:R,FRs)),
        Feats),  % findall/3 plus sort/2 might be faster here
  member(Feat,Feats).

feature(Feat):-
  current_predicate(intro,(_ intro _)),
  setof(F,Type^R^FRs^((Type intro FRs),
                       member(F:R,FRs)),
        Feats),
  member(Feat,Feats).

% ------------------------------------------------------------------------------
% Value Restriction
% [Reference Manual]
%
% restricts(Type:type, Feat:feat, TypeRestr:type)                     eval
% ------------------------------------------------------------------------------
% Type introduces the feature Feat imposing value restriction TypeRestr
% ------------------------------------------------------------------------------
restricts(Type,Feat,TypeRestr):-
  current_predicate(sub,(_ sub _)),
  Type sub _ intro FRs,
  member(Feat:TypeRestr,FRs).
restricts(Type,Feat,TypeRestr):-
  current_predicate(intro,(_ intro _)),
  Type intro FRs,
  member(Feat:TypeRestr,FRs).

% ------------------------------------------------------------------------------
% introduce(?Feat:feat, -Type:type)             eval
% [User's Manual] [Reference Manual]
% ------------------------------------------------------------------------------
% Type is the most general type appropriate for Feat
% ------------------------------------------------------------------------------
introduce(Feat,Type):-
  setof(N,TypeRestr^T^(restricts(T,Feat,TypeRestr),
       clause(type_num(T,N),true)),TypeNums),
  map_minimal(TypeNums,TypesMin),
  ( arg(2,TypesMin,[]) -> arg(1,TypesMin,Type)
  ; raise_exception(ale(feat_intro(Feat,TypesMin)))
  ).

% ------------------------------------------------------------------------------
% approp/3
% approp(Feat:feat, Type:type, TypeRestr:type)                       mh(1)
% [User's Manual]
% ------------------------------------------------------------------------------
% approp(Feat,Type) = TypeRestr
% ------------------------------------------------------------------------------
(approp(Feat,Type,ValRestr) if_h) :-
  setof(TypeRestr,TypeSubs^(sub_type(TypeSubs,Type),
                            restricts(TypeSubs,Feat,TypeRestr)),
        TypeRestrs),
               ale(upward_closure(Feat,Type,TypeRestrs)) if_error
                    (\+ unify_types(TypeRestrs,ValRestr)),
  unify_types(TypeRestrs,ValRestr).
approp(_,_,_) if_h [fail] :-
  ( current_predicate(sub,(_ sub _)) -> \+ (_ sub _ intro _)
  ; true),
  ( current_predicate(intro,(_ intro _)) -> \+ (_ intro _)
  ; true).

% ------------------------------------------------------------------------------
% approps(Type:type, FRs:feat_vals)                                     eval
% ------------------------------------------------------------------------------
% FRs is list of appropriateness declarations for Type
% ------------------------------------------------------------------------------
approps(Type,FRs,N) if_b [] :-
  type(Type),  % ALE WON'T CATCH FEATURES DEFINED FOR ATOMS UNTIL COMPILER RUNS
  esetof(Feat:TypeRestr, approp(Feat,Type,TypeRestr), FRs),
  length(FRs,N).

% ------------------------------------------------------------------------------
% approp_feats(Type:type,Fs:feats)
% ------------------------------------------------------------------------------
% 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
% [User's Manual] [Reference Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% ud(FS1:fs, FS2:fs, IqsIn:ineqs, IqsOut:ineqs)                     eval
% ------------------------------------------------------------------------------
% unifies FS1 and FS2 (after dereferencing);
% ------------------------------------------------------------------------------
ud(FS1,FS2):-
  deref(FS1,Ref1,SVs1), deref(FS2,Ref2,SVs2),
  ( (Ref1 == Ref2) -> true
  ; functor(SVs1,F1,_),
    functor(SVs2,F2,_),
    ( F1 @=< F2 -> u(SVs1,SVs2,Ref1,Ref2)
    ; u(SVs2,SVs1,Ref2,Ref1)
    )
  ).

% ud(FS:fs,Tag:ref,SVs:svs,IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
% 3-place version of ud/2
% ------------------------------------------------------------------------------

ud(FS1,RefIn2,SVsIn2) :-
  deref(FS1,Ref1,SVs1), deref(RefIn2,SVsIn2,Ref2,SVs2),
  ( (Ref1 == Ref2) -> true
  ; functor(SVs1,F1,_),
    functor(SVs2,F2,_),
    ( F1 @=< F2 -> u(SVs1,SVs2,Ref1,Ref2)
    ; u(SVs2,SVs1,Ref2,Ref1)
    )
  ).

% ud(Tag1:ref,SVs1:svs,Tag2:ref,SVs2:svs,IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
% 4-place version of ud/2
% ------------------------------------------------------------------------------

ud(RefIn1,SVsIn1,RefIn2,SVsIn2) :-
  deref(RefIn1,SVsIn1,Ref1,SVs1), deref(RefIn2,SVsIn2,Ref2,SVs2),
  ( (Ref1 == Ref2) -> true
  ; functor(SVs1,F1,_),
    functor(SVs2,F2,_),
    ( F1 @=< F2 -> u(SVs1,SVs2,Ref1,Ref2)
    ; u(SVs2,SVs1,Ref2,Ref1)
    )
  ).

call_u(SVs1,SVs2,Ref1,Ref2) :-  % like ud/4, but already dereferenced
  ( (Ref1 == Ref2) -> true
  ; functor(SVs1,F1,_),
    functor(SVs2,F2,_),
    ( F1 @=< F2 -> u(SVs1,SVs2,Ref1,Ref2)
    ; u(SVs2,SVs1,Ref2,Ref1)
    )
  ).

% ------------------------------------------------------------------------------
% Dereferencing
% [Reference Manual]
%
% deref(FSIn:fs, RefOut:ref, SVsOut:svs)
% ------------------------------------------------------------------------------
% RefOut-SVsOut is result of dereferencing FSIn at top level
% Also detects full-deref and pretty-printing references to be safe
%   for co-routining.
% ------------------------------------------------------------------------------
deref(Ref-SVs,RefOut,SVsOut):-
  ( var(Ref) -> (RefOut = Ref, SVsOut = SVs)
  ; functor(Ref,-,2) -> deref(Ref,RefOut,SVsOut)
  ; (Ref=fully(NewRef,NewSVs)) ->  deref(NewRef,NewSVs,RefOut,SVsOut)
%  ; atomic(Ref),  % pretty-printing reference
%    RefOut = Ref, SVsOut = SVs
  ).

% ------------------------------------------------------------------------------
% deref_list(RefsIn:refs, RefsOut:refs)
% ------------------------------------------------------------------------------
% 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:ref,SVsIn:svs, RefOut:ref, SVsOut:svs)
% ------------------------------------------------------------------------------
% RefOut-SVsOut is result of dereferencing FSIn at top level
% ------------------------------------------------------------------------------
deref(Ref,SVs,RefOut,SVsOut):-
  ( var(Ref) -> (RefOut = Ref, SVsOut = SVs)
  ; functor(Ref,-,2) -> deref(Ref,RefOut,SVsOut)
  ; (Ref=fully(NewRef,NewSVs)) -> deref(NewRef,NewSVs,RefOut,SVsOut)
%  ; atomic(Ref), % pretty-printing reference
%    RefOut = Ref, SVsOut = SVs
  ).

% ------------------------------------------------------------------------------
% fully_deref_prune(RefIn:ref,SVsIn:svs, RefOut:ref, SVsOut:svs,
%                   IqsIn:ineqs, IqsOut:ineqs)
% ------------------------------------------------------------------------------
% 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) :-
%  fully_deref(Tag,SVs,TagOut,SVsOut).
%  prune(IqsIn,IqsOut).

% 5/1/96 Octav -- added a clause for the case the inequations list is
%   uninstantiated
% 5/5/97 -- Octav Popescu - removed to allow for first argument indexing
%prune(Var,Var) :- var(Var), !. % !!! CHECK IF NECESSARY
%prune([],[]).
%prune([ineq(Tag1,SVs1,Tag2,SVs2,Ineqs)|IqsIn],IqsOut) :-
%  prune_deref(Tag1,SVs1,Tag1Out,SVs1Out,InFlag1),
%  prune_deref(Tag2,SVs2,Tag2Out,SVs2Out,InFlag2),
%  ((InFlag1 = out)
%   -> ((InFlag2 = out)           % both are out
%       -> prune(IqsIn,IqsOut)
%        ;                         % one is out, and it is intensional
%          (\+(SVs1 = a_ _),       % structure-sharing inside atoms could cause
%           functor(SVs1,Sort1,_), %  trouble later - so keep them around
%           \+extensional(Sort1))
%         -> prune(IqsIn,IqsOut)
%          ; (check_inequal_conjunct(ineq(Tag1Out,SVs1Out,Tag2Out,SVs2Out,
%                                         Ineqs),
%                                    IqOut,Result),
%            prune_act(Result,IqOut,IqsIn,IqsOut)))
%    ; ((InFlag2 = out,
%        \+(SVs2 = a_ _),
%        functor(SVs2,Sort2,_),
%        \+extensional(Sort2))
%       -> prune(IqsIn,IqsOut)
%        ; (check_inequal_conjunct(ineq(Tag1Out,SVs1Out,Tag2Out,SVs2Out,Ineqs),
%                                  IqOut,Result),
%           prune_act(Result,IqOut,IqsIn,IqsOut)))).

%prune_act(done,done,_,_) :-   % conjunct failed
%  !,fail.
%prune_act(succeed,_,IqsIn,IqsOut) :-  % conjunct succeeded
%  !,prune(IqsIn,IqsOut).
%prune_act(_,IqOut,IqsIn,[IqOut|IqsOut]) :-  % conjunct temporarily succeeded
%  prune(IqsIn,IqsOut).

%prune_deref(Tag,SVs,Tag,SVsOut,out) :-
%  var(Tag),
%  !,
%  ((SVs = a_ _) -> (SVsOut = SVs)
%                 ; (SVs =.. [Sort|Vs], % some substructures may still be shared
%                    prune_deref_feats(Vs,VsOut),
%                    SVsOut =.. [Sort|VsOut])
%  ).
%prune_deref(fully(TagOut,SVsOut),_,TagOut,SVsOut,in).
%prune_deref(Tag-SVs,_,TagOut,SVsOut,InFlag) :-
%  prune_deref(Tag,SVs,TagOut,SVsOut,InFlag).

%prune_deref_feats([],[]).
%prune_deref_feats([Ref-SVs|Vs],[RefOut-SVsOut|VsOut]) :-
%  prune_deref(Ref,SVs,RefOut,SVsOut,_),
%  prune_deref_feats(Vs,VsOut).

% ------------------------------------------------------------------------------
% fully_deref/4
% [Reference Manual]
% fully_deref(RefIn:ref,SVsIn:svs, RefOut:ref, SVsOut:svs)
% ------------------------------------------------------------------------------
% RefOut-SVsOut is result of recursively dereferencing FSIn;
% destroys RefIn-SVsIn by overwriting Tags
% ------------------------------------------------------------------------------
fully_deref(Tag,SVs,TagOut,SVsOut):-
  ( nonvar(Tag) -> fully_deref_act(Tag,SVs,TagOut,SVsOut)
                 ; Tag = (fully(TagOut,SVsOut)-SVsOut),
                   ((SVs = a_ X) -> SVsOut = a_ X
                                  ; (functor(SVs,Rel,Arity),
                                     functor(SVsOut,Rel,Arity),
                                     fully_deref_args(Arity,SVs,SVsOut))
                   )
  ).

fully_deref_act(fully(TagOut,_),SVs,TagOut,SVs).
fully_deref_act(TagMid-SVsMid,_,TagOut,SVsOut):-
  fully_deref(TagMid,SVsMid,TagOut,SVsOut).

fully_deref_args(0,_,_):-!.
fully_deref_args(N,SVs,SVsOut):-
  arg(N,SVs,TagN-SVsN),
  fully_deref(TagN,SVsN,TagOutN,SVsOutN),
  arg(N,SVsOut,TagOutN-SVsOutN),
  M is N-1,
  fully_deref_args(M,SVs,SVsOut).

% ------------------------------------------------------------------------------
% u(SVs1:svs,SVs2:svs,Ref1:ref,Ref2:ref,IqsIn:ineqs,
%   IqsOut:ineqs)                                                        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) if_b SubGoals:-
  unify_type(Type1,Type2,Type3),
  atom(Type3),  % handle a_/1 at the end.
  Type1 @=< Type2,
  uact(Type3,SVs1,SVs2,Ref1,Ref2,Type1,Type2,SubGoals).
u(a_ X,a_ X,Ref,Ref) if_b []. % must put this here too b/c of if_b/2.
u(a_ X,bot,Ref,Ref-(a_ X)) if_b [].  % when we strip off functors in ud/4,
                                % 'a_' will be less than bot in the standard order.

% ------------------------------------------------------------------------------
% 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(Type3,SVs1,SVs2,Ref1,Ref2,Type1,Type2,SubGoals):-
  % we know Type1, Type2, and Type3 aren't a_ atoms
  approps(Type1,FRs1,N1), functor(SVs1,Type1,N1),
  ( Type1 == Type2  -> Ref1 = Ref2, functor(SVs2,Type1,N1),
                       map_feats_eq(0,N1,SVs1,SVs2,SubGoals)
  ; approps(Type2,FRs2,N2), functor(SVs2,Type2,N2),      % Type1 \== Type2,
    ( Type2 == Type3 -> Ref1 = Ref2-SVs2,
                        map_feats_subs(FRs1,FRs2,SVs1,1,SVs2,1,SubGoals)
    ; Type1 == Type3 -> Ref2 = Ref1-SVs1,
                        map_feats_subs(FRs2,FRs1,SVs2,1,SVs1,1,SubGoals)
    ; Ref2 = Ref1,                                       % Type1\==Type3,Type2 \== Type3
      ( (N1==0,N2==0) -> bind_mgsat(Type3,Ref1,SubGoals,[])
       % if both are atomic, then we can use MGSat for Type3 - we could instantiate Ref1
               % to a type template if no constraints at Type3
      ; approps(Type3,FRs3,N3), functor(SVs3,Type3,N3),
        map_feats_unif(FRs1,FRs2,FRs3,SVs1,1,SVs2,1,SVs3,1,SubGoalsMid,SubGoalsRest),
        ucons(Type3,Type2,Type1,Ref1,SubGoalsRest),
        ( SubGoalsRest == []
        -> Ref1 = Tag3-SVs3, SubGoals = SubGoalsMid
; SubGoals = [(Ref1 = Tag3-SVs3)|SubGoalsMid]
        )
      )
    )
  ).

% ------------------------------------------------------------------------------
% ucons(Type:type,ExclType1:type,ExclType2:type,Tag:ref,SVs:svs,
%       IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
% Enforce the constraint for Type, and for all supersorts of Type, excluding
%  ExclType1 and ExclType2, on Tag-SVs
% ------------------------------------------------------------------------------
ucons(Type,ET1,ET2,FS,SubGoals) :-
  findall(T,(clause(constrained(T),true),
             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,FS,SubGoals,[]).

% ------------------------------------------------------------------------------
% ct(Type:type,Tag:ref,SVs:svs,Goals:goals,Rest:goals,IqsIn:ineqs,
%    IqsOut,ineqs)
% ------------------------------------------------------------------------------
% Goals, with tail Rest, are the compiled goals of the description (and
%  clause) attached to Type, enforced on feature structure Tag-SVs
% ------------------------------------------------------------------------------
:- dynamic constrained/1.
%ct(_Type,_FS,Rest,Rest,Iqs,Iqs) if_b [fail] :-
%  \+ current_predicate(cons,(_ cons _)),
%  !.
ct(Type,FS,Goals,Rest) if_b [] :-  % HACK: prob. should assert these as facts
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  Type cons RHS,
  ( nonvar(RHS), RHS = (Cons goal Goal) ->
    compile_desc(Cons,FS,Goals,GoalsMid2,true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs),
    compile_body(Goal,GoalsMid2,Rest,true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs),
    FSsOut = [],
%    build_fs_palette(FSsOut,FSPal,Goals,GoalsMid,ct),
    assert(constrained(Type))
  ; compile_desc(RHS,FS,Goals,Rest,true,VarsIn,_,FSPal,[],FSsOut,NVs),
    FSsOut = [],
%    build_fs_palette(FSsOut,FSPal,Goals,GoalsMid,ct),
    assert(constrained(Type))
  ).
% ct(_Type,FS,Rest,Rest,Iqs,Iqs) if_b [].    % all other types

% ------------------------------------------------------------------------------
% map_cons(Types:types,Tag:ref,SVs:svs,IqsIn:ineqs,IqsOut:ineqs,
%          SubGoals:goals,SubGoalsRest:goals)
% ------------------------------------------------------------------------------
% Given a set of types, strings together the goals and inequations for them.
% ------------------------------------------------------------------------------
%map_cons([],_,_,Iqs,Iqs,Goals,Goals).
%map_cons([Type|Types],Tag,SVs,IqsIn,IqsOut,SubGoals,SubGoalsRest) :-
%  ct(Type,Tag,SVs,SubGoals,SubGoalsMid,IqsIn,IqsMid),
%  map_cons(Types,Tag,SVs,IqsMid,IqsOut,SubGoalsMid,SubGoalsRest).
map_cons([],_,Goals,Goals).
map_cons([T|ConsTypes],FS,Goals,GoalsRest) :-
  ct(T,FS,Goals,GoalsMid),
  map_cons(ConsTypes,FS,GoalsMid,GoalsRest).

% ------------------------------------------------------------------------------
% map_feats_eq(FRs:feats,Vs1:fss,Vs2:fss,IqsIn:ineqs,IqsOut:ineqs,
%              Goals:goals)
% ------------------------------------------------------------------------------
% 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_eq(N,N,_,_,[]) :- !.
map_feats_eq(I,N,SVs1,SVs2,[ud(V1,V2)|SubGoals]) :-
  NewI is I + 1, arg(NewI,SVs1,V1), arg(NewI,SVs2,V2),
  map_feats_eq(NewI,N,SVs1,SVs2,SubGoals).


% ------------------------------------------------------------------------------
% map_feats_subs(FRs1:feats, FRs2:feats, Vs1:fss, Vs2:fss,
%                IqsIn:ineqs, IqsOut:ineqs, Goals:goals)
% ------------------------------------------------------------------------------
% 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_subs([],_,_,_,_,_,[]).
map_feats_subs([F:_|FRs1],FRs2,SVs1,I1,SVs2,I2,[ud(V1,V2)|SubGoals]) :-
  arg(I1,SVs1,V1), NewI1 is I1 + 1,
  map_feats_find(F,FRs2,V2,SVs2,I2,FRs2Out,NewI2),
  map_feats_subs(FRs1,FRs2Out,SVs1,NewI1,SVs2,NewI2,SubGoals).

% ------------------------------------------------------------------------------
% map_feats_find(F:feat, FRs:feats, V:fs, Vs:fss,
%                FRsOut:feats, VsOut:fss)
% ------------------------------------------------------------------------------
% 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,SVs,I,FRs,NewI) :-
%  !,arg(I,SVs,V), NewI is I + 1.
%map_feats_find(F,[_|FRs],V,SVs,I,FRsOut,NewI) :-
%  IMid is I + 1,
%  map_feats_find(F,FRs,V,SVs,IMid,FRsOut,NewI).

map_feats_find(F,[F2:_|FRs],V,SVs,I,FRsOut,NewI) :-
  ( F == F2 -> arg(I,SVs,V), NewI is I + 1, FRsOut = FRs
  ; IMid is I + 1,
    map_feats_find(F,FRs,V,SVs,IMid,FRsOut,NewI)
  ).

% ------------------------------------------------------------------------------
% map_feats_unif(FRs1:feats,FRs2:feats,FRs3:feats,Vs1:fss,Vs2:fss,
%                 Vs3:fss,IqsIn:ineqs,IqsOut:ineqs,Goals:goals,
%                 GoalsRest:goals)
% ------------------------------------------------------------------------------
% Vs1, Vs2 and Vs3 set to same length as Feats1, FRs2 and FRs3;
% a subgoal's added to Goals for each feature shared in FRs1 and FRs2;
% feats shared in Vs1,Vs2 and Vs3 passed; new Vs3 entries are created
% ------------------------------------------------------------------------------
%map_feats_unif([],FRs2,FRs3,[],Vs2,Vs3,IqsIn,IqsOut,Goals,GoalsRest):-
%  map_new_feats(FRs2,FRs3,Vs2,Vs3,IqsIn,IqsOut,Goals,GoalsRest).
%map_feats_unif([F1:R1|FRs1],FRs2,FRs3,Vs1,Vs2,Vs3,IqsIn,IqsOut,Goals,
%               GoalsRest):-
%  map_feats_unif_ne(FRs2,F1,R1,FRs1,FRs3,Vs1,Vs2,Vs3,IqsIn,IqsOut,Goals,
%                    GoalsRest).

%map_feats_unif_ne([],F1,R1,FRs1,FRs3,Vs1,[],Vs3,IqsIn,IqsOut,Goals,GoalsRest):-
%  map_new_feats([F1:R1|FRs1],FRs3,Vs1,Vs3,IqsIn,IqsOut,Goals,GoalsRest).
%map_feats_unif_ne([F2:R2|FRs2],F1,R1,FRs1,FRs3,Vs1,Vs2,Vs3,
%                  IqsIn,IqsOut,Goals,GoalsRest):-
%  compare(Comp,F1,F2),
%  map_feats_unif_act(Comp,F1,F2,R1,R2,FRs1,FRs2,FRs3,Vs1,Vs2,Vs3,
%                     IqsIn,IqsOut,Goals,GoalsRest).

%map_feats_unif_act(=,F1,_F2,R1,R2,FRs1,FRs2,FRs3,[V1|Vs1],[V2|Vs2],Vs3,
%                   IqsIn,IqsOut,[ud(V1,V2,IqsIn,IqsMid)|Goals1],GoalsRest):-
%  unify_type(R1,R2,R1UnifyR2),
%  map_new_feats_find(F1,R1UnifyR2,FRs3,V1,Vs3,FRs3Out,Vs3Out,IqsMid,IqsMid2,
%                     Goals1,Goals2),
%  map_feats_unif(FRs1,FRs2,FRs3Out,Vs1,Vs2,Vs3Out,IqsMid2,IqsOut,Goals2,
%                 GoalsRest).
%map_feats_unif_act(<,F1,F2,R1,R2,FRs1,FRs2,FRs3,[V1|Vs1],Vs2,Vs3,
%                   IqsIn,IqsOut,Goals,GoalsRest2):-
%  map_new_feats_find(F1,R1,FRs3,V1,Vs3,FRs3Out,Vs3Out,IqsIn,IqsMid,
%                     Goals,GoalsRest1),
%  map_feats_unif_ne(FRs1,F2,R2,FRs2,FRs3Out,Vs2,Vs1,Vs3Out,
%                    IqsMid,IqsOut,GoalsRest1,GoalsRest2).
%map_feats_unif_act(>,F1,F2,R1,R2,FRs1,FRs2,FRs3,Vs1,[V2|Vs2],Vs3,
%                   IqsIn,IqsOut,Goals,GoalsRest2):-
%  map_new_feats_find(F2,R2,FRs3,V2,Vs3,FRs3Out,Vs3Out,IqsIn,IqsMid,
%                     Goals,GoalsRest1),
%  map_feats_unif_ne(FRs2,F1,R1,FRs1,FRs3Out,Vs1,Vs2,Vs3Out,
%                    IqsMid,IqsOut,GoalsRest1,GoalsRest2).

map_feats_unif([],FRs2,FRs3,_,_,SVs2,I2,SVs3,I3,Goals,GoalsRest):-
  nmap_new_feats(FRs2,FRs3,SVs2,I2,SVs3,I3,Goals,GoalsRest).
map_feats_unif([F1:R1|FRs1],FRs2,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,Goals,GoalsRest):-
  map_feats_unif_ne(FRs2,F1,R1,FRs1,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,Goals,GoalsRest).

map_feats_unif_ne([],F1,R1,FRs1,FRs3,SVs1,I1,_,_,SVs3,I3,Goals,GoalsRest):-
  nmap_new_feats([F1:R1|FRs1],FRs3,SVs1,I1,SVs3,I3,Goals,GoalsRest).
map_feats_unif_ne([F2:R2|FRs2],F1,R1,FRs1,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,Goals,GoalsRest):-
  compare(Comp,F1,F2),
  map_feats_unif_act(Comp,F1,F2,R1,R2,FRs1,FRs2,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,Goals,GoalsRest).

map_feats_unif_act(=,F1,_F2,R1,R2,FRs1,FRs2,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,
   [ud(V1,V2)|Goals1],GoalsRest):-
  arg(I1,SVs1,V1), arg(I2,SVs2,V2),
  NewI1 is I1 + 1, NewI2 is I2 + 1,
  unify_type(R1,R2,R1UnifyR2),
  nmap_new_feats_find(F1,R1UnifyR2,FRs3,V1,SVs3,I3,NewI3,FRs3Out,Goals1,Goals2),
  map_feats_unif(FRs1,FRs2,FRs3Out,SVs1,NewI1,SVs2,NewI2,SVs3,NewI3,Goals2,GoalsRest).
map_feats_unif_act(<,F1,F2,R1,R2,FRs1,FRs2,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,Goals,GoalsRest2):-
  arg(I1,SVs1,V1), NewI1 is I1 + 1,
  nmap_new_feats_find(F1,R1,FRs3,V1,SVs3,I3,NewI3,FRs3Out,Goals,GoalsRest1),
  map_feats_unif_ne(FRs1,F2,R2,FRs2,FRs3Out,SVs2,I2,SVs1,NewI1,SVs3,NewI3,GoalsRest1,GoalsRest2).
map_feats_unif_act(>,F1,F2,R1,R2,FRs1,FRs2,FRs3,SVs1,I1,SVs2,I2,SVs3,I3,Goals,GoalsRest2):-
  arg(I2,SVs2,V2), NewI2 is I2 + 1,
  nmap_new_feats_find(F2,R2,FRs3,V2,SVs3,I3,NewI3,FRs3Out,Goals,GoalsRest1),
  map_feats_unif_ne(FRs2,F1,R1,FRs1,FRs3Out,SVs1,I1,SVs2,NewI2,SVs3,NewI3,GoalsRest1,GoalsRest2).

% ------------------------------------------------------------------------------
% map_new_feats(FRs:feats, FRsNew:feats, Vs:fss, VsNew:fss,
%               IqsIn:ineqs,IqsOut:ineqs,Gs:goals,GsRest:goals)
% ------------------------------------------------------------------------------
% 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,SubGoals,SubGoalsRest):-
%  map_new_feats_introduced(FRsNew,VsNew,SubGoals,SubGoalsRest).
%map_new_feats([Feat:TypeRestr|FRs],FRsNew,[V|Vs],VsNew,SubGoals,SubGoalsRest2):-
%  map_new_feats_find(Feat,TypeRestr,FRsNew,V,VsNew,
%                     FRsNewLeft,VsNewLeft,SubGoals,SubGoalsRest1),
% map_new_feats(FRs,FRsNewLeft,Vs,VsNewLeft,SubGoalsRest1,SubGoalsRest2).

nmap_new_feats([],FRsNew,_,_,SVsNew,M,SubGoals,SubGoalsRest):-
  nmap_new_feats_introduced(FRsNew,SVsNew,M,SubGoals,SubGoalsRest).
nmap_new_feats([Feat:TypeRestr|FRs],FRsNew,SVs,N,SVsNew,M,SubGoals,SubGoalsRest2):-
  arg(N,SVs,V),
  nmap_new_feats_find(Feat,TypeRestr,FRsNew,V,SVsNew,M,NewM,FRsNewLeft,SubGoals,SubGoalsRest1),
  NewN is N + 1,
  nmap_new_feats(FRs,FRsNewLeft,SVs,NewN,SVsNew,NewM,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,SubGoals,SubGoalsRest):-
%  !,
%  ( sub_type(TypeRestrNew,TypeRestr)
%    -> SubGoals = SubGoalsRest
%     ; ((TypeRestrNew = a_ X)
%        -> (Goal =.. ['add_to_type_a_',SVs,Tag,X],
%            SubGoals = [deref(V,Tag,SVs),Goal|SubGoalsRest])
%         ; (cat_atoms(add_to_type_,TypeRestrNew,Rel),
%            Goal =.. [Rel,SVs,Tag],
%            SubGoals = [deref(V,Tag,SVs),Goal|SubGoalsRest]))
%  ).
%map_new_feats_find(Feat,TypeRestr,[_:TypeRestrNew|FRs],
%                   V,[FS|Vs],FRsNew,VsNew,SubGoals,SubGoalsRest):-
% mgsc(TypeRestrNew,FS,SubGoals,SubGoalsMid),
%%(   (TypeRestrNew = a_ X)
%%  -> Goal =.. ['add_to_type_a_',bot,Tag,IqsIn,IqsMid,X]
%%   ; (cat_atoms(add_to_type_,TypeRestrNew,Rel),
%%      Goal =.. [Rel,bot,Tag,IqsIn,IqsMid])),
% map_new_feats_find(Feat,TypeRestr,FRs,V,Vs,FRsNew,VsNew,SubGoalsMid,SubGoalsRest).

nmap_new_feats_find(Feat,TypeRestr,[Feat2:TypeRestrNew|FRs],
                    V,SVsNew,M,NewM,FRsNew,SubGoals,SubGoalsRest):-
  ( Feat == Feat2 -> FRsNew = FRs,
                     arg(M,SVsNew,V), NewM is M + 1,
                     ( sub_type(TypeRestrNew,TypeRestr) -> SubGoals = SubGoalsRest
                     ; SubGoals = [deref(V,Tag,SVs),Goal|SubGoalsRest],
                       ((TypeRestrNew = a_ X) -> Goal = add_to_type_a_(SVs,Tag,X)
                       ; name(TypeRestrNew,TypeRestrNewName),
append("add_to_type_",TypeRestrNewName,RelName), name(Rel,RelName),
                         functor(Goal,Rel,2), arg(1,Goal,SVs), arg(2,Goal,Tag)
                       )
                     )
  ; arg(M,SVsNew,FS), MMid is M + 1,
    bind_mgsat(TypeRestrNew,FS,SubGoals,SubGoalsMid),
    nmap_new_feats_find(Feat,TypeRestr,FRs,V,SVsNew,MMid,NewM,FRsNew,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([],[],Rest,Rest).
%map_new_feats_introduced([_:TypeRestr|FRs],[FS|Vs],SubGoals,SubGoalsRest):-
% mgsc(TypeRestr,FS,SubGoals,SubGoalsMid),
%% ((TypeRestr = a_ X)
%%  -> Goal =.. ['add_to_type_a_',bot,Ref,IqsIn,IqsMid,X]
%%   ; (cat_atoms(add_to_type_,TypeRestr,Rel),
%%      Goal =.. [Rel,bot,Ref,IqsIn,IqsMid])),
% map_new_feats_introduced(FRs,Vs,SubGoalsMid,SubGoalsRest).

nmap_new_feats_introduced([],_,_,Rest,Rest).
nmap_new_feats_introduced([_:TypeRestr|FRs],SVs,M,SubGoals,SubGoalsRest):-
arg(M,SVs,FS), NewM is M + 1,
bind_mgsat(TypeRestr,FS,SubGoals,SubGoalsMid),
nmap_new_feats_introduced(FRs,SVs,NewM,SubGoalsMid,SubGoalsRest).


bind_mgsat(Type,RefOrV,SubGoals,SubGoalsRest) :-
  clause(mgsc(Type,MGSat,SubGoals,SubGoalsMid),true),
  ( SubGoalsMid == SubGoals -> RefOrV = MGSat, SubGoals = SubGoalsRest % no constraints in MGSat
  ; SubGoalsMid = [RefOrV = MGSat|SubGoalsRest] % otherwise enforce constraints first, then bind.
  ).  % If there are no constraints at Type3, then MGSat is instantiated already


% ==============================================================================
% Lexical Rules
% [User's Manual] [Reference Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% 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,GoalIn,WordOut,TagOut,SVsOut,GoalOut) if_h SubGoals :-
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  ( (_LexRuleName lex_rule DescOrGoalIn **> DescOrGoalOut morphs Morphs),
    Cond = true
  ; (_LexRuleName lex_rule DescOrGoalIn **> DescOrGoalOut if Cond morphs Morphs)
  ),
  ( var(DescOrGoalIn) -> DescIn = DescOrGoalIn
  ; functor(DescOrGoalIn,goal,2) -> arg(1,DescOrGoalIn,DescIn),
                                    arg(2,DescOrGoalIn,GoalIn)
  ; DescIn = DescOrGoalIn
  ),
  ( var(DescOrGoalOut) -> DescOut = DescOrGoalOut, GoalOut = true
  ; functor(DescOrGoalOut,goal,2) -> arg(1,DescOrGoalOut,DescOut),
                                     arg(2,DescOrGoalOut,GoalOut)
  ; DescOut = DescOrGoalOut, GoalOut = true
  ),
  compile_desc(DescIn,TagIn,SVsIn,SubGoals,SubGoalsRest1,
               true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs),
  compile_body(Cond,SubGoalsRest1,SubGoalsMid,true,VarsMid,
               VarsMid2,FSPal,FSsMid,FSsMid2,NVs),
  compile_desc(DescOut,TagMid,bot,SubGoalsMid,
               [morph(Morphs,WordIn,WordOut),
                fully_deref(TagMid,bot,TagOut,SVsOut)],
               true,VarsMid2,_,FSPal,FSsMid2,FSsOut,NVs),
  FSsOut = [].  % KNOWN BUG: should probably flag these if violated.
%  build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsFinal,lex_rule).

% ------------------------------------------------------------------------------
% 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):-  % need to instantiate Word even if
  name(WordIn,CodesIn),         %  X becomes X - do we want this?
  make_char_list(CodesIn,CharsIn),
  morph_chars(Morphs,CharsIn,CharsOut),
  make_char_list(CodesOut,CharsOut),
  name(WordOut,CodesOut).

% ------------------------------------------------------------------------------
% morph_chars(Morphs:morph)>,
%             CharsIn:char)>, CharsOut:char)>)
% ------------------------------------------------------------------------------
% applies first pattern rewriting in Morphs that matches input CharsIn
% to produce output CharsOut;  CharsIn should be instantiated and
% CharsOut should be uninstantiated for sound result
% ------------------------------------------------------------------------------
morph_chars((Morph,Morphs),CharsIn,CharsOut):-
    morph_template(Morph,CharsIn,CharsOut)
    -> true
     ; morph_chars(Morphs,CharsIn,CharsOut).
morph_chars(Morph,CharsIn,CharsOut):-
  morph_template(Morph,CharsIn,CharsOut).

% ------------------------------------------------------------------------------
% morph_template(Morph:morph, CharsIn:chars, CharsOut:chars)
% ------------------------------------------------------------------------------
% 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:pattern,Chars:char)>)
% ------------------------------------------------------------------------------
% apply pattern Patt, which is sequence of atomic patterns,
% to list of characters Chars, using append/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:atomic_pattern,List:char)>)
% ------------------------------------------------------------------------------
% 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:ascii)>, CharList:char)>)
% ------------------------------------------------------------------------------
% 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:desc, Tag:tag, SVs:svs, IqsIn:ineqs, IqsOut:ineqs)
% ------------------------------------------------------------------------------
% Info in Phi is added to FSIn (FSIn already derefenced);
% ------------------------------------------------------------------------------
add_to(X,Ref2,SVs2) :-
  var(X),
  !,(X = Ref2-SVs2).
add_to(Ref1-SVs1,Ref2,SVs2):-
  !,
  if((deref(Ref1,SVs1,Ref3,SVs3),
      call_u(SVs2,SVs3,Ref2,Ref3)),
     true,
     (suppress_adderrs -> fail
     ; error_msg((
             \+ \+ (frozen_term([Ref1|SVs1],Frozen1),
frozen_term([Ref2|SVs2],Frozen2),
( (current_predicate(portray_unif_failure,portray_unif_failure(_,_,_,_,_,_)),
   portray_unif_failure(Ref1,SVs1,Frozen1,Ref2,SVs2,Frozen2)) -> true
; build_iqs(Frozen1,Iqs1,FSGoals1),
  build_iqs(Frozen2,Iqs2,FSGoals2),
                  (show_res -> residue_args(FSGoals1,ResArgs,[Ref1-SVs1|ResArgs2]),
    residue_args(FSGoals2,ResArgs2,[Ref2-SVs2])
  ; ResArgs = [Ref1-SVs1,Ref2-SVs2]
  ),
                  empty_assoc(AssocIn),
                  duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid),
          duplicates_iqs(Iqs1,DupsMid,DupsMid2,VisMid,VisMid2,NumMid,NumMid2),
                  duplicates_iqs(Iqs2,DupsMid2,DupsMid3,VisMid2,_,NumMid2,_),
                  nl, write('add_to could not unify '),
                  nl,tab(5),
     pp_fs(Ref1,SVs1,DupsMid3,DupsMid4,AssocIn,Vis2Mid,5,AssocIn,HDMid), nl,
  pp_iqs(Iqs1,DupsMid4,DupsMid5,Vis2Mid,Vis2Mid2,5,HDMid,HDMid2),
  ((show_res,FSGoals1 \== [])
  -> nl,nl, write('Residue:'),
     pp_residue(FSGoals1,DupsMid5,DupsMid6,Vis2Mid2,Vis2Mid3,5,HDMid2,HDMid3)
  ; DupsMid6 = DupsMid5, Vis2Mid3 = Vis2Mid2, HDMid3 = HDMid2
  ),
  nl, write('and '),
  nl, tab(5),
  pp_fs(Ref2,SVs2,DupsMid6,DupsMid7,Vis2Mid3,Vis2Mid4,5,HDMid3,HDMid4),
  pp_iqs(Iqs2,DupsMid7,DupsOut,Vis2Mid4,Vis2Out,5,HDMid4,HDOut),
  ((show_res,FSGoals2 \== [])
  -> nl,nl, write('Residue:'),
     pp_residue(FSGoals2,DupsOut,_,Vis2Out,_,5,HDOut,_)
                  ; true
  ),
                ttynl)))))).
add_to([],Ref,SVs):-
  !, add_to(e_list,Ref,SVs).
add_to([H|T],Ref,SVs):-
  !, add_to((hd:H,tl:T),Ref,SVs).
add_to(Path1 == Path2,Tag,SVs) :-
  !, pathval(Path1,Tag,SVs,TagAtPath1,SVsAtPath1),
  deref(Tag,SVs,TagMid,SVsMid),
  pathval(Path2,TagMid,SVsMid,TagAtPath2,SVsAtPath2),
  if(call_u(SVsAtPath1,SVsAtPath2,TagAtPath1,TagAtPath2),
     true,
     (suppress_adderrs -> fail
     ; error_msg((frozen_term([Tag|SVs],Frozen),
  ((current_predicate(portray_path_failure,portray_path_failure(_,_,_,_,_)),
   portray_path_failure(Path1,Path2,Tag,SVs,Frozen)) -> true
  ; nl, write('add_to could not unify paths '),
                    write(Path1), write(' and '),
                    write(Path2), write(' in '),
                    nl, pp_fs_res_col(Tag,SVs,Frozen,5),
                    ttynl
     ))))).
%-------------------------------------------------------------------------------
% Inequations
% [User's Manual]
%-------------------------------------------------------------------------------

add_to(=\= Desc,Tag,SVs):-
  !,add_to(Desc,Tag2,bot),
  ineq(Tag-SVs,Tag2-bot).

add_to(Feat:Desc,Ref,SVs):-
  !,
  ( approp(Feat,_,_) -> true
  ; error_msg((nl,write_list([description,uses,unintroduced,feature,Feat]),ttynl))
  ),
  if(featval(Feat,SVs,Ref,FSatFeat),
     (deref(FSatFeat,RefatFeat,SVsatFeat),
      add_to(Desc,RefatFeat,SVsatFeat)),
     (suppress_adderrs
      -> fail
       ; error_msg((frozen_term([Ref|SVs],Frozen),
    ((current_predicate(portray_feat_failure,portray_feat_failure(_,_,_,_)),
      portray_feat_failure(Feat,Ref,SVs,Frozen)) -> true
    ; nl, write('add_to could not add feature '), write(Feat),
                      write(' to '), pp_fs_res_col(Ref,SVs,Frozen,5),
                      ttynl
    ))))).
add_to((Desc1,Desc2),Ref,SVs):-
  !, add_to(Desc1,Ref,SVs),
  deref(Ref,SVs,Ref2,SVs2),
  add_to(Desc2,Ref2,SVs2).
add_to((Desc1;Desc2),Ref,SVs):-
  !,
  ( add_to(Desc1,Ref,SVs)
  ; add_to(Desc2,Ref,SVs)
  ).
%-------------------------------------------------------------------------------
% Macros
% [User's Manual]
%-------------------------------------------------------------------------------
add_to(@ MacroName,Ref,SVs):-
  !,
  if((MacroName macro Desc),
     add_to(Desc,Ref,SVs),
     error_msg((frozen_term([Ref|SVs],Frozen),
        ((current_predicate(portray_macro_failure,portray_macro_failure(_,_,_,_)),
  portray_macro_failure(MacroName,Ref,SVs,Frozen)) -> true
        ; nl, write('add_to could not add undefined macro '),
                  write(MacroName),
                  write(' to '), pp_fs_res_col(Ref,SVs,Frozen,5),
                  ttynl
        )))).
add_to(Type,Ref,SVs):-
  type(Type),
  !,
  if(add_to_type(Type,SVs,Ref),
     true,
     (suppress_adderrs
      -> fail
       ; error_msg((frozen_term([Ref|SVs],Frozen),
    ((current_predicate(portray_addtype_failure,portray_addtype_failure(_,_,_,_)),
      portray_addtype_failure(Type,Ref,SVs,Frozen)) -> true
    ; nl, write('add_to could not add incompatible type '),
                      write(Type),
                      nl, write('to '), pp_fs_res_col(Ref,SVs,Frozen,5),
                      ttynl
    ))))).
add_to(FunDesc,Ref,SVs) :-   % complex function constraints
  functor(FunDesc,Functor,FunArity),
  FunDesc =.. [_|FunDescArgs],
  clause(fun_spec(Functor,FunArity,_),true),
  !, name(Functor,FunName),
  append("fs_",FunName,RelName),
  name(Rel,RelName),
  clause(fun_spec(Functor,FunArity,ResArg),true),
  PreLen is ResArg - 1, PostLen is FunArity - ResArg + 1,
  length(PreArgs,PreLen), length(PostArgs,PostLen),
  append(PreArgs,PostArgs,FunArgs),
%  append(PostArgs,[IqsMid,IqsOut],PostRelArgs),
  append(PreArgs,[Ref-SVs|PostArgs],RelArgs),
  Goal =.. [Rel|RelArgs],
  mg_sat_list(FunDescArgs,FunArgs),
  call(Goal).
add_to(Atom,Ref,SVs) :-
  atomic(Atom),
  !,
  error_msg((frozen_term([Ref|SVs],Frozen),
     ((current_predicate(portray_undef_type,portray_undef_type(_,_,_,_)),
       portray_undef_type(Atom,Ref,SVs,Frozen)) -> true
     ; nl, write('add_to could not add undefined type '), write(Atom),
               nl, write('to '), pp_fs_res_col(Ref,SVs,Frozen,5),
               ttynl
     ))).
add_to(Desc,Ref,SVs) :-
  error_msg((frozen_term([Ref|SVs],Frozen),
     ((current_predicate(portray_desc_failure,portray_desc_failure(_,_,_,_)),
       portray_desc_failure(Desc,Ref,SVs,Frozen)) -> true
     ; nl,write('add_to could not add ill formed complex description '),
               nl, tab(5), write(Desc),
               nl, write('to '),
               pp_fs_res_col(Ref,SVs,Frozen,5),
               ttynl
     ))).

% add_to_list(Descs:descs,FSs:fss,IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
%  add each description in Descs to the respective FS in FSs
% ------------------------------------------------------------------------------
add_to_list([],[]).
add_to_list([Desc|Descs],[FS|FSs]) :-
  deref(FS,Tag,SVs),
  add_to(Desc,Tag,SVs),
  add_to_list(Descs,FSs).

% add_to_fresh(Descs:descs,FSs:fss,IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
%  same as add_to_list, but instantiates the FS's first to bottom
% ------------------------------------------------------------------------------
add_to_fresh([],[]).
add_to_fresh([Desc|Descs],[Ref-bot|FSs]) :-
  add_to(Desc,Ref,bot),
  add_to_fresh(Descs,FSs).

% ------------------------------------------------------------------------------
% pathval(P:path,TagIn:tag,SVsIn:svs,TagOut:svs,
%         IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
% TagOut-SVsOut is the undereferenced value of dereferenced TagIn-SVsIn
% at path P
% ------------------------------------------------------------------------------
pathval([],Tag,SVs,Tag,SVs).
pathval([Feat|Path],Tag,SVs,TagOut,SVsOut):-
  if(featval(Feat,SVs,Tag,FSMid),
     (deref(FSMid,TagMid,SVsMid),
      pathval(Path,TagMid,SVsMid,TagOut,SVsOut)),
     (suppress_adderrs -> fail
     ; (frozen_term([Tag|SVs],Frozen),
       ((current_predicate(portray_featpath_failure,portray_featpath_failure(_,_,_,_,_)),
portray_featpath_failure(Feat,Path,Tag,SVs,Frozen)) -> fail
       ; write('feature '), write(Feat), write(' in path '),
         write([Feat|Path]), write('could not be added to '),
         pp_fs_res_col(Tag,SVs,Frozen,5),
         fail)))).

% ------------------------------------------------------------------------------
% add_to_type(Type:type,SVs:svs,Ref:ref,IqsIn:ineqs,
%             IqsOut:ineqs)                                              mh(2)
% ------------------------------------------------------------------------------
% adds Type to Ref-SVs -- arranged so that it can be compiled
% ------------------------------------------------------------------------------

add_to_type(Type1,SVs2,Ref) if_b SubGoals :-  % unify_type/3 sorts by Type1 - cheaper to
  unify_type(Type1,Type2,Type3), %  drive off Type1 and not use if_h/2 than to
  add_to_typeact(Type2,Type3,Type1,SVs2,Ref,SubGoals). % drive off Type2 and save some calls to
                                                           % approps/2 below.

% ------------------------------------------------------------------------------
% 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,_,[]) :- !.
add_to_typeact(a_ X,a_ X,bot,a_ X,_,[]) :- !.
add_to_typeact(bot,a_ X,a_ X,bot,_-(a_ X),[]) :- !.
add_to_typeact(Type2,Type3,Type1,SVs2,Ref,SubGoals):-
  approps(Type2,FRs2,N2), functor(SVs2,Type2,N2),
  ( sub_type(Type1,Type2)  -> SubGoals = []  % if Type1 subsumes Type2, then do nothing
  ; N2 == 0 -> bind_mgsat(Type3,Ref,SubGoals,[])
       % if Type2 is atomic, then we can use MGSat for Type3 - we could instantiate Ref
               % to a type template if no constraints at Type3
  ; approps(Type3,FRs3,N3), functor(SVs3,Type3,N3), % o.w. need to find out which feat's are new
    nmap_new_feats(FRs2,FRs3,SVs2,1,SVs3,1,SubGoalsMid,SubGoalsRest),
    add_to_typecons(Type3,Type2,Ref,SubGoalsRest),
    ( SubGoalsRest == [] -> Ref = Tag3-SVs3, SubGoals = SubGoalsMid
    ; SubGoals = [(Ref = (Tag3-SVs3))|SubGoalsMid]
    )
  ).

% ------------------------------------------------------------------------------
% add_to_typecons(Type:type,ExclType:type,Tag:ref,SVs:svs,
%                 IqsIn:ineqs,IqsOut:ineqs,SubGoals:goals)
% ------------------------------------------------------------------------------
% Enforce the constraint for Type, and for all supersorts of Type, excluding
%  those in the ideal of ExclType, on Tag-SVs
% ------------------------------------------------------------------------------

add_to_typecons(Type,ET,FS,SubGoals) :-
  findall(T,(clause(constrained(T),true),
             sub_type(T,Type), % find set of types whose constraints
             \+sub_type(T,ET)),ConsTypes), %  must be satisfied
  map_cons(ConsTypes,FS,SubGoals,[]).
% this map_cons is the same as the one for ucons

% ------------------------------------------------------------------------------
% featval(F:feat,SVs:SVs,Ref:ref,V:fs,
%         IqsIn:ineqs,IqsOut:ineqs)                                    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) if_h SubGoals:-
  introduce(F,TypeIntro),
  unify_type(TypeIntro,Type,ResType),
  featval_act(Type,ResType,TypeIntro,SVs,Tag,SubGoals,F,V).
     % actually seems to pay to recompute this rather than compile featval
     % add_to_type code in one shot
%  deref(RefOut,SVs,_NewTag,NewSVs),
%  NewSVs =.. [_ResType|Vs],   % don't have to worry about atoms as long as
%  approps(ResType,FRs,_),       %  TypeIntro can't be bot (i.e. bot has no features)
%  find_featval(F,FRs,Vs,V).

% like add_to_typeact/6, but returns the value of F too.
featval_act(Type2,Type3,Type1,SVs2,Ref,SubGoals,F,V):-
  approps(Type2,FRs2,N2), functor(SVs2,Type2,N2),
  ( sub_type(Type1,Type2)  -> SubGoals = [],
                              fs_at_pos(FRs2,F,1,Pos), arg(Pos,SVs2,V)
  % o.w. even if N2 == 0, we need access to the resulting SVs to find V
  ; approps(Type3,FRs3,N3), functor(SVs3,Type3,N3),
    nmap_new_feats(FRs2,FRs3,SVs2,1,SVs3,1,SubGoalsMid,SubGoalsRest),
    add_to_typecons(Type3,Type2,Ref,SubGoalsRest),
    ( SubGoalsRest == [] -> Ref = Tag3-SVs3, SubGoals = SubGoalsMid
    ; SubGoals = [(Ref = (Tag3-SVs3))|SubGoalsMid]
    ),
    fs_at_pos(FRs3,F,1,Pos), arg(Pos,SVs3,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:fs, FS2:fs)
% ------------------------------------------------------------------------------
% 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:fs_seq)
% ------------------------------------------------------------------------------
% takes structure fs_seq 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),
  iso_seq_act(Tag1,SVs1,Tag2,SVs2,Isos).

iso_seq_act(Tag1,SVs1,Tag2,SVs2,Isos) :-
  ( (Tag1 == Tag2)
    -> iso_seq(Isos)
     ; (Tag1 = Tag2,
        iso_sub_seq(SVs1,SVs2,Isos))).

iso_sub_seq(a_ X,a_ Y,Isos) if_h [X==Y,iso_seq(Isos)]. % ext. like Prolog
iso_sub_seq(SVs1,SVs2,Isos) if_h SubGoal :-
  clause(extensional(Sort),true),
  \+ (Sort = a_ _),
  approps(Sort,_,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:ref, SVs:svs, Iqs:iqs)
%-------------------------------------------------------------------------------
% search for extensional types which should be unified in Tag-SVs, and its
%  inequations, and do it.  Extensional types are assumed to be maximal.
%-------------------------------------------------------------------------------
extensionalise(Ref,SVs) :-
  ext_act(fs(Ref,SVs,fsdone),edone).

extensionalise(FS) :-
  deref(FS,Ref,SVs),
  ext_act(fs(Ref,SVs,fsdone),edone).

ext_act(fs(Ref,SVs,FSs),ExtQ) :-
  check_pre_traverse(SVs,Ref,ExtQ,FSs).
ext_act(fsdone,_).  % KNOWN BUG - FSs in suspended goals only are not extensionalised.
%  ext_ineq(Ineqs,ExtQ,Iqs).

%ext_ineq(ineq(Ref1,SVs1,Ref2,SVs2,Ineqs),ExtQ,Iqs) :-
%  deref(Ref1,SVs1,DRef1,DSVs1),
%  deref(Ref2,SVs2,DRef2,DSVs2),
%  ext_act(fs(DRef1,DSVs1,fs(DRef2,DSVs2,fsdone)),ExtQ,Ineqs,Iqs).
%ext_ineq(done,ExtQ,Iqs) :-
%  ext_iqs(Iqs,ExtQ).

%ext_iqs([Iq|Iqs],ExtQ) :-
%  ext_ineq(Iq,ExtQ,Iqs).
%ext_iqs([],_).

extensionalise_list(FSList) :-
  list_to_fss(FSList,FSs),
  ext_act(FSs,edone).

list_to_fss([],fsdone).
list_to_fss([FS|FSList],fs(Tag,SVs,FSs)) :-
  deref(FS,Tag,SVs),
  list_to_fss(FSList,FSs).

check_pre_traverse(SVs,Ref,ExtQ,FSs) if_b [!|SubGoals] :-
  type(T),
  ( (T = (a_ _)) -> SVs = T,
                    SubGoals = [traverseQ(ExtQ,Ref,SVs,FSs,ExtQ)]
  ; clause(extensional(T),true) -> approps(T,_,N),
                                   functor(SVs,T,N),
                                   SubGoals = [traverseQ(ExtQ,Ref,SVs,FSs,ExtQ)]
  ).
check_pre_traverse(SVs,_,ExtQ,FSs) if_b
  [check_post_traverse(SVs,ExtQ,FSs)].

check_post_traverse(SVs,ExtQ,FSs) if_b [!|SubGoals] :-
  type(T),
  clause(ext_sub_structs(T,SVs,NewFSs,FSs,SubGoals,
                         [ext_act(NewFSs,ExtQ)]),true).
check_post_traverse(_,ExtQ,FSs) if_b
  [ext_act(FSs,ExtQ)].

% ------------------------------------------------------------------------------
% traverseQ(ExtQRest:exts,ExtQ:exts,Ref:ref,SVs:svs,FSs:fss,
%           Ineqs:ineqs,Iqs:iqs)
% ------------------------------------------------------------------------------
% Add Ref-SVs to the extensionality queue, ExtQ.  Only ExtQRest remains to
% traverse (ExtQ is the head).  If the difference is unbound, then add Ref-SVs
% to the end.  If the first element on the difference is the same FS as
% Ref-SVs, then no need to add.  If the first element can be extensionally
% identified with Ref-SVs, then stop looking, since now Ref-SVs is the same as
% that FS.  If none of these, then go on to the next element.
% ------------------------------------------------------------------------------
traverseQ(edone,Ref,SVs,FSs,ExtQ) :-
  check_post_traverse(SVs,ext(Ref,SVs,ExtQ),FSs).
traverseQ(ext(ERef,ESVs,ERest),Ref,SVs,FSs,ExtQ) :-
   ERef == Ref -> ext_act(FSs,ExtQ)
; iso_seq_act(Ref,SVs,ERef,ESVs,done) -> ext_act(FSs,ExtQ)
; traverseQ(ERest,Ref,SVs,FSs,ExtQ).

% ------------------------------------------------------------------------------
% check_inequal(IqsIn:ineqs,IqsOut:ineqs)
%-------------------------------------------------------------------------------
% 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)
%-------------------------------------------------------------------------------
% 5/1/96 Octav -- added a clause for the case the inequations list is
%   uninstantiated
% 5/5/97 Octav - removed test to allow for first argument indexing
%check_inequal(Var,Var) :- var(Var), !.
%check_inequal([],[]).
%check_inequal([IqIn|IqsIn],IqsOut) :-
%  check_inequal_conjunct(IqIn,IqOut,Result),
%  check_inequal_act(Result,IqOut,IqsIn,IqsOut).

%check_inequal_act(done,done,_,_) :-  % conjunct not satisfied
%  !,fail.
%check_inequal_act(succeed,_,IqsIn,IqsOut) :-  % conjunct satisfied
%  !,check_inequal(IqsIn,IqsOut).
%check_inequal_act(_,IqOut,IqsIn,[IqOut|IqsOut]) :-  % conjunct temporarily
%  check_inequal(IqsIn,IqsOut).                      %  satisfied

%check_inequal_conjunct(done,done,done).
%check_inequal_conjunct(ineq(ITag1,ISVs1,ITag2,ISVs2,IqInRest),IqOut,Result) :-
%  deref(ITag1,ISVs1,Tag1,SVs1),
%  deref(ITag2,ISVs2,Tag2,SVs2),
%  ( (Tag1 == Tag2)
%    -> check_inequal_conjunct(IqInRest,IqOut,Result)
%     ; ((SVs1 = a_ X) % fold in results of unify_type/3 and atom extensionality
%        -> ((SVs2 = a_ Y)
%            -> ((X==Y)
%                -> check_inequal_conjunct(IqInRest,IqOut,Result)
%                 ; ((\+ \+(X=Y))
%                    -> (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest),
%                        check_inequal_conjunct(IqInRest,IqOutRest,Result))
%                     ; (Result = succeed)))
%             ; (functor(SVs2,Sort2,_),
%                ((Sort2 \== bot)
%                 -> Result = succeed
%                  ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest),
%                     check_inequal_conjunct(IqInRest,IqOutRest,Result)))))
%         ; ((SVs2 = a_ _)
%            -> (functor(SVs1,Sort1,_),
%                ((Sort1 \== bot)
%                 -> Result = succeed
%                  ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest),
%                     check_inequal_conjunct(IqInRest,IqOutRest,Result))))
%             ; (functor(SVs1,Sort1,_),
%                functor(SVs2,Sort2,_),
%                (unify_type(Sort1,Sort2,_)
%                 -> (check_sub_seq(SVs1,SVs2,IqInRest,IqOut,Result)
%                     -> true
%                      ; (IqOut = ineq(Tag1,SVs1,Tag2,SVs2,IqOutRest),
%                         check_inequal_conjunct(IqInRest,IqOutRest,Result)))
%                  ; Result = succeed))))).

%check_sub_seq(_,_,_,_,_) if_h [fail] :-  % atoms never make it to check_sub_seq
%  \+ (extensional(S),(\+ (S = a_ _))).

%check_sub_seq(SVs1,SVs2,IqInRest,IqOut,Result) if_h SubGoal :-
%  extensional(Sort),
%  \+ (Sort = a_ _),
%  approps(Sort,_,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:type,Vs:vs,Tag:var,SVs:svs,Right:int,N:int,
%            Dtrs:ints,DtrsRest:var,NextRight:int,Chart:chart,
%            IqsIn:iqs,IqsOut:iqs)
% ------------------------------------------------------------------------------
% Run-time predicate compiled into rules.  Matches a list of cats in Chart,
%  specified by Sort(Vs), to span an edge to OldRight, the first of which is
%  Tag-SVs, which spans to Right.  Also matches an edge for the next category
%  of the current rule to use (necessary because an initial empty-list cats
%  matches nothing).
% ------------------------------------------------------------------------------
match_list(Sort,[HdFS,TlFS],Tag,SVs,Right,N,[N|DtrsMid],DtrsRest,Chart,
           NextRight) :-
  sub_type(ne_list,Sort),
  !,ud(HdFS,Tag,SVs),
  deref(TlFS,_,TlSVs),
  TlSVs =.. [TlSort|TlVs],  % a_ correctly causes error in recursive call
  match_list_rest(TlSort,TlVs,Right,NextRight,DtrsMid,DtrsRest,Chart).

match_list(Sort,_,_,_,_,_,_,_,_,_) :-
  error_msg((nl,write('error: cats> value with sort, '),write(Sort),
            write(' is not a valid argument (e_list or ne_list)'))).

% ------------------------------------------------------------------------------
% match_list_rest(Sorttype,Vs:vs,Right:int,NewRight:int,
%                 DtrsRest:ints,DtrsRest2:var,Chart:chart,IqsIn:iqs,
%                 IqsOut:iqs)
% ------------------------------------------------------------------------------
% 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,_) :-
  !.
match_list_rest(Sort,[HdFS,TlFS],Right,NewRight,[N|DtrsRest],DtrsRest2,Chart) :-
  sub_type(ne_list,Sort),
  !,get_edge(Right,Chart,N,MidRight,Tag,SVs,_,_),
  ud(HdFS,Tag,SVs),
  deref(TlFS,_,TlSVs),
  TlSVs =.. [TlSort|TlVs],  % a_ correctly causes error in recursive call
  match_list_rest(TlSort,TlVs,MidRight,NewRight,DtrsRest,DtrsRest2,Chart).
match_list_rest(Sort,_,_,_,_,_,_) :-
  error_msg((nl,write('error: cats> value with sort, '),write(Sort),
            write(' is not a valid argument (e_list or ne_list)'))).


% ==============================================================================
% Chart Parser
% [User's Manual] [Reference Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% rec(+Ws:words, Tag:var_tag, SVs:svs, Iqs:ineqs)
% [User's Manual]
% ------------------------------------------------------------------------------
% Ws can be parsed as category Tag-SVs with inequations Iqs;  Tag-SVs
%  uninstantiated to start
% ------------------------------------------------------------------------------
:- dynamic num/1.

rec(Ws,Tag,SVs,Residue) :-
  clear,
  assert(parsing(Ws)),
  asserta(num(0)),
  ( current_predicate(lex,lex(_,_))
  -> reverse_count_lex_check(Ws,[],WsRev,0,Length),
     CLength is Length - 1,
     functor(Chart,chart,CLength),
     build(WsRev,Length,Chart),
     retract(to_rebuild(Index)),
     call_residue((clause(edge(Index,0,Length,Tag,SVs,_,_),true),
                   extensionalise(Tag,SVs)),Residue),
     assert(solution(Index))
  ; raise_exception(ale(no_lex))
  ).

% ------------------------------------------------------------------------------
% rec(+Ws:words, Tag:var_tag, SVs:svs, Iqs:ineqs, ?Desc:desc)
% ------------------------------------------------------------------------------
% Like rec/3, but Tag-SVs also satisfies description, Desc.
% ------------------------------------------------------------------------------
rec(Ws,TagOut,SVsOut,Desc,Residue) :-
  clear,
  assert(parsing(Ws)),
  asserta(num(0)),
  ( current_predicate(lex,lex(_,_))
  -> reverse_count_lex_check(Ws,[],WsRev,0,Length),
     CLength is Length - 1,
     functor(Chart,chart,CLength),
     build(WsRev,Length,Chart),
     retract(to_rebuild(Index)),
     call_residue((clause(edge(Index,0,Length,Tag,SVs,_,_),true),
                   (secret_noadderrs
                   ; secret_adderrs,
                     fail),
                   add_to(Desc,Tag,SVs),
                   deref(Tag,SVs,TagOut,SVsOut),
                   extensionalise(TagOut,SVsOut),
                   (secret_adderrs
                   ; secret_noadderrs,
                     fail)),Residue),
     assert(solution(Index))
  ; raise_exception(ale(no_lex))
  ).

% ------------------------------------------------------------------------------
% build(Ws:words, Right:int, Chart:chart)
% ------------------------------------------------------------------------------
% fills in inactive edges of chart from beginning to Right using
% Ws, representing words in chart in reverse order.  Chart is the functor
% 'chart' of arity equal to the length of the input string (which is thus
%  bounded at 255).
% ------------------------------------------------------------------------------
build([W|Ws],Right,Chart):-
  RightMinus1 is Right - 1,
  (
% empty_cat(N,Right,Tag,SVs,Iqs,_,_),
%    rule(Tag,SVs,Iqs,Right,Right,empty(N,Right))
%  ;
    lex(W,FS), deref(FS,Tag,SVs), % KNOWN BUG: should pass FS rather than Tag-SVs pair
%    lex_goal(_-(a_ W),Tag-SVs),
    add_edge(RightMinus1,Right,Tag,SVs,[],lexicon,Chart)
  ; ( RightMinus1 =:= 0
      -> true
       ; rebuild_edges(Edges),
         arg(RightMinus1,Chart,Edges),
         build(Ws,RightMinus1,Chart)
    )
  ).
%build([],_):-
%  empty_cat(N,0,Tag,SVs,Iqs,_,_),
%  rule(Tag,SVs,Iqs,0,0,empty(N,0)).
build([],_,_).

% ------------------------------------------------------------------------------
% rebuild_edges(Edges:edges)
% ------------------------------------------------------------------------------
% Copy non-looping edges asserted into the database in the most recent pass
%  (all of the edges from the most recent node) into an edge/7 structure on
%  the heap for inclusion into the chart.  Copying them once now means that we
%  only copy an edge once in total rather than every time a rule asks for it.
%  We can do this because we have closed the rules under prefixes of empty
%  categories; so we know that no edge will be needed until closure at the next
%  node begins.
% ------------------------------------------------------------------------------
rebuild_edges(Edges) :-
  retract(to_rebuild(Index))
  -> clause(edge(Index,_,R,T,S,D,RN),true),
     Edges = edge(Index,R,T,S,D,RN,EdgesRest),
     rebuild_edges(EdgesRest)
   ; Edges = nomore.

% ------------------------------------------------------------------------------
% add_edge_deref(Left:int, Right:int, Tag:var_tag, SVs:svs,
%                Iqs:ineqs,Dtrs:fss,RuleName,Chart:chart)             eval
% ------------------------------------------------------------------------------
% adds dereferenced category Tag-SVs,Iqs as inactive edge from Left to Right;
% check for any rules it might start, then look for categories in Chart
% to complete those rules
% ------------------------------------------------------------------------------
add_edge_deref(Left,Right,Tag,SVs,Dtrs,RuleName,Chart):-
  fully_deref(Tag,SVs,TagOut,SVsOut),
  (no_subsumption
  -> (edge_assert(Left,Right,TagOut,SVsOut,Dtrs,RuleName,N)
     -> rule(TagOut,SVsOut,Left,Right,N,Chart))
   ; (subsumed(Left,Right,TagOut,SVsOut,Dtrs,RuleName)
     -> fail
      ; (edge_assert(Left,Right,TagOut,SVsOut,Dtrs,RuleName,N)
        -> rule(TagOut,SVsOut,Left,Right,N,Chart)))).

add_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,Chart):-
  (no_subsumption
  -> (edge_assert(Left,Right,TagOut,SVsOut,Dtrs,RuleName,N)
     -> rule(TagOut,SVsOut,Left,Right,N,Chart))
   ; (subsumed(Left,Right,TagOut,SVsOut,Dtrs,RuleName)
     -> fail
      ; (edge_assert(Left,Right,TagOut,SVsOut,Dtrs,RuleName,N)
        -> rule(TagOut,SVsOut,Left,Right,N,Chart)))).

gennum(N) :-
  retract(num(N)),
  NewN is N+1,
  asserta(num(NewN)).

gen_emptynum(N) :-
  retract(emptynum(N)),
  NewN is N-1,
  asserta(emptynum(NewN)).

count_edges(N):-
  setof(edge(M,X,Y,Z,W,D,R),edge(M,X,Y,Z,W,D,R),Es),
  length(Es,N).

% ------------------------------------------------------------------------------
% get_edge(Left:int,Chart:chart,Index:int,Right:int,Tag:ref,
%          SVs:svs,EdgeIqs:iqs,Dtrs:ints,RuleName:atom)
% ------------------------------------------------------------------------------
% Retrieve an edge from the chart, which means either an empty category
% or one of the non-empty edges in Chart
% ------------------------------------------------------------------------------

get_edge(Right,_,empty(N,Right),Right,Tag,SVs,Dtrs,RuleName) :-
  empty_cat(N,Right,Tag,SVs,Dtrs,RuleName).
get_edge(Left,Chart,N,Right,Tag,SVs,Dtrs,RuleName) :-
  arg(Left,Chart,Edges),
  edge_member(Edges,N,Right,Tag,SVs,Dtrs,RuleName).
%  clause(edge(Left,N,Right,Tag,SVs,EdgeIqs,Dtrs,RuleName),true).

edge_member(edge(I,R,T,S,D,RN,Edges),N,Right,Tag,SVs,Dtrs,RuleName) :-
  I = N, R = Right, T = Tag, S = SVs, D = Dtrs, RN = RuleName
; edge_member(Edges,N,Right,Tag,SVs,Dtrs,RuleName).

% ------------------------------------------------------------------------------
% subsumed(Left:int,Right:int,Tag:var_tag,SVs:svs,Iqs:ineqs,
%          Dtrs:ints,RuleName)
% ------------------------------------------------------------------------------
% Check if any edge spanning Left to Right subsumes Tag-SVs, the feature
%  structure of the candidate edge, or vice versa.  Succeeds based on whether
%  or not Tag-SVs is subsumed - but all edges subsumed by Tag-SVs are also
%  retracted.
% ------------------------------------------------------------------------------
subsumed(Left,Right,Tag,SVs,Dtrs,RuleName) :-
  clause(to_rebuild(EI),true),
  clause(edge(EI,Left,Right,ETag,ESVs,_,_),true), %this may have >1 soln
  empty_assoc(H),
  empty_assoc(K),
  frozen_term([Tag|SVs],Frozen),
  frozen_term([ETag|ESVs],EFrozen),
  build_iqs(Frozen,Iqs,_),  % don't use other suspensions in subsumption calculation
  build_iqs(EFrozen,EIqs,_),
  subsume(s(Tag,SVs,ETag,ESVs,sdone),<,>,LReln,RReln,H,K,Iqs,EIqs),
  subsumed_act(RReln,LReln,EI,Tag,SVs,Dtrs,RuleName,Left,Right).

subsumed_act(>,LReln,EI,Tag,SVs,Dtrs,RuleName,Left,Right) :- %edge subsumes
  !,edge_discard(LReln,EI,Tag,SVs,Dtrs,RuleName,Left,Right). % candidate
subsumed_act(#,<,EI,Tag,SVs,Dtrs,RuleName,Left,_) :- % candidate
  edge_retract(Left,EI,Tag,SVs,Dtrs,RuleName).       % subsumes edge
% subsumed_act(#,#,_,_,_,_,_,_,_) fails

% subsume(Ss,Iqs1,Iqs2,LeftRelnIn,RightRelnIn,LeftRelnOut,RightRelnOut,H,K)
% ------------------------------------------------------------------------------
% LeftRelnOut is bound to < if LeftRelnIn is not # and there exists a
%  subsumption morphism, H (see Carpenter, 1992, p. 41) from Tag1-SVs1 to
%  Tag2-SVs2, for every s(Tag1,SVs1,Tag2,SVs2,_) in Ss, and from the
%  inequations in Iqs1 to those in Iqs2.  Otherwise, LeftRelnOut is bound to
%  #.  RightRelnOut is bound to > if RightRelnIn is not #, and
%  a subsumption morphism, K, exists in the reverse direction, and is bound
%  otherwise to #.  The FS's in the s-structures are expected to be fully
%  dereferenced, with irrelevant inequations pruned off (which can be
%  achieved by using fully_deref_prune).
% ------------------------------------------------------------------------------
subsume(sdone,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K,Iqs,EIqs) :-
  subsume_iqs(Iqs,EIqs,LRelnIn,LRelnOut,H),  % as a last resort, try to
  subsume_iqs(EIqs,Iqs,RRelnIn,RRelnOut,K).  % disprove subsumption using ineqs
subsume(s(Tag,SVs,ETag,ESVs,Ss),LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K,Iqs,EIqs) :-
  get_assoc(Tag,H,HPair)
  -> (get_assoc(ETag,K,KPair)  % first try to disprove subsumption using
     -> HPair = [HTag|_],      %  observed structure sharing at current roots
        KPair = [KTag|_],
        (KTag == Tag
        -> (HTag == ETag
           -> ((LRelnIn == #,RRelnIn == #)
              -> LRelnOut = #,RRelnOut = #  % we can quit once we show this
               ; subsume(Ss,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K,Iqs,EIqs)
              )
            ; LRelnOut = #,
              (RRelnIn == #
              -> RRelnOut = #
               ; subsume(Ss,#,RRelnIn,#,RRelnOut,H,K,Iqs,EIqs)
              )
           )
         ; RRelnOut = #,
           (HTag == ETag
           -> (LRelnIn == #
              -> LRelnOut = #
               ; subsume(Ss,LRelnIn,#,LRelnOut,#,H,K,Iqs,EIqs)
              )
            ; LRelnOut = #, RRelnOut = #
           )
        )
     ; LRelnOut = #,
       (RRelnIn == #
       -> RRelnOut = #
        ; subsume_type(SVs,ESVs,Tag,ETag,Ss,#,RRelnIn,#,RRelnOut,H,K,Iqs,EIqs)
       )
    )
  ; (get_assoc(ETag,K,KPair)
    -> RRelnOut = #,
       (LRelnIn == #
       -> LRelnOut = #
        ; subsume_type(Tag,SVs,ETag,ESVs,Ss,LRelnIn,#,LRelnOut,#,H,K,Iqs,EIqs)
       )
     ; subsume_type(SVs,ESVs,Tag,ETag,Ss,LRelnIn,RRelnIn,LRelnOut,RRelnOut,H,K,Iqs,EIqs)
    ).

% next try to disprove subsumption using type information at root node
subsume_type(bot,(a_ X),Tag,ETag,Ss,LRelnIn,_RRelnIn,LRelnOut,
             RRelnOut,H,K,Iqs,EIqs) if_b [!,RRelnOut = #,
                                          (LRelnIn == #
                                          -> LRelnOut = #
                                           ; put_assoc(Tag,H,[ETag|(a_ X)],NewH),
                                             subsume(Ss,LRelnIn,#,LRelnOut,#,NewH,K,Iqs,EIqs)
                                          )].
subsume_type((a_ X),bot,Tag,ETag,Ss,_LRelnIn,RRelnIn,LRelnOut,
             RRelnOut,H,K,Iqs,EIqs) if_b [!,LRelnOut = #,
                                          (RRelnIn == #
                                          -> RRelnOut = #
                                           ; put_assoc(ETag,K,[Tag|(a_ X)],NewK),
                                             subsume(Ss,#,RRelnIn,#,RRelnOut,H,NewK,Iqs,EIqs)
                                          )].
subsume_type((a_ X),(a_ Y),Tag,ETag,Ss,LRelnIn,RRelnIn,LRelnOut,
             RRelnOut,H,K,Iqs,EIqs) if_b [!,(subsumes_chk(X,Y)   % this is all variant/2
                                            -> (subsumes_chk(Y,X) % does anyway
                                               -> ((LRelnIn == #
                                                   -> LRelnOut = #, H = NewH
                                                    ; put_assoc(Tag,H,[ETag|(a_ Y)],
                                                                NewH)
                                                   ),
                                                   (RRelnIn == #
                                                   -> RRelnOut = #, K = NewK
                                                    ; put_assoc(ETag,K,[Tag|(a_ X)],
                                                                NewK)
                                                   ),
                                                   subsume(Ss,LRelnIn,RRelnIn,
                                                           LRelnOut,RRelnOut,NewH,NewK,Iqs,EIqs)
                                                  )
                                               ; RRelnOut = #,
                                                 (LRelnIn == #
                                                 -> LRelnOut = #
                                                  ; put_assoc(Tag,H,[ETag|(a_ Y)],
                                                              NewH),
                                                    subsume(Ss,LRelnIn,#,LRelnOut,#,NewH,K,Iqs,EIqs)
                                                 )
                                               )
                                            ; (subsumes_chk(Y,X)
                                              -> LRelnOut = #,
                                                 (RRelnIn == #
                                                 -> RRelnOut = #
                                                  ; put_assoc(ETag,K,[Tag|(a_ X)],
                                                              NewK),
                                                    subsume(Ss,#,RRelnIn,#,RRelnOut,H,NewK,Iqs,EIqs)
                                                 )
                                               ; LRelnOut = #, RRelnOut = #
                                              )
                                            )].
subsume_type(SVs,ESVs,Tag,ETag,Ss,LRelnIn,RRelnIn,LRelnOut,RRelnOut,
             H,K,Iqs,EIqs) if_b SubGoals :-
  non_a_type(Sort),  % dont want a_/1 atoms
  approps(Sort,FRs,N),
  length(Vs,N),
  SVs =.. [Sort|Vs],
  subsume_type_act(Sort,FRs,N,Vs,SVs,ESVs,Tag,ETag,Ss,LRelnIn,RRelnIn,
                   LRelnOut,RRelnOut,H,K,Iqs,EIqs,SubGoals).

subsume_type_act(Sort,_FRs,N,Vs,SVs,ESVs,Tag,ETag,Ss,LRelnIn,RRelnIn,
                 LRelnOut,RRelnOut,H,K,Iqs,EIqs,[!,(LRelnIn == #
                                                   -> LRelnOut = #, H = NewH
                                                    ; put_assoc(Tag,H,[ETag|ESVs],NewH)
                                                   ),
                                                   (RRelnIn == #
                                                   -> RRelnOut = #, K = NewK
                                                    ; put_assoc(ETag,K,[Tag|SVs],NewK)
                                                   ),
                                                   subsume(NewSs,LRelnIn,
                                                           RRelnIn,LRelnOut,RRelnOut,
                                                           NewH,NewK,Iqs,EIqs)]) :-
  length(EVs,N),
  append_s(Vs,EVs,Ss,NewSs),
  ESVs =.. [Sort|EVs].
subsume_type_act(Sort,FRs,_N,Vs,_SVs,ESVs,Tag,ETag,Ss,LRelnIn,
                 _RRelnIn,LRelnOut,RRelnOut,H,K,Iqs,EIqs,
                 [!,RRelnOut = #,
                  (LRelnIn == #
                  -> LRelnOut = #
                   ; put_assoc(Tag,H,[ETag|ESVs],NewH),
                     subsume(NewSs,LRelnIn,#,LRelnOut,#,NewH,K,Iqs,EIqs)
                  )]) :-
  sub_type(Sort,ESort), \+ functor(ESort,'a_',1), ESort \== Sort,
  approps(ESort,EFRs,EN),
  length(EVs,EN),
  sub_feats(FRs,EFRs,EVs,SubEVs),
  append_s(Vs,SubEVs,Ss,NewSs),
  ESVs =.. [ESort|EVs].
subsume_type_act(Sort,FRs,_N,Vs,SVs,ESVs,Tag,ETag,Ss,_LRelnIn,RRelnIn,
                 LRelnOut,RRelnOut,H,K,Iqs,EIqs,[!,LRelnOut = #,
                                                   (RRelnIn == #
                                                   -> RRelnOut = #
                                                    ; put_assoc(ETag,K,[Tag|SVs],NewK),
                                                      subsume(NewSs,#,RRelnIn,
                                                              #,RRelnOut,H,NewK,Iqs,EIqs)
                                                   )]) :-
  sub_type(ESort,Sort), \+ functor(Sort,'a_',1), Sort \== ESort,
  approps(ESort,EFRs,EN),
  length(EVs,EN),
  sub_feats(EFRs,FRs,Vs,SubVs),
  append_s(SubVs,EVs,Ss,NewSs),
  ESVs =.. [ESort|EVs].
subsume_type_act(_,_,_,_,_,_,_,_,_,_,_,_,_,#,#,_,_,_,_,[]).
                 % still need 1 arg to multi-hash

subsume_iqs([],_,Reln,Reln,_).
subsume_iqs([Iq|Iqs1],Iqs2,RelnIn,RelnOut,H) :-
  RelnIn == #
  -> RelnOut = #
   ; subsume_iq(Iq,Iqs2,RelnIn,RelnMid,H), % make sure image of each conjunct
     subsume_iqs(Iqs1,Iqs2,RelnMid,RelnOut,H). % holds in image FS

%subsume_iq(done,Iqs2Out,RelnIn,RelnOut,_) :- % negated image of conjunct is
%  check_inequal(Iqs2Out,_)      % satisfied by image FS, so no subsumption
%  -> RelnOut = #                % morphism exists.
%   ; RelnOut = RelnIn.    % image of conjunct is satisfied by an
%                          %  inequation conjunct of the image FS (which
%                          %  failed in the check_inequal/2 call)
subsume_iq(done,_,_,#,_). % negated image of conjunct is
                          % satisfied by image FS, so no subsumption
                          % morphism exists.
subsume_iq(ineq(Tag1,SVs1,Tag2,SVs2,IqRest),Iqs2Mid,RelnIn,RelnOut,H) :-
  (get_assoc(Tag1,H,HPair1)   % test which inequated FS has an image
  -> HPair1 = [HTag1|HSVs1],
     (get_assoc(Tag2,H,HPair2)
     -> HPair2 = [HTag2|HSVs2],
        unify_disjunct_image(HTag1,HSVs1,HTag2,HSVs2,IqRest,Iqs2Mid,
                             RelnIn,RelnOut,H)
      ; unify_disjunct_image(HTag1,HSVs1,Tag2,SVs2,IqRest,Iqs2Mid,
                             RelnIn,RelnOut,H)
     )
   ; get_assoc(Tag2,H,HPair2), % inequation was not pruned, so this one exists
     HPair2 = [HTag2|HSVs2],
     unify_disjunct_image(Tag1,SVs1,HTag2,HSVs2,IqRest,Iqs2Mid,
                          RelnIn,RelnOut,H)
     % use an inequated FS with no image itself for matching conjuncts
  )
  -> true
   ; RelnOut = RelnIn.  %  image of conjunct is
                        %  implicitly encoded in the image FS (since
                        %  unifying the images of the inequated FSs of
                        %  every disjunct failed earlier in this clause).

unify_disjunct_image(Tag1,SVs1,Tag2,SVs2,IqRest,Iqs2Mid,RelnIn,RelnOut,H) :-
  call_u(SVs1,SVs2,Tag1,Tag2), % KNOWN BUG - this could have side effects
  subsume_iq(IqRest,Iqs2Mid,RelnIn,RelnOut,H).


% sub_feats(SubFRs,FRs,Vs,SubVs)
% ------------------------------------------------------------------------------
% SubFRs is a sorted sublist of sorted feature:restriction list, FRs.  Vs is
%  a list of values of features of FRs in order.  SubVs is the sublist of Vs
%  consisting of values of features of SubFRs in order.
% ------------------------------------------------------------------------------
sub_feats([],_,_,[]) :-
  !.
sub_feats([Feat:_|SubFRs],[Feat:_|FRs],[V|Vs],[V|SubVs]) :-
  !,sub_feats(SubFRs,FRs,Vs,SubVs).
sub_feats(SubFRs,[_|FRs],[_|Vs],SubVs) :-
  sub_feats(SubFRs,FRs,Vs,SubVs).

% append_s(Vs,EVs,Ss,NewSs)
% ------------------------------------------------------------------------------
% NewSs is Ss plus in-order pairs of FS's from Vs and EVs (which are the same
%  length), in s-structures.
% ------------------------------------------------------------------------------
append_s([],[],Ss,Ss).
append_s([Tag-SVs|Vs],[ETag-ESVs|EVs],Ss,s(Tag,SVs,ETag,ESVs,NewSs)) :-
  append_s(Vs,EVs,Ss,NewSs).


% edge_discard(LReln:var/#,I:int,Tag:var_tag,SVs:svs,Iqs:ineqs,
%             Dtrs:ints,RuleName,Left:int,Right:int)
% ------------------------------------------------------------------------------
% Discard edge Tag-SVs, with inequations Iqs, daughters Dtrs, created by rule
%  RuleName, because it is subsumed by the edge with index I.  If LReln is a
%  variable, then the two are equal - otherwise, LReln is #, which indicates
%  strict subsumption.
% ------------------------------------------------------------------------------
edge_discard(_,_,_,_,_,_,_,_) :-
  no_interpreter,
  !.
edge_discard(LReln,I,Tag,SVs,Dtrs,RuleName,Left,Right) :-
  length(Dtrs,ND),
  !, (show_res -> frozen_term([Tag|SVs],Frozen) ; Frozen = []),
  print_edge_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Frozen).

print_edge_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
((current_predicate(portray_edge_discard,portray_edge_discard(_,_,_,_,_,_,_,_,_)),
   portray_edge_discard(LReln,I,Left,Right,Tag,SVs,RuleName,ND,Res)) -> true
; nl,pp_fs_res(Tag,SVs,Res),
   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,Dtrs,RuleName,ND,Res).

print_edge_discard_act(<,I) :-
  !,nl,write('is equal to an existing edge, index:'),write(I),write('.').
print_edge_discard_act(#,I) :-
  nl,write('is subsumed by an existing edge, index:'),write(I),write('.').

query_discard(_,_,_,_,_,_,_,_,_,_) :-
  go(_),
  !.
query_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  nl,write('Action(noadd,continue,break,dtr-#,existing,abort)? '),
  nl,read(Response),
  query_discard_act(Response,LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).

query_discard_act(noadd,_,_,_,_,_,_,_,_,_,_) :- !.
query_discard_act(continue,_,_,_,_,_,_,_,_,_,_) :-
  !,fail.
query_discard_act(break,LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  !,break,
  print_edge_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).
query_discard_act(dtr-D,LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DResidue),
  !,length(DDtrs,DND),
  print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DResidue),
  print_edge_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).
query_discard_act(existing,LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  call_residue(clause(edge(I,Left,Right,ETag,ESVs,EDtrs,ERuleName),true),ERes),
  !,edge_act(I,Left,Right,ETag,ESVs,EDtrs,ERuleName,ERes),
  print_edge_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).
query_discard_act(abort,_,_,_,_,_,_,_,_,_,_) :-
  !,abort.
query_discard_act(_,LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  query_discard(LReln,I,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).

% edge_retract(Left:int,I:int,Tag:var_tag,SVs:svs,Iqs:ineqs,
%              Dtrs:ints,RuleName:atom)
% ------------------------------------------------------------------------------
% Retract edge with index I because it is subsumed by Tag-SVs, with inequations
%  Iqs, daughters Dtrs, created by rule RuleName
% ------------------------------------------------------------------------------
edge_retract(Left,I,_,_,_,_) :-
  no_interpreter,
  retract(to_rebuild(I)),
  retract(edge(I,Left,_,_,_,_,_)),
  !,fail.     % failure-drive through all subsumed edges

edge_retract(Left,I,Tag,SVs,Dtrs,RuleName) :-
  !,call_residue(clause(edge(I,Left,Right,ETag,ESVs,EDtrs,ERuleName),true),ERes),
  length(EDtrs,NED),
  print_edge_retract(I,Left,Right,ETag,ESVs,EDtrs,ERuleName,NED,ERes,
                     Tag,SVs,Dtrs,RuleName).

print_edge_retract(I,Left,Right,ETag,ESVs,EDtrs,ERuleName,NED,ERes,
                   Tag,SVs,Dtrs,RuleName) :-
((current_predicate(portray_edge_retract,portray_edge_retract(_,_,_,_,_,_,_,_)),
   portray_edge_retract(I,Left,Right,ETag,ESVs,ERuleName,NED,ERes)) -> true
; nl,pp_fs_res(ETag,ESVs,ERes),
   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,EDtrs,ERuleName,NED,ERes,
               Tag,SVs,Dtrs,RuleName).

query_retract(Left,I,_,_,_,_,_,_,_,_,_,_,_) :-
  go(_),
  retract(edge(I,Left,_,_,_,_,_)),
  retract(to_rebuild(I)),
  !,fail.
query_retract(Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,ERes,
              Tag,SVs,Dtrs,RuleName) :-
  nl,write('Action(retract,continue,break,dtr-#,incoming,abort)? '),
  nl,read(Response),
  query_retract_act(Response,Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                    ERes,Tag,SVs,Dtrs,RuleName).
query_retract_act(retract,Left,I,_,_,_,_,_,_,_,_,_,_,_) :-
  retract(edge(I,Left,_,_,_,_,_)),
  retract(to_rebuild(I)),
  !,fail.
query_retract_act(remain,_,_,_,_,_,_,_,_,_,_,_,_,_) :-
  !,fail.
query_retract_act(continue,_,_,_,_,_,_,_,_,_,_,_,_,_) :-
  !.
query_retract_act(break,Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                  ERes,Tag,SVs,Dtrs,RuleName) :-
  !,break,
  print_edge_retract(I,Left,Right,ETag,ESVs,EDtrs,ERuleName,NED,ERes,
                     Tag,SVs,Dtrs,RuleName).
query_retract_act(dtr-D,Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                  ERes,Tag,SVs,Dtrs,RuleName) :-
  nth_index(EDtrs,D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DResidue),
  !,length(DDtrs,DND),
  print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DResidue),
  print_edge_retract(I,Left,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                     ERes,Tag,SVs,Dtrs,RuleName).
query_retract_act(incoming,Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                  ERes,Tag,SVs,Dtrs,RuleName) :-
  !,length(Dtrs,ND),
  (show_res -> frozen_term([Tag|SVs],Frozen) ; Frozen = []),
  ( print_incoming_edge(Left,Right,Tag,SVs,Dtrs,RuleName,ND,Frozen)
   -> true
    ; print_edge_retract(I,Left,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                         ERes,Tag,SVs,Dtrs,RuleName)).
query_retract_act(abort,_,_,_,_,_,_,_,_,_,_,_,_,_) :-
  !,abort.
query_retract_act(_,Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                  ERes,Tag,SVs,Dtrs,RuleName) :-
  query_retract(Left,I,Right,ETag,ESVs,EDtrs,ERuleName,NED,
                ERes,Tag,SVs,Dtrs,RuleName).

print_incoming_edge(Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
((current_predicate(portray_incoming_edge,portray_incoming_edge(_,_,_,_,_,_,_)),
   portray_incoming_edge(Left,Right,Tag,SVs,RuleName,ND,Res)) -> true
; nl,pp_fs_res(Tag,SVs,Res),
   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),nl
),
query_incoming_edge(Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).

query_incoming_edge(Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  nl,write('Action(noadd,dtr-#,existing,abort)?' ),
  nl,read(Response),
  query_incoming_act(Response,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).
query_incoming_act(noadd,_,_,_,_,_,_,_,_) :-
  !.
query_incoming_act(existing,_,_,_,_,_,_,_,_) :-
  !,fail.
query_incoming_act(abort,_,_,_,_,_,_,_,_) :-
  !,abort.
query_incoming_act(dtr-D,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DResidue),
  !,length(DDtrs,DND),
  print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DResidue),
  print_incoming_edge(Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).
query_incoming_act(_,Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  query_incoming_edge(Left,Right,Tag,SVs,Dtrs,RuleName,ND,Res).

% ==============================================================================
% Interpreter
% ==============================================================================

edge_assert(Left,Right,TagOut,SVsOut,Dtrs,RuleName,N) :-
  no_interpreter,
  !,gennum(N),
  asserta(to_rebuild(N)),
  asserta(edge(N,Left,Right,TagOut,SVsOut,Dtrs,RuleName)),
%  format('Edge added: Number: ~w, Left: ~w, Right: ~w, Rule: ~w~n',
%         [N,Left,Right,RuleName]), % DEBUG
  ttyflush.

edge_assert(Left,Right,TagOut,SVsOut,Dtrs,RuleName,N) :-
  !,nl,
  length(Dtrs,ND),
  (show_res -> frozen_term([TagOut|SVsOut],Frozen) ; Frozen = []),
  ( print_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Frozen)
  -> gennum(N),
     asserta(to_rebuild(N)),
     asserta(edge(N,Left,Right,TagOut,SVsOut,Dtrs,RuleName))).

print_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res) :-
((current_predicate(portray_edge,portray_edge(_,_,_,_,_,_,_,_)),
   portray_edge(pending,Left,Right,TagOut,SVsOut,RuleName,ND,Res)) -> true
; nl,pp_fs_res(TagOut,SVsOut,Res),
   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,Dtrs,RuleName,ND,Res).

query_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res) :-
  go(Left),               % right-to-left parser triggers on left
  !,retractall(go(_)),
  query_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res).
query_edge(_,_,_,_,_,_,_,_) :-
  go(_),
  !.
query_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res) :-
  nl,write('Action(add,noadd,go(-#),break,dtr-#,abort)? '),
  nl,read(Response),
  query_edge_act(Response,Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res).

query_edge_act(add,_,_,_,_,_,_,_,_) :-
  !.
query_edge_act(noadd,_,_,_,_,_,_,_,_) :-
  !,fail.
query_edge_act(go,_,_,_,_,_,_,_,_) :-
  !,asserta(go(go)).
query_edge_act(go-G,_,_,_,_,_,_,_,_) :-
  !,asserta(go(G)).
query_edge_act(break,Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res) :-
  !,break,
  print_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res).
query_edge_act(dtr-D,Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res):-
  nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DResidue),
  !,length(DDtrs,DND),
  print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DResidue),
  print_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res).
query_edge_act(abort,_,_,_,_,_,_,_,_) :-
  !,abort.
query_edge_act(_,Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res) :-
  query_edge(Left,Right,TagOut,SVsOut,Dtrs,RuleName,ND,Res).

print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DRes) :-
((current_predicate(portray_dtr_edge,portray_dtr_edge(_,_,_,_,_,_,_,_)),
   portray_dtr_edge(D,DLeft,DRight,DTag,DSVs,DRule,DND,DRes)) -> true
; nl,pp_fs_res(DTag,DSVs,DRes),
   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),nl
),
query_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DRes).

query_dtr_edge(D,I,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DRes) :-
  nl,write('Action(retract,dtr-#,parent,abort)?' ),
  nl,read(Response),
  query_dtr_act(Response,D,I,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DRes).
query_dtr_act(parent,_,_,_,_,_,_,_,_,_,_) :-
  !.
query_dtr_act(retract,_,I,DLeft,_,_,_,_,_,_,_) :-
  retract(edge(I,DLeft,_,_,_,_,_)),  % will fail on empty cats
  !.
query_dtr_act(abort,_,_,_,_,_,_,_,_,_,_) :-
  !,abort.
query_dtr_act(dtr-DD,D,I,Left,Right,Tag,SVs,Dtrs,Rule,ND,Res) :-
  nth_index(Dtrs,DD,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DRes),
  !,length(DDtrs,DND),
  print_dtr_edge(DD,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DRes),
  print_dtr_edge(D,I,Left,Right,Tag,SVs,Dtrs,Rule,ND,Res).
query_dtr_act(_,D,I,Left,Right,Tag,SVs,Dtrs,Rule,ND,Res) :-
  query_dtr_edge(D,I,Left,Right,Tag,SVs,Dtrs,Rule,ND,Res).

nth_index([I|Is],N,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,Residue) :-
  N =:= 1
  -> DI = I,
     (I = empty(E,DLeft)
     -> call_residue(empty_cat(E,DLeft,DTag,DSVs,DDtrs,DRule),Residue),
        DLeft = DRight
      ; (call_residue(clause(edge(I,DLeft,DRight,DTag,DSVs,DDtrs,DRule),true),Residue)
        -> true
         ; error_msg((nl,write('edge has been retracted')))
        )
     )
   ; NMinus1 is N-1,
     nth_index(Is,NMinus1,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,Residue).


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

% fsolve(Fun:fun,Ref:ref,SVs:svs,IqsIn:ineqs,IqsOut:ineqs)
% ------------------------------------------------------------------------------
%  Solve function constraint, Fun, along with its argument descriptions.
% ------------------------------------------------------------------------------
%fsolve(_,_,_,_,_) if_b [fail] :-
%  \+ current_predicate(+++>,+++>(_,_)).
%fsolve(_,_,_,_,_) if_b [fail] :-
%  current_predicate(+++>,+++>(_,_)),
%  \+ (_ +++> _).
%fsolve(Fun,Tag,SVs,IqsIn,IqsOut) if_b Goals :-
%  current_predicate(+++>,+++>(_,_)),
%  empty_assoc(VarsIn),
%  empty_assoc(NVs),
%  (FHead +++> FResult),
%  FHead =.. [Rel|ArgDescs],
%  compile_descs(ArgDescs,Args,IqsIn,IqsMid,GoalsMid,
%                [check_inequal(IqsMid,IqsMid2)|GoalsMid2],true,VarsIn,VarsMid,
%                FSPal,[],FSsMid,NVs),
%  Fun =.. [Rel|Args],
%  compile_desc(FResult,Tag,SVs,IqsMid2,IqsOut,GoalsMid2,[],true,VarsMid,_,FSPal,
%               FSsMid,FSsOut,NVs),
%  build_fs_palette(FSsOut,FSPal,Goals,GoalsMid,[]).


% ==============================================================================
% Definite Clause Resolution/Compilation
% ==============================================================================

% ------------------------------------------------------------------------------
% compile_body(GoalDesc,IqsIn,IqsOut,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,
%              FSPal,FSsIn,FSsOut)
% ------------------------------------------------------------------------------
% compiles arbitrary Goal.
% PGoals is instantiated to list of Prolog goals required to add
% arguments relations in Goal and then call the procedure to solve them.
% IqsIn and IqsOut are uninstantiated at compile time.
% ------------------------------------------------------------------------------
% 4/1/96 - Octav -- changed compile_body/7 to take an extra argument that's
% used for computing the Goals list as difference list
compile_body(((GD1,GD2),GD3),PGoals,PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_body((GD1,(GD2,GD3)),PGoals,PGoalsRest,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_body(((IfD -> ThenD ; ElseD),PGD),
             [(IfG -> ThenG ; ElseG)|PGoalsMid],PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !,compile_body(IfD,IfGoals,[],CBSafe,VarsIn,VarsIf,FSPal,FSsIn,
                 FSsIf,NVs),
  compile_body(ThenD,ThenGoals,[],false,VarsIf,VarsThen,FSPal,
               FSsIf,FSsThen,NVs),
  compile_body(ElseD,ElseGoals,[],false,VarsIn,VarsElse,FSPal,
               FSsIn,FSsElse,NVs),
  goal_list_to_seq(IfGoals,IfG),
  goal_list_to_seq(ThenGoals,ThenG),
  goal_list_to_seq(ElseGoals,ElseG),
  vars_merge(VarsThen,VarsElse,VarsMid),
  fss_merge(FSsThen,FSsElse,FSsMid),
  compile_body(PGD,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut,
               FSPal,FSsMid,FSsOut,NVs).
compile_body(((GD1;GD2),GD3),PGoals,PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_body(((GD1,GD3);(GD2,GD3)),PGoals,PGoalsRest,CBSafe,
                  VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_body((\+ GD1, GD2),[(\+ PGoal)|PGoalsMid],PGoalsRest,
             CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_body(GD1,PGoalsList,[],CBSafe,VarsIn,_,FSPal,FSsIn,_,NVs),
  goal_list_to_seq(PGoalsList,PGoal),
  compile_body(GD2,PGoalsMid,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
               FSsIn,FSsOut,NVs).
compile_body((Desc1 =@ Desc2,GD),PGoals,PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
   !, compile_descs_fresh([Desc1,Desc2],[FS1,FS2],PGoals,
  [deref(FS1,DTag1,DSVs1),
                           deref(FS2,DTag2,DSVs2),
   ext_act(fs(DTag1,DSVs1,fs(DTag2,DSVs2,fsdone)),edone),
                           deref(DTag1,DSVs1,Tag1Out,_),
                           deref(DTag2,DSVs2,Tag2Out,_),
                           (Tag1Out == Tag2Out)|PGoalsMid],CBSafe,VarsIn,VarsMid,
  FSPal,FSsIn,FSsMid,NVs),
   compile_body(GD,PGoalsMid,PGoalsRest,CBSafe,VarsMid,
                VarsOut,FSPal,FSsMid,FSsOut,NVs).
compile_body((Desc1 = Desc2,GD),PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,
     FSPal,FSsIn,FSsOut,NVs) :-
  !, compile_desc(Desc1,Tag,bot,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
  FSsIn,FSsMid,NVs),
  compile_desc(Desc2,Tag,bot,PGoalsMid,PGoalsMid2,
       CBSafe,VarsMid,VarsMid2,FSPal,FSsMid,FSsMid2,NVs),
  compile_body(GD,PGoalsMid2,PGoalsRest,CBSafe,VarsMid2,VarsOut,FSPal,FSsMid2,
       FSsOut,NVs).
compile_body((true,GD),PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  !, compile_body(GD,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
                  FSsIn,FSsOut,NVs).
compile_body((fail,_),[fail|PGoalsRest],PGoalsRest,_,Vars,Vars,_,FSs,FSs,_):-
  !.
compile_body((!,PGD),[!|PGoalsMid],PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_body(PGD,PGoalsMid,PGoalsRest,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_body(((IfD -> ThenD),PGD),PGoals,PGoalsRest,CBSafe,
             VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !,compile_body(((IfD -> ThenD ; fail),PGD),PGoals,PGoalsRest,
                 CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_body((prolog(Goal),GD),PGoals,PGoalsRest,CBSafe,
             VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !, desc_varfs_body(GD,DVars,DFSs,NVs), % should record FSs created by EFD closure
  term_variables(Goal,HookVars),
  map_vars(HookVars,HookNVars,NVs),
  ord_intersection(DVars,HookNVars,HookDVars),
  tricky_vars_merge(HookDVars,VarsIn,VarsMid),
  replace_hook_fss(Goal,DFSs,PGoal,PGoals,[PGoal|PGoalsMid],FSPal,FSsIn,FSsMid),
  compile_body(GD,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,
               FSsMid,FSsOut,NVs).
compile_body((prolog(NVs,Goal),GD),PGoals,PGoalsRest,CBSafe,
             VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !, desc_varfs_body(GD,DVars,DFSs,NVs), % should record FSs created by EFD closure
  term_variables(Goal,HookVars),
  map_vars(HookVars,HookNVars,NVs),
  ord_intersection(DVars,HookNVars,HookDVars),
  tricky_vars_merge(HookDVars,VarsIn,VarsMid),
  replace_hook_fss(Goal,DFSs,PGoal,PGoals,[PGoal|PGoalsMid],FSPal,FSsIn,FSsMid),
  compile_body(GD,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,
               FSsMid,FSsOut,NVs).
compile_body((when(Cond,WBody),GD),PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,
     FSPal,FSsIn,FSsOut,NVs) :-
  !,desc_varfs_body(when(Cond,WBody),WhenVars,WhenFSs,NVs),
  desc_varfs_body(GD,ContVars,ContFSs,NVs),
  ord_intersection(WhenVars,ContVars,DVars),
  ord_intersection(WhenFSs,ContFSs,DFSs),
  tricky_vars_merge(DVars,VarsIn,VarsTricky),
  tricky_fss_merge(DFSs,FSsIn,FSsTricky),  % every FS is tricky - could discriminate
           %  between unseen and tricky much better here (possibly by binding all
           %  when/2 FSs to palette args just before suspension)
  compile_cond(Cond,WBody,PGoals,PGoalsMid,VarsTricky,FSPal,FSsTricky,NVs),
  compile_body(GD,PGoalsMid,PGoalsRest,CBSafe,VarsTricky,VarsOut,FSPal,
       FSsTricky,FSsOut,NVs).
compile_body((AGD,GD2),PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  !,AGD =.. [Rel|ArgDescs],
  compile_descs_fresh(ArgDescs,Args,PGoals,[AGoal|PGoalsMid],
                      CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),
%  append(Args,[IqsMid,IqsMid2],CompiledArgs),
  cat_atoms('fs_',Rel,CompiledRel),
  AGoal =.. [CompiledRel|Args],
  compile_body(GD2,PGoalsMid,PGoalsRest,CBSafe,VarsMid,VarsOut,
               FSPal,FSsMid,FSsOut,NVs).
compile_body((IfD -> ThenD ; ElseD),
             [(IfG -> ThenG ; ElseG)|PGoalsRest],PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !,compile_body(IfD,IfGoals,[],CBSafe,VarsIn,VarsIf,FSPal,FSsIn,
                 FSsIf,NVs),
  compile_body(ThenD,ThenGoals,[],false,VarsIf,VarsThen,FSPal,
               FSsIf,FSsThen,NVs),
  compile_body(ElseD,ElseGoals,[],false,VarsIn,VarsElse,FSPal,
               FSsIn,FSsElse,NVs),
  goal_list_to_seq(IfGoals,IfG),
  goal_list_to_seq(ThenGoals,ThenG),
  goal_list_to_seq(ElseGoals,ElseG),
  vars_merge(VarsThen,VarsElse,VarsOut),
  fss_merge(FSsThen,FSsElse,FSsOut).
compile_body((GD1;GD2),[(PGoal1;PGoal2)|PGoalsRest],PGoalsRest,_,
             VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_body(GD1,PGoals1,[],false,VarsIn,VarsDisj1,FSPal,
                  FSsIn,FSsDisj1,NVs),
  compile_body(GD2,PGoals2,[],false,VarsIn,VarsDisj2,FSPal,FSsIn,
               FSsDisj2,NVs),
  goal_list_to_seq(PGoals1,PGoal1),
  goal_list_to_seq(PGoals2,PGoal2),
  vars_merge(VarsDisj1,VarsDisj2,VarsOut),
  fss_merge(FSsDisj1,FSsDisj2,FSsOut).
compile_body((\+ GD),[(\+ PGoal)|PGoalsRest],PGoalsRest,CBSafe,
             VarsIn,VarsIn,FSPal,FSs,FSs,NVs) :-  % vars will be unbound, so dont thread
  !, compile_body(GD,PGoalsList,[],CBSafe,VarsIn,_,FSPal,FSs,_,NVs),
  goal_list_to_seq(PGoalsList,PGoal).
compile_body((Desc1 =@ Desc2),PGoals,PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_descs_fresh([Desc1,Desc2],[FS1,FS2],PGoals,
               [deref(FS1,DTag1,DSVs1),
                deref(FS2,DTag2,DSVs2),
ext_act(fs(DTag1,DSVs1,fs(DTag2,DSVs2,fsdone)),edone),
                deref(DTag1,DSVs1,Tag1Out,_),
                deref(DTag2,DSVs2,Tag2Out,_),
                (Tag1Out == Tag2Out)|PGoalsRest],
               CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_body((Desc1 = Desc2),PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,
     FSPal,FSsIn,FSsOut,NVs) :-
  !, compile_desc(Desc1,Tag,bot,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
  FSsIn,FSsMid,NVs),
  compile_desc(Desc2,Tag,bot,PGoalsMid,PGoalsRest,
       CBSafe,VarsMid,VarsOut,FSPal,FSsMid,FSsOut,NVs).
compile_body(true,PGoals,PGoals,_,Vars,Vars,_,FSs,FSs,_):-
  !.
compile_body(fail,[fail|PGoalsRest],PGoalsRest,_,Vars,Vars,_,FSs,FSs,_):-
  !.
compile_body(!,[!|PGoalsRest],PGoalsRest,_,Vars,Vars,_,FSs,FSs,_):-
  !.
compile_body((IfD -> ThenD),PGoals,PGoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !,compile_body((IfD -> ThenD ; fail),PGoals,PGoalsRest,CBSafe,
                 VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_body(prolog(Goal),PGoals,PGoalsRest,_,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,
     NVs) :-
  !, term_variables(Goal,HookVars),
  map_vars(HookVars,HookNVars,NVs),
  tricky_vars_merge(HookNVars,VarsIn,VarsOut),
  replace_hook_fss(Goal,[],PGoal,PGoals,[PGoal|PGoalsRest],FSPal,FSsIn,FSsOut).
compile_body(prolog(NVs,Goal),PGoals,PGoalsRest,_,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,
     NVs) :-
  !, term_variables(Goal,HookVars),
  map_vars(HookVars,HookNVars,NVs),
  tricky_vars_merge(HookNVars,VarsIn,VarsOut),
  replace_hook_fss(Goal,[],PGoal,PGoals,[PGoal|PGoalsRest],FSPal,FSsIn,FSsOut).
compile_body(when(Cond,WBody),PGoals,PGoalsRest,_CBSafe,VarsIn,VarsTricky,
     FSPal,FSsIn,FSsTricky,NVs) :-
  !,desc_varfs_body(when(Cond,WBody),WhenVars,WhenFSs,NVs),
  tricky_vars_merge(WhenVars,VarsIn,VarsTricky),
  tricky_fss_merge(WhenFSs,FSsIn,FSsTricky),
  compile_cond(Cond,WBody,PGoals,PGoalsRest,VarsTricky,FSPal,FSsTricky,NVs).
compile_body(AtGD,PGoals,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  AtGD =.. [Rel|ArgDescs],
  compile_descs_fresh(ArgDescs,Args,PGoals,[AtGoal|PGoalsRest],
                      CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs),
%  append(Args,[IqsMid,IqsOut],CompiledArgs),
  cat_atoms('fs_',Rel,CompiledRel),
  AtGoal =.. [CompiledRel|Args].

% ------------------------------------------------------------------------------
% compile_cond/8
% [User's Manual] [Reference Manual]
% compile_cond(Cond:cond,WBody:goal,
%              PGoals:prolog_goals,PGoalsRest:prolog_goals,
%              FSPal:var,FSsIn:fss,FSsIn:fss)
% ------------------------------------------------------------------------------
% Compile a delay condition into Prolog when/2 statements to delay execution of
%  PGoals-PGoalsRest, the compiled code for the ALE goal, WBody.  A delay on a
%  FS can be any function-free, inequation-free description.  Delays on
%  multiple FSs closed under conjunction and disjunction are also supported.
% ------------------------------------------------------------------------------
compile_cond(X^(Cond),WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,NVs) :-
  !, ( nonvar(X) -> error_msg((nl,write_list(['non-variable',X,used,in,quantifier]),ttynl))
     ; true
     ),
  % because of EFD-closure, this will sometimes reject otherwise good vars - too bad
  put_assoc(X,NVs,unseen,NewNVs), % innermost var gets priority
  compile_cond(Cond,WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,NewNVs).
compile_cond(Cond,WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,NVs) :-
  transform_cond(Cond,CUFCond),
  compile_cond_list(CUFCond,WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,NVs).

transform_cond(Cond,CUFCond) :-
  flatten_cond(Cond,FlatCond,[]),
  unfold_tails(FlatCond,UFCond),
  compress_feat_prefixes(UFCond,CUFCond).

% SHOULD RENAME VARIABLES TO REFLECT COND OR DESC PROPERLY
flatten_cond(FS=Desc,Descs,DescsRest) :-
  !,expand_cd_macros(Desc,EDesc),
  flatten_desc(EDesc,FS,[],Descs,DescsRest).
flatten_cond((C1;C2),[(FC1;FC2)|Rest],Rest) :-
  !,flatten_cond(C1,FC1,[]),
  flatten_cond(C2,FC2,[]).
flatten_cond((C1,C2),FC1,FC2Rest) :-
  !,flatten_cond(C1,FC1,FC2),
  flatten_cond(C2,FC2,FC2Rest).
flatten_cond(X,_,_) :-
  error_msg((nl,write('unrecognised conditional: '),write(X),nl)).

expand_cd_macros(X,X) :-
  var(X),
  !.
expand_cd_macros([],e_list) :- !.
expand_cd_macros([H|T],(hd:EH,tl:ET)) :-
  !,expand_cd_macros(H,EH),
  expand_cd_macros(T,ET).
expand_cd_macros(@ MacroName,EDesc) :-
  !, ( (MacroName macro Desc) -> true
     ; error_msg((nl,write_list([undefined,macro,MacroName,used,in,description]),ttynl))
     ),  % we used to backtrack on macro definitions here - bad move
  expand_cd_macros(Desc,EDesc).
expand_cd_macros(F:Desc,F:EDesc) :-
  !,expand_cd_macros(Desc,EDesc).
expand_cd_macros((Desc1,Desc2),(EDesc1,EDesc2)) :-
  !,expand_cd_macros(Desc1,EDesc1),
  expand_cd_macros(Desc2,EDesc2).
expand_cd_macros((Desc1;Desc2),(EDesc1;EDesc2)) :-
  !,expand_cd_macros(Desc1,EDesc1),
  expand_cd_macros(Desc2,EDesc2).
expand_cd_macros(X,X).  % paths, types, etc. - flag inequations and functional descs later.
               % Paths can't be expanded because their implicit var is narrowly quantified.

% postcondition: when result list contains FS=Blah, Blah is never a list
% SHOULD RENAME VARIABLES TO REFLECT COND OR DESC PROPERLY
flatten_desc(X,FS,FeatPrefix,[FS=FPX|DsRest],DsRest) :-
  var(X),
  !,unwind_prefix(FeatPrefix,X,FPX).
flatten_desc((D1,D2),FS,FeatPrefix,Descs,DsRest) :-
  !,flatten_desc(D1,FS,FeatPrefix,Descs,DsMid),
  flatten_desc(D2,FS,FeatPrefix,DsMid,DsRest).
flatten_desc(F:Desc,FS,FeatPrefix,Descs,DsRest) :-
  !,flatten_desc(Desc,FS,[F|FeatPrefix],Descs,DsRest).
flatten_desc((D1;D2),FS,FeatPrefix,[(Ds1;Ds2)|DsRest],DsRest) :-
  !,flatten_desc(D1,FS,FeatPrefix,Ds1,[]),
  flatten_desc(D2,FS,FeatPrefix,Ds2,[]).
flatten_desc((Path1 == Path2),FS,FeatPrefix,[FS=FPEq|DsRest],DsRest) :-
  !,unwind_prefix(FeatPrefix,(Path1 == Path2),FPEq).
flatten_desc(Other,FS,FeatPrefix,[(FS=FPOther)|DsRest],DsRest) :-
  ( type(Other) ; functor(Other,-,2) ),
  !, unwind_prefix(FeatPrefix,Other,FPOther).
flatten_desc(X,_,_,_,_) :-
  error_msg((nl,write('unrecognised conditional: '),write(X),nl)).

unwind_prefix([],Desc,Desc).
unwind_prefix([F|Prefix],Desc,Result) :-
  unwind_prefix(Prefix,F:Desc,Result).

unfold_tails([],[]).
unfold_tails([FS=Desc|FRest],[FS=Desc|UFRest]) :-
  !,unfold_tails(FRest,UFRest).
unfold_tails([(FC1;FC2)|FRest],[(UFC1New;UFC2New)]) :-
  append(FC1,FRest,FC1New),
  append(FC2,FRest,FC2New),
  unfold_tails(FC1New,UFC1New),
  unfold_tails(FC2New,UFC2New).

compress_feat_prefixes([],[]).
compress_feat_prefixes([FS=X|Cond],[FS=X|CCond]) :-
  var(X),
  !,compress_feat_prefixes(Cond,CCond).
compress_feat_prefixes([FS=F:Desc|Cond],[FS=F:FDesc|CCondRest]) :-
  !,compress_fp_feat(Cond,F,FS,FDescs,CondRest),
  compress_feat_prefixes([FS=Desc|FDescs],CFDescs),
  collect_feat_descs(CFDescs,FDesc),
  compress_feat_prefixes(CondRest,CCondRest).
compress_feat_prefixes([FS=Other|Cond],[FS=Other|CCond]) :-
  !,compress_feat_prefixes(Cond,CCond).
compress_feat_prefixes([(C1;C2)],[(CC1;CC2)]) :-
  compress_feat_prefixes(C1,CC1),
  compress_feat_prefixes(C2,CC2).

compress_fp_feat([FS=F:Desc|CondRest],F,FS0,FDescs,FCondRest) :-
  FS == FS0,
  !,FDescs = [FS=Desc|FDescsRest],
  compress_fp_feat(CondRest,F,FS0,FDescsRest,FCondRest).
compress_fp_feat(CondRest,_,_,[],CondRest).

collect_feat_descs([_=Desc],Desc) :- !.
collect_feat_descs([_=Desc1|EqDescs],(Desc1,Desc2)) :-
  collect_feat_descs(EqDescs,Desc2).

compile_cond_list([Cond1|Cond2],WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,NVs) :-
  compile_cond_list_act(Cond2,Cond1,WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,NVs).

compile_cond_list_act([],(Cond1;Cond2),WBody,PGoals,PGoalsRest,Vars,FSPal,FSs,
      NVs) :-
  !,compile_cond_list(Cond1,(prolog(Trigger = 0) -> WBody ; true),PGoals,PGoalsMid,
      Vars,FSPal,FSs,NVs),
  compile_cond_list(Cond2,(prolog(Trigger = 1) -> WBody ; true),PGoalsMid,
    PGoalsRest,Vars,FSPal,FSs,NVs).
compile_cond_list_act([],FS=Desc,WBody,[PGoal|PGoalsRest],PGoalsRest,Vars,FSPal,
      FSs,NVs) :-
  ( get_assoc(FS,NVs,unseen)
  -> error_msg((nl,write_list([narrowly,quantified,variable,used,on,'LHS',of,delay,FS=Desc],ttynl)))
  ; true
  ),  % KNOWN BUG: should substitute FS under NVs here
  compile_cond_desc(Desc,FS,WGoal,PGoal,Vars,VarsBody,FSPal,FSs,FSsBody,NVs,NVsMid),
% replace_nv_body(WBody,NBody,Vars,VarsTricky,NVs), % all narrow vars are tricky in body
%         % - maybe could do better, but user might wake up suspension by binding two
%         % vars in prolog hook without instantiating them
  map_assoc(nv_fresh,NVsMid,NewNVs),
  compile_body(WBody,BodyGoals,[],false,VarsBody,_VarsLost,FSPal,FSsBody,
       _FSsLost,NewNVs),  % KNOWN BUG: this might drag the FS palette into the suspension - bad move.
  goal_list_to_seq(BodyGoals,WGoal).
compile_cond_list_act([Cond|CondRest],FS=Desc,WBody,[PGoal|PGoalsRest],PGoalsRest,
      Vars,FSPal,FSs,NVs) :-
  ( get_assoc(FS,NVs,unseen)
  -> error_msg((nl,write_list([narrowly,quantified,variable,used,on,'LHS',of,delay,FS=Desc]),ttynl))
  ; true
  ),  % KNOWN BUG: should substitute FS under NVs here
  compile_cond_desc(Desc,FS,PGoal2,PGoal,Vars,VarsMid,FSPal,FSs,FSsMid,NVs,NewNVs),
  compile_cond_list_act(CondRest,Cond,WBody,PGoals2,[],VarsMid,FSPal,FSsMid,NewNVs),
  goal_list_to_seq(PGoals2,PGoal2).

compile_cond_desc(Var,FS,WGoal,PGoal,VarsIn,VarsOut,_,FSsIn,FSsOut,NVsIn,NVsOut) :-
  var(Var),
  !, FSsOut = FSsIn,
     (  get_assoc(Var,NVsIn,SeenFlag)
     -> ( SeenFlag = unseen
-> put_assoc(Var,NVsIn,seen(FreshVar),NVsOut),
   put_assoc(FreshVar,VarsIn,seen,VarsOut),
   PGoal = (FS = FreshVar,call(WGoal))
; SeenFlag = seen(NVar), NVsOut = NVsIn,  % because of flattening, we either
  PGoal = when_eq(FS,NVar,WGoal), VarsOut = VarsIn % saw it or didn't see it
)                                         % - no tricky case
      ; PGoal = when_eq(FS,Var,WGoal), put_assoc(Var,VarsIn,seen,VarsOut),
NVsOut = NVsIn
     ).
compile_cond_desc(F:Desc,FS,WGoal,PGoal,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVsIn,
  NVsOut) :-
  introduce(F,FIntro),
  !, name(F,FName),
  append("featval_",FName,RelName),
  name(Rel,RelName),
  FGoal =.. [Rel,SVs,Tag,FSatF],
  PGoal = when_type(FIntro,FS,(deref(FS,Tag,SVs),
       FGoal,DescGoal)),
  compile_cond_desc(Desc,FSatF,WGoal,DescGoal,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVsIn,
    NVsOut).
compile_cond_desc((Path1 == Path2),FS,WGoal,PGoal,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,
  NVs,NVs) :-
  !,expand_path(Path1,PathVar,ExpPath1),
  expand_path(Path2,PathVar,ExpPath2),
  put_assoc(PathVar,NVs,unseen,PathNVs),
  compile_cond_desc((ExpPath1,ExpPath2),FS,WGoal,PGoal,VarsIn,VarsOut,FSPal,FSsIn,
    FSsOut,PathNVs,_).
compile_cond_desc((Desc1,Desc2),FS,WGoal,PGoal,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVsIn,
  NVsOut) :-
  !,compile_cond_desc(Desc1,FS,PGoal2,PGoal,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVsIn,
      NVsMid),
  compile_cond_desc(Desc2,FS,WGoal,PGoal2,VarsMid,VarsOut,FSPal,FSsMid,FSsOut,NVsMid,
    NVsOut).
%compile_cond_desc((Desc1;Desc2),FS,WGoal,(PGoal1,PGoal2),NVs) :-
%  !,compile_cond_desc(Desc1,FS,(Trigger=0 -> WGoal ; true),PGoal1,NarrowVars),
%  compile_cond_desc(Desc2,FS,(Trigger=1 -> WGoal ; true),PGoal2,NarrowVars).
compile_cond_desc((a_ X),FS,WGoal,when_a_(X,FS,WGoal),Vars,Vars,_,FSs,FSs,NVs,NVs) :- !.
compile_cond_desc(Type,FS,WGoal,PGoal,VarsIn,VarsOut,_,FSsIn,FSsOut,NVs,NVs) :-
  type(Type),
  !, (Type == bot -> PGoal = WGoal
     ; PGoal = when_type(Type,FS,WGoal)
     ),
     VarsOut = VarsIn, FSsOut = FSsIn.
compile_cond_desc(Tag-SVs,FS,WGoal,PGoal,Vars,Vars,FSPal,FSsIn,FSsOut,NVs,NVs) :-
  deref(Tag,SVs,DTag,DSVs),
  find_fs(FSsIn,DTag,DSVs,PGoals,[when_eq(FS,FSVar,WGoal)],FSVar,FSPal,FSsOut),
  goal_list_to_seq(PGoals,PGoal).
compile_cond_desc(X,_,_,_,_,_,_,_,_,_,_) :-
  error_msg((nl,write('unrecognised conditional in '),write(X))).

fs_at_pos([],F,_,_) :-
  error_msg((nl,write('unrecognised feature '),write(F))).
fs_at_pos([F:_|_],F,Pos,Pos) :- !.
fs_at_pos([_:_|FRs],F,Cur,Pos) :-
  Next is Cur + 1,
  fs_at_pos(FRs,F,Next,Pos).

expand_path([],Var,Var).
expand_path([Feat|Path],Var,(Feat:Rest)) :-
  ( approp(Feat,_,_) -> expand_path(Path,Var,Rest)
  ; error_msg((nl,write_list([undefined,feature,Feat,used,in,path,[Feat|Path]]),ttynl))
  ).

% ------------------------------------------------------------------------------
% Co-routining
% [User's Manual] [Reference Manual]
%
% when_type(Type:type,FS:fs,WGoal:prolog_goal)
% ------------------------------------------------------------------------------
% Wait until FS is of type Type, then execute WGoal.
% ------------------------------------------------------------------------------
when_type(Type,FS,WGoal) :-
  when(nonvar(FS),when_type0(Type,FS,WGoal)).

when_type0(Type,FS,WGoal) :-
  (deref(FS,Tag,SVs)
  -> functor(SVs,FSType,_),  % 'a_' correctly produces failure below
     (sub_type(Type,FSType) % already of that type - assume approp
     -> call(WGoal)         % is satisfied (o.w. wont terminate on
      ; (unify_type(Type,FSType,_)  % cyclic structures)
        -> when_type_delayed(Type,Tag,SVs,WGoal) % not yet - delay
         ; true    % never will be
        )
      )
   ; true   % pp_fs will restore on backtracking
   ).


when_type_delayed(Type,TagIn,SVsIn,WGoal) :-
  when(nonvar(TagIn),when_type_delayed0(Type,TagIn,SVsIn,WGoal)).

when_type_delayed0(Type,TagIn,SVsIn,WGoal) :-
  ( deref(TagIn,SVsIn,Tag,SVs)
  -> when(nonvar(SVs),(functor(SVs,FSType,_),
                       ( sub_type(Type,FSType)
                       -> when_approp(FSType,SVs,WGoal)
                        ; ( unify_type(Type,FSType,_)
                          -> when_type_delayed(Type,Tag,SVs,WGoal)
                           ; true
                          )
                      )))
   ; true % pp_fs will restore on backtracking
  ).


% ------------------------------------------------------------------------------
% when_a_(X:prolog_term,FS:fs,Goal:
% ------------------------------------------------------------------------------
% Like when_type/3, but for a_/1 atoms
% ------------------------------------------------------------------------------
when_a_(X,FS,WGoal) :-
  when(nonvar(FS),(deref(FS,Tag,SVs)
                  -> when(nonvar(SVs),(functor(SVs,FSType,_),
                                       (FSType == (a_)        % already a_ atom
                                       -> arg(1,SVs,FSX),
                                          (X == FSX   % identical
                                          -> call(WGoal)
                                          ; when(?=(X,FSX),(X==FSX -> call(WGoal) ; true))
                                          )  % not yet - delay
                                       ; (FSType == bot
                                         -> when_a_(X,Tag,WGoal) % not yet - delay
                                         ; true    % never will be
                                         )
                                       )))
  ; true % pp_fs will restore on backtracking
  )).

% ------------------------------------------------------------------------------
% when_a_chk(X:prolog_term,FS:fs,Goal:
% ------------------------------------------------------------------------------
% Like when_a_/3, but uses subsumes_chk/2 instead of ==/2.  Necessary for
%  checking appropriateness conditions with a_/1 value restrictions, in which
%  token identity of variables has no significance.
% ------------------------------------------------------------------------------
when_a_chk(X,FS,WGoal) :-
  when(nonvar(FS),(deref(FS,Tag,SVs)
                  -> when(nonvar(SVs),(functor(SVs,FSType,_),
                                       (FSType == (a_)        % already a_ atom
                                       -> arg(1,SVs,FSX),
                                          (subsumes_chk(X,FSX)   % subsumed
                                          -> call(WGoal)
                                          ; decompose_a_chk(X,FSX,WGoal)
                                          )
                                       ; (FSType == bot
                                         -> when_a_(X,Tag,WGoal) % not yet - delay
                                         ; true    % never will be
                                         )
                                       )))
  ; true % pp_fs will restore on backtracking
  )).

% X is acyclic and not a variable
decompose_a_chk(X,FSX,WGoal) :-
  when((nonvar(True);nonvar(False)),(var(True) -> true ; call(WGoal))),
  empty_assoc(VarsIn),
  decompose_ac_arg(X,FSX,VarsIn,_,True,False).

decompose_ac_arg(X,FSX,VarsIn,VarsOut,True,False) :-
  var(X) -> ( get_assoc(X,VarsIn,XAnchor) -> VarsOut = VarsIn,
                             when((?=(FSX,XAnchor);nonvar(False)),
  ( var(False) -> ( FSX==XAnchor -> True=[] ; False=[])
  ; true))
    ; put_assoc(X,VarsIn,FSX,VarsOut),
              True = []
    )
  ; functor(X,Fun,N),
    when((nonvar(FSX);nonvar(False)),
( var(False) -> ( functor(FSX,Fun,N) -> ( N==0 -> True = []
                                 ; functor(Ground,Fun,N),
                   when((ground(Ground);nonvar(False)),( var(False) -> True = []
                                       ; true)),
                                                  decompose_ac_args(0,N,X,FSX,VarsIn,VarsOut,Ground,False)
         )
            ; False = []
)
; true
)).

decompose_ac_args(N,N,_,_,Vars,Vars,_,_) :- !.
decompose_ac_args(I,N,X,FSX,VarsIn,VarsOut,Ground,False) :-
  NewI is I + 1,
  arg(NewI,X,XA),
  arg(NewI,FSX,FSA),
  arg(NewI,Ground,G),
  decompose_ac_arg(XA,FSA,VarsIn,VarsMid,G,False),
  decompose_ac_args(NewI,N,X,FSX,VarsMid,VarsOut,Ground,False).


% ------------------------------------------------------------------------------
% when_approp(Type:type,SVs:svs,WGoal:prolog_goal)                   mh(0)
% ------------------------------------------------------------------------------
% Tag-SVs is of type Type.  Wait until all of its values are of the types
%  required by their appropriateness restrictions, and then execute WGoal.
% ------------------------------------------------------------------------------
when_approp(Type,SVs,WGoal) if_h [SubGoal] :-
  approps(Type,FRs,_),
  when_approp_subgoals(FRs,1,SVs,WGoal,SubGoal).

when_approp_subgoals([],_,_,WGoal,call(WGoal)).
when_approp_subgoals([_:R|FRs],N,SVs,WGoal,(arg(N,SVs,NthV),
                                            WhenGoal)) :-
  (R = (a_ X)
  -> WhenGoal = when_a_chk(X,NthV,SubGoal)
   ; WhenGoal = when_type(R,NthV,SubGoal)),
  NewN is N + 1,
  when_approp_subgoals(FRs,NewN,SVs,WGoal,SubGoal).

% ------------------------------------------------------------------------------
% when_eq(FS1:fs,FS2:fs,Goal:prolog_goal)
% ------------------------------------------------------------------------------
% Wait until FS1 == FS2, then execute Goal
% ------------------------------------------------------------------------------
when_eq(FS1,FS2,WGoal) :- % We should probably wait until ?=(FS1,FS2) instead
  ( var(FS1) -> FS1 = _-bot ; true),
  ( var(FS2) -> FS2 = _-bot ; true),
  when_eq0(FS1,FS2,WGoal).

when_eq0(FS1,FS2,WGoal) :-
  deref(FS1,Tag1,SVs1) -> ( deref(FS2,Tag2,SVs2) % don't need to guard SVs1 and SVs2 here -
                  -> when_eq_act(Tag1,SVs1,Tag2,SVs2,WGoal) % suspensions don't use this
  ; true % pp_fs will restore on backtracking
  )
  ; true. % pp_fs will restore on backtracking
when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal) :-
  deref(Tag1,SVs1,Tag1Out,SVs1Out) -> ( deref(Tag2,SVs2,Tag2Out,SVs2Out)
      -> when((nonvar(SVs1Out),nonvar(SVs2Out)), % guard for fully_deref/4
      when_eq_act(Tag1Out,SVs1Out,Tag2Out,SVs2Out,WGoal))
      ; true
      )
  ; true.
when_eq0(FS1,Tag2,SVs2,WGoal) :-
  deref(FS1,Tag1Out,SVs1Out) -> ( deref(Tag2,SVs2,Tag2Out,SVs2Out)
-> when((nonvar(SVs1Out),nonvar(SVs2Out)), % guard for fully_deref/4
when_eq_act(Tag1Out,SVs1Out,Tag2Out,SVs2Out,WGoal))
; true
)
  ; true.

when_eq_act(Tag1,SVs1,Tag2,SVs2,WGoal) :-
    Tag1 == Tag2 -> call(WGoal)
  ; SVs1 = (a_ X1) -> ( SVs2 = (a_ X2) -> when(?=(X1,X2),when_eq_a2(X1,X2,Tag1,Tag2,WGoal))
      ; SVs2 = bot -> when(nonvar(Tag2),when_eq0(Tag2,Tag1,SVs1,WGoal))
      ; true
      )
  ; functor(SVs1,Type1,N),
    ( functor(SVs2,'a_',1) -> Type2 = SVs2
    ; functor(SVs2,Type2,_)
    ),
    ( Type1==Type2 -> ( clause(extensional(Type1),true)
      -> ext_act(fs(Tag1,SVs1,fs(Tag2,SVs2,fsdone)),edone),
                 deref(Tag1,SVs1,ETag1,ESVs1),
                         deref(Tag2,SVs2,ETag2,ESVs2),
                 ( ETag1 == ETag2 -> call(WGoal)
; N==0 -> (Tag1=Tag2,call(WGoal))
; functor(Ground,Type1,N),
when(ground(Ground),(Tag1=Tag2,WGoal)),
wheneq_decomp(0,N,ESVs1,ESVs2,Ground)
      )
      ; maximal(Type1) -> when(?=(Tag1,Tag2),(Tag1==Tag2 -> WGoal ; true))
              ; when((nonvar(Tag1);nonvar(Tag2);?=(Tag1,Tag2)),when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal))
      )
    ; sub_type(Type1,Type2) -> when(nonvar(Tag1),when_eq0(Tag1,Tag2,SVs2,WGoal))
    ; sub_type(Type2,Type1) -> when(nonvar(Tag2),when_eq0(Tag2,Tag1,SVs1,WGoal))
    ; unify_type(Type1,Type2,_) -> when((nonvar(Tag1);nonvar(Tag2);?=(Tag1,Tag2)), % KNOWN BUG: do we need ?=/2 check here?
when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal))
    ; true % otherwise can never be equal
    ).

when_eq_a2(X1,X2,Tag1,Tag2,WGoal) :-
  (X1==X2 -> (Tag1=Tag2,call(WGoal)) ; true).

wheneq_decomp(N,N,_,_,_) :- !.  % KNOWN BUG - can hang on cyclic extensional FSs
wheneq_decomp(I,N,SVs1,SVs2,Ground) :-
  NewI is I + 1,
  arg(NewI,SVs1,A1),
  arg(NewI,SVs2,A2),
  arg(NewI,Ground,G),
  when_eq(A1,A2,(G=[])),
  wheneq_decomp(NewI,N,SVs1,SVs2,Ground).

% inequations
ineq(FS1,FS2) :-
  deref(FS1,Tag1,SVs1),
  deref(FS2,Tag2,SVs2),  % no need to delay on first pass
  ineq_disj_act(Tag1,SVs1,Tag2,SVs2,_,0).  % 0 causes failure when unified with [].

ineq_disj(FS1,FS2,True,False) :-
  deref(FS1,Tag1,SVs1),
  deref(FS2,Tag2,SVs2),  % guard for fully_deref/4
  when((nonvar(SVs1),nonvar(SVs2)),ineq_disj_act(Tag1,SVs1,Tag2,SVs2,True,False)).

ineq_disj(Tag1In,SVs1In,Tag2In,SVs2In,True,False) :-
  deref(Tag1In,SVs1In,Tag1,SVs1),
  deref(Tag2In,SVs2In,Tag2,SVs2),  % guard for fully_deref/4
  when((nonvar(SVs1),nonvar(SVs2)),ineq_disj_act(Tag1,SVs1,Tag2,SVs2,True,False)).

ineq_disj_act(Tag1,SVs1,Tag2,SVs2,True,False) :-
  ( Tag1 == Tag2 -> False = []
  ; ( SVs1 = (a_ X1) -> Type1 = SVs1, N=0,
                ( SVs2 = (a_ X2) -> when((?=(X1,X2);nonvar(True)),
                                                 (var(True) -> ( X1==X2 -> False = []
       ; True = [])
; true))
; functor(SVs2,Type2,_),
                          ( unify_type(Type1,Type2,_) % negate to undo binding in a_/1 atoms
                          -> ineq_suspend(Tag1,Tag2,SVs1,SVs2,True,False) % Type2 must be bot
                          ; True = []  % this inequation can never be violated
                          )
)
    ; functor(SVs1,Type1,N),
      ( SVs2 = (a_ _) -> Type2 = SVs2
      ; functor(SVs2,Type2,_)
      ),
      ( unify_type(Type1,Type2,_) % negate to undo binding in a_/1 atoms
      -> ( Type1 == Type2, clause(extensional(Type1),true)
         -> ( N==0 -> False = []
            ; functor(Ground,Type1,N),
              when((nonvar(True);ground(Ground)),
   ineq_resolve_decomp(True,False)),
              ineq_decomp(0,N,SVs1,SVs2,True,Ground)
            )
         ; ineq_suspend(Tag1,Tag2,SVs1,SVs2,True,False)
         )
      ; True = []  % this inequation can never be violated
      )
    )
  ).

ineq_decomp(N,N,_,_,_,_) :- !.  % KNOWN BUG - can hang on cyclic extensional FSs
ineq_decomp(I,N,SVs1,SVs2,True,Ground) :-
  NewI is I + 1,
  arg(NewI,SVs1,A1),
  arg(NewI,SVs2,A2),
  arg(NewI,Ground,G),
  ineq_disj(A1,A2,True,G),
  ineq_decomp(NewI,N,SVs1,SVs2,True,Ground).

ineq_resolve_decomp(True,False) :-
  var(True) -> False = [] % fail if all disjuncts fail
  ; true.  % otherwise somebody can never be violated, so OK.

ineq_suspend(Tag1,Tag2,SVs1,SVs2,True,False) :-
  when((nonvar(Tag1);nonvar(Tag2);?=(Tag1,Tag2);nonvar(True)),
       ineq_resolve_suspend(Tag1,SVs1,Tag2,SVs2,True,False)).

ineq_resolve_suspend(Tag1,SVs1,Tag2,SVs2,True,False) :-
  var(True) -> ineq_disj(Tag1,SVs1,Tag2,SVs2,True,False)
  ; true.  % if True is bound, then no longer need to check.



% ------------------------------------------------------------------------------
% goal_list_to_seq(Goals:goals, GoalsSeq:goal_seq)
% ------------------------------------------------------------------------------
%
% ------------------------------------------------------------------------------
goal_list_to_seq([],true).
goal_list_to_seq([G|Gs],GsSeq) :-
  ((G = true)
   -> goal_list_to_seq(Gs,GsSeq)
    ; goal_list_to_seq_act(Gs,G,GsSeq)).

goal_list_to_seq_act([],G,G).
goal_list_to_seq_act([G2|Gs],G,(G,GsSeq)):-
  goal_list_to_seq_act(Gs,G2,GsSeq).

% ------------------------------------------------------------------------------
% goal_list_to_disj(Goals:goals, GoalsDisj:goal_seq)
% ------------------------------------------------------------------------------
%
% ------------------------------------------------------------------------------
goal_list_to_disj([],fail).
goal_list_to_disj([G|Gs],GsSeq) :-
  ((G = fail)
   -> goal_list_to_disj(Gs,GsSeq)
    ; goal_list_to_disj_act(Gs,G,GsSeq)).

goal_list_to_disj_act([],G,G).
goal_list_to_disj_act([G2|Gs],G,(G;GsSeq)):-
  goal_list_to_disj_act(Gs,G2,GsSeq).

% ------------------------------------------------------------------------------
% compile_descs(Descs,Vs,IqsIn,IqsOut,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,
%               FSPal,FSsIn,FSsOut)
% ------------------------------------------------------------------------------
% compiles descriptions Descs to constraint Vs into diff list Goals-GoalsRest
% ------------------------------------------------------------------------------
compile_descs([],[],Goals,Goals,_,Vars,Vars,_,FSs,FSs,_).
compile_descs([ArgDesc|ArgDescs],[Arg|Args],
              SubGoals,SubGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  compile_desc(ArgDesc,Arg,SubGoals,SubGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_descs(ArgDescs,Args,SubGoalsMid,SubGoalsRest,CBSafe,
                VarsMid,VarsOut,FSPal,FSsMid,FSsOut,NVs).

% ------------------------------------------------------------------------------
% compile_descs_fresh(Descs,Vs,IqsIn,IqsOut,Goals,GoalsRest,CBSafe,VarsIn,
%                     VarsOut,FSPal,FSsIn,FSsOut)
% ------------------------------------------------------------------------------
% similar to compile_descs, except that Vs are instantiated to Ref-bot
% before compiling Descs
% ------------------------------------------------------------------------------
compile_descs_fresh([],[],Goals,Goals,_,Vars,Vars,_,FSs,FSs,_).
compile_descs_fresh([ArgDesc|ArgDescs],[Arg|Args],
                    SubGoals,SubGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
                    FSsOut,NVs):-
  ( var(ArgDesc)    -> ( get_assoc(ArgDesc,NVs,seen(AVar)) -> true
       ; AVar = ArgDesc
       ),
                       ( get_assoc(AVar,VarsIn,Seen,VarsMid2,seen)
                         -> ( Seen == seen -> Arg = AVar,
                                              SubGoals = SubGoalsMid2
                            ; % Seen == tricky,
                              SubGoals = [(var(AVar)
                                          -> Arg = Ref-bot, AVar = Arg
                                           ; Arg = AVar)|SubGoalsMid2]
    % KNOWN BUG - probably could bind Arg above at CT
                            )
                       ; Arg = AVar,
                         SubGoals = [AVar = Ref-bot|SubGoalsMid2],
                         put_assoc(AVar,VarsIn,seen,VarsMid2)
                       ),
                       FSsMid2 = FSsIn
  ; ArgDesc = Tag-SVs -> deref(Tag,SVs,DTag,DSVs),
                         find_fs(FSsIn,DTag,DSVs,SubGoals,SubGoalsMid2,Arg,
                                 FSPal,FSsMid2),
                         VarsMid2 = VarsIn
  ; root_struct(ArgDesc,RStruct,DRest,NVs) ->
    ( var(RStruct) -> ( get_assoc(RStruct,VarsIn,Seen,VarsMid,seen)
                         -> ( Seen == seen -> Arg = RStruct,
                                              SubGoals = SubGoalsMid
                            ; % Seen == tricky,
                              SubGoals = [(var(RStruct)
                              -> Arg = Ref-bot, RStruct = Arg
                               ; Arg = RStruct)|SubGoalsMid]
                            )
                      ; Arg = RStruct,
                        SubGoals = [RStruct = Ref-bot|SubGoalsMid],
                        put_assoc(RStruct,VarsIn,seen,VarsMid)
                      ),
                      FSsMid = FSsIn
    ; RStruct = Tag-SVs,
      deref(Tag,SVs,DTag,DSVs),
      find_fs(FSsIn,DTag,DSVs,SubGoals,SubGoalsMid,Arg,FSPal,FSsMid),
      VarsMid = VarsIn
    ),
    compile_desc(DRest,Arg,SubGoalsMid,SubGoalsMid2,CBSafe,
                 VarsMid,VarsMid2,FSPal,FSsMid,FSsMid2,NVs)
  ; % some other description - need a new FS
    Arg = Ref-bot,
    compile_desc(ArgDesc,Ref,bot,SubGoals,SubGoalsMid2,CBSafe,
                 VarsIn,VarsMid2,FSPal,FSsIn,FSsMid2,NVs)
  ),
  compile_descs_fresh(ArgDescs,Args,SubGoalsMid2,SubGoalsRest,
                      CBSafe,VarsMid2,VarsOut,FSPal,FSsMid2,FSsOut,NVs).

% ------------------------------------------------------------------------------
% root_struct(+Desc:desc,-RootStruct:var_or_fs,-DRest:desc)
% ------------------------------------------------------------------------------
% Find a variable that can be used to refer the feature structure described
%  by Desc.  If there is one, then we can use that variable as the argument
%  of the predicate being assembled in compile_descs_fresh/11.
% ------------------------------------------------------------------------------
root_struct(Desc,RStruct,DRest,NVs) :-
  root_struct_act(Desc,RS0,DRest),
  ( get_assoc(RS0,NVs,seen(RStruct)) -> true
  ; RStruct = RS0
  ).

root_struct_act((D1,D2),RStruct,DRest) :-
   is_root(D1),is_root(D2) -> ( RStruct = D1, DRest = D2
                              ; RStruct = D2, DRest = D1)
; is_root(D1) -> ( RStruct = D1, DRest = D2
                  ; root_struct_act(D2,RStruct,D2Rest),
                    DRest = (D1,D2Rest))
; is_root(D2) -> ( RStruct = D2, DRest = D1
                  ; root_struct_act(D1,RStruct,D1Rest),
                    DRest = (D1Rest,D2))
; ( root_struct_act(D1,RStruct,D1Rest),
     DRest = (D1Rest,D2)
   ; root_struct_act(D2,RStruct,D2Rest),
     DRest = (D1,D2Rest)).
root_struct_act((D1;D2),RStruct,DRest) :-
   (is_root(D1),is_root(D2)) -> D1 == D2,
                                RStruct = D1, DRest = bot
; is_root(D1) -> root_struct_act(D2,RStruct,D2Rest),
                  D1 == RStruct,
                  DRest = D2Rest
; is_root(D2) -> root_struct_act(D1,RStruct,D1Rest),
                  D2 == RStruct,
                  DRest = D1Rest
; root_struct_act(D1,RStruct,D1Rest),
   root_struct_act(D2,RStruct2,D2Rest),
   RStruct == RStruct2,
   DRest = (D1Rest;D2Rest).

is_root(D) :-
   var(D) -> true
; functor(D,-,2).

% ==============================================================================
% Phrase Structure Rule Compiler
% [User's Manual]
% ==============================================================================

:-dynamic curr_lex_rule_depth/1.
curr_lex_rule_depth(2).

% ------------------------------------------------------------------------------
% lex_rule_depth(N:int)
% ------------------------------------------------------------------------------
% 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:word, Tag:var_tag, SVs:svs, IqsOut:ineqs)               mh(0)
% ------------------------------------------------------------------------------
% Word has category Tag-SVs
% ------------------------------------------------------------------------------
lex(_,_) if_b [fail] :-
  current_predicate('--->',(_ ---> _)) -> \+ (_ ---> _) ; true.
lex(Word,FS) if_b Goals :-
  current_predicate('--->',(_ ---> _)),
  (WordStart ---> DescOrGoal),
  ( var(DescOrGoal) -> Desc = DescOrGoal, GoalStart = true
  ; functor(DescOrGoal,goal,2) -> arg(1,DescOrGoal,Desc),
                                  arg(2,DescOrGoal,GoalStart)
  ; Desc = DescOrGoal, GoalStart = true
  ),
  lex_act(Word,FS,Goals,WordStart,Desc,GoalStart).

lex_act(Word,FS,Goals,WordStart,Desc,GoalStart) :-
  if(add_to(Desc,TagStart,bot),
     (fully_deref(TagStart,bot,TagMid,SVsMid),
      curr_lex_rule_depth(Max),
      lex_close(0,Max,WordStart,TagMid,SVsMid,GoalStart,Word,FS,Goals)),
     error_msg((write('lex: unsatisfiable lexical entry for '),
                write(WordStart),nl))).

% ------------------------------------------------------------------------------
% lex_close(WordIn:word, TagIn:var_tag, SVsIn:svs,
%           WordOut:word, TagOut:var_tag, SVsOut:svs, IqsIn:ineqs,
%           IqsOut:ineqs)
% ------------------------------------------------------------------------------
% If WordIn has category TagIn-SVsIn, then WordOut has category
% TagOut-SVsOut;  computed by closing under lexical rules
% ------------------------------------------------------------------------------
lex_close(_,_,Word,Tag,SVs,Goal,Word,FS,Goals) :-
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  term_variables(Tag-SVs,FSVars),
  term_variables(Goal,GoalVars),
  ( ord_intersect(GoalVars,FSVars) -> GoalLinked = (FS=(Tag-SVs),Goal)
  ; GoalLinked = Goal, FS = (Tag-SVs)
  ),
  compile_body(GoalLinked,GoalsFinal,[],true,VarsIn,_,FSPal,[],FSsOut,NVs),
  build_fs_palette(FSsOut,FSPal,Goals,GoalsFinal,lex).
lex_close(N,Max,WordIn,TagIn,SVsIn,Goal,WordOut,FS,Goals):-
  current_predicate(lex_rule,lex_rule(_,_,_,_,_,_,_,_)),
  N < Max,
  lex_rule(WordIn,TagIn,SVsIn,Goal,WordMid,TagMid,SVsMid,GoalMid),
  NPlus1 is N + 1,
  lex_close(NPlus1,Max,WordMid,TagMid,SVsMid,GoalMid,WordOut,FS,Goals).

% lex_goal/2 - run-time hooks for lexical items.
%lex_goal(Phon,FS) :-
%  current_predicate(fs_lex_goal,fs_lex_goal(_,_))
%  -> fs_lex_goal(Phon,FS)
%  ; true.

% ------------------------------------------------------------------------------
% empty_cat(N:neg, Node:int, Tag:var_tag, SVs:svs, Iqs:ineqs,
%           Dtrs:ints, RuleName:atom)                                  mh(0)
% ------------------------------------------------------------------------------
empty_cat(_,_,_,_,_,_) if_h [fail] :-
  \+ current_predicate(empty,empty(_)),
  ( true
  ; current_predicate(rule,(_ rule _)),
    (RuleName rule Mother ===> Dtrs),
    assert(alec_rule(RuleName,Dtrs,_,Mother,PrevDtrs,PrevDtrs)),
    fail
  ).
empty_cat(N,Node,TagOut,SVsOut,Dtrs,RuleName) if_h SubGoal :-
  current_predicate(empty,empty(_)),
  findall(empty(M,_,FTag,FSVs,[],empty),
   (empty(Desc),
    add_to(Desc,Tag,bot),
    gen_emptynum(M),
%  curr_lex_rule_depth(Max),             % should we be closing empty cats
%  lex_close(0,Max,e,Tag,bot,_,TagMid,SVsMid,IqsIn,IqsMid), % under lex. rules?
    fully_deref(Tag,bot,FTag,FSVs)),
   BasicEmptys),
  (no_subsumption
  -> MinimalEmptys = BasicEmptys
   ; minimise_emptys(BasicEmptys,[],MinimalEmptys)
  ),
  close_emptys(MinimalEmptys,ClosedEmptys,ClosedRules),
  (no_subsumption
  -> MinimalClosedEmptys = ClosedEmptys
   ; minimise_emptys(ClosedEmptys,[],MinimalClosedEmptys)
  ),
(( MinimalClosedEmptys = [] -> SubGoal = [fail]
  ; SubGoal = [],
    member(empty(N,Node,TagOut,SVsOut,Dtrs,RuleName),MinimalClosedEmptys)
  )
; member(Rule,ClosedRules),
   assert(Rule),
   fail
).


% ------------------------------------------------------------------------------
% minimise_emptys(+Emptys:emptys,+Accum:emptys,?MinimalEmptys:emptys)
% ------------------------------------------------------------------------------
% MinimalEmptys is the minimal list resulting from combining Emptys and
% Accum.  A list of empty(N,Node,Tag,SVs,Iqs,Dtrs,RuleName) terms is minimal
% iff no term on the list subsumes any other term.
% ------------------------------------------------------------------------------
minimise_emptys([],MinimalEmptys,MinimalEmptys).
minimise_emptys([BE|BasicEmptys],Accum,MinimalEmptys) :-
  minimise_emptys_act(Accum,BE,BasicEmptys,NewAccum,NewAccum,MinimalEmptys).

minimise_emptys_act([],B,BsRest,NewAccum,[B],MEs) :-
  minimise_emptys(BsRest,NewAccum,MEs).
minimise_emptys_act([A|AsRest],B,BsRest,NewAccum,NARest,MEs) :-
  A = empty(_,_,ATag,ASVs,_,_),
  B = empty(_,_,BTag,BSVs,_,_),
  empty_assoc(H),
  empty_assoc(K),
  frozen_term([ATag|ASVs],AFrozen),
  frozen_term([BTag|BSVs],BFrozen),
  build_iqs(AFrozen,AIqs,_),
  build_iqs(BFrozen,BIqs,_),
  subsume(s(ATag,ASVs,BTag,BSVs,sdone),<,>,LReln,RReln,H,K,AIqs,BIqs),
  me_subsume_act(LReln,RReln,A,B,AsRest,BsRest,NewAccum,NARest,MEs).

me_subsume_act(<,_,A,_,AsRest,BsRest,NewAccum,[A|AsRest],MEs) :-
  nl,write('EFD-closure discarded a subsumed empty category'),
  minimise_emptys(BsRest,NewAccum,MEs).
me_subsume_act(#,>,_,B,AsRest,BsRest,NewAccum,NARest,MEs) :-
  nl,write('EFD-closure discarded a subsumed empty category'),
  minimise_emptys_act(AsRest,B,BsRest,NewAccum,NARest,MEs).
me_subsume_act(#,#,A,B,AsRest,BsRest,NewAccum,[A|NARest],MEs) :-
  minimise_emptys_act(AsRest,B,BsRest,NewAccum,NARest,MEs).

% ------------------------------------------------------------------------------
% close_emptys(+Emptys:emptys,-ClosedEmptys:emptys,-ClosedRules:rules)
% ------------------------------------------------------------------------------
% Close Emptys under the rules in the database to obtain ClosedEmptys.  In
%  the process, we also close those rules closed under empty category prefixes,
%  to obtain ClosedRules.
% ------------------------------------------------------------------------------
close_emptys(Emptys,ClosedEmptys,ClosedRules) :-
  findall(alec_rule(RuleName,Dtrs,_,Mother,PrevDtrs,PrevDtrs),
        (current_predicate(rule,(_ rule _)),
         (RuleName rule Mother ===> Dtrs)),
        Rules),
  efd_iterate(Emptys,Rules,[],[],[],ClosedEmptys,ClosedRules).

% ------------------------------------------------------------------------------
% efd_iterate(+Es:emptys,+Rs:rules,+NRs:rules,+EAs:emptys,+RAs:rules,
%             -ClosedEmptys:emptys,-ClosedRules:rules)
% ------------------------------------------------------------------------------
% The Empty-First-Daughter closure algorithm closes a given collection of
%  base empty categories and base extended PS rules breadth-first under
%  prefixes of empty category daughters.  This has the following benefits:
%  1) it corrects a long-standing problem in ALE with combining empty
%     categories.  Because any permutation of empty categories can, in
%     principle, be combined to form a new empty category, ALE cannot perform
%     depth-first closure under a leftmost empty category as it can with
%     normal edges;
%  2) it corrects a problem that non-ISO-compatible Prologs, including SICStus
%     Prolog, have with asserted predicates that results in empty category
%     leftmost daughters not being able to combine with their own outputs;
%  3) it allows parsers to establish a precondition that rules only need to
%     be closed with non-empty leftmost daughters at run-time.  As a result,
%     when a new mother category is created and closed under rules as the
%     leftmost daughter, it cannot combine with other edges created with the
%     same left node.  This allows ALE, at each step in its right-to-left pass
%     throught the string, to copy all of the edges in the internal database
%     back onto the heap before they can be used again, and thus reduces
%     edge copying to a constant 2/edge for non-empty edges (edges with
%     different left and right nodes).  Keeping a copy of the chart on the
%     heap also allows for more sophisticated indexing strategies that would
%     otherwise be overwhelmed by the cost of copying the edge before matching.
%
% Let Es,Rs,NEs,NRs,EAs, and RAs be lists.  Initialise Es to the base empty
%  categories, and Rs to the base rules, and the others to []
%
% loop:
% while Es =/= [] do
%   for each E in Es do
%     for each R in Rs do
%       match E against the leftmost unmatched category description of R
%       if it does not match, continue
%       if the leftmost category was the rightmost (unary rule), then
%         add the new empty category to NEs
%       otherwise, add the new rule (with leftmost category marked as matched)
%         to NRs
%     od
%   od
%   EAs := Es + EAs
%   Rs := Rs + RAs, RAs := []
%   Es := NEs, NEs := []
% od
% if NRs = [],
%  then end: EAs are the closed empty cats, Rs are the closed rules
%  else
%    Es := EAs, EAs := []
%    RAs := Rs, Rs := NRs, NRs := []
%    go to loop
%
% This algorithm terminates for exactly those grammars in which bottom-up
%  parsing over empty categories terminates, i.e., it is no worse than pure
%  bottom-up parsing.
% ------------------------------------------------------------------------------
efd_iterate([],Rules,NewRules,EmptyAccum,_RuleAccum,  % RuleAccum is []
            ClosedEmptys,ClosedRules) :-
  !,
  (NewRules == []
  -> ClosedEmptys = EmptyAccum, ClosedRules = Rules
   ; efd_iterate(EmptyAccum,NewRules,[],[],Rules,ClosedEmptys,ClosedRules)
  ).
efd_iterate(Emptys,Rules,NewRules,EmptyAccum,RuleAccum,
            ClosedEmptys,ClosedRules) :-
  apply_once(Emptys,Rules,NewEmptysandRules),
  split_emptys_rules(NewEmptysandRules,NewRules,NewRules1,NewEmptys),
  append(Emptys,EmptyAccum,EmptyAccum1),
  append(Rules,RuleAccum,Rules1),
  efd_iterate(NewEmptys,Rules1,NewRules1,EmptyAccum1,[],
              ClosedEmptys,ClosedRules).

% ------------------------------------------------------------------------------
% apply_once(+Es:emptys,+Rs:emptys,-NEsorRs:empty_or_rules)
% ------------------------------------------------------------------------------
% the two for-loops of the EFD-closure algorithm above.
% ------------------------------------------------------------------------------
apply_once(Emptys,Rules,NewEmptysandRules) :-
  findall(EmptyorRule,
          (member(Empty,Emptys),
           member(alec_rule(RuleName,Dtrs,Node,Mother,PrevDtrs,PrevDtrsMid),
                  Rules),

           match_cat_to_next_cat(Dtrs,Mother,RuleName,PrevDtrs,PrevDtrsMid,
                                 Empty,EmptyorRule,Node)

%   arg(1,Empty,N), % DEBUG
%                                  write(user_error,'matched '),write(user_error,N),
%   write(user_error,' to '),write(user_error,RuleName),
%   nl(user_error),flush_output(user_error)

  ),
          NewEmptysandRules).

% ------------------------------------------------------------------------------
% split_emptys_rules(+NEsorRs:empty_or_rules,+NRsOld:rules,
%                    -NRsNew:rules,-NEsNew:emptys)
% ------------------------------------------------------------------------------
% classifies the results of apply_once/3 as empty cats or rules, and adds them
% to NEs or NRs, respectively.
% ------------------------------------------------------------------------------

split_emptys_rules([],NewRulesRest,NewRulesRest,[]).
split_emptys_rules([Item|Items],NewRulesRest,NewRules,NewEmptys) :-
  functor(Item,Functor,_),
  (Functor == alec_rule
  -> NewRules = [Item|NewRulesMid],
%     nl,write('EFD-closure generated a partial rule'),
     split_emptys_rules(Items,NewRulesRest,NewRulesMid,NewEmptys)
   ; % Functor == empty,
     NewEmptys = [Item|NewEmptysMid],
%     nl,write('EFD-closure generated an empty category'),
     split_emptys_rules(Items,NewRulesRest,NewRules,NewEmptysMid)
  ).

% ------------------------------------------------------------------------------
% match_cat_to_next_cat(+Dtrs:dtrs,+Mother:desc,+RuleName:atom,
%                       +PrevDtrs:s,-PrevDtrsRest:s,
%                       +RuleIqs:ineqs,+Empty:empty,
%                       -EmptyorRule:empty_or_rule,-Node:var_int)
% ------------------------------------------------------------------------------
% interpretive matching of empty category to leftmost category description
% plus all procedural attachments up to the next category description.
% ------------------------------------------------------------------------------
match_cat_to_next_cat((cat> Dtr,Rest),Mother,RuleName,PrevDtrs,
                      [empty(N,Node)|PrevDtrsMid],
                      empty(N,Node,Tag,SVs,_,_),EmptyorRule,Node) :-
  add_to(Dtr,Tag,SVs),
  match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,
                    EmptyorRule,Node).
match_cat_to_next_cat((cat> Dtr),Mother,RuleName,PrevDtrs,[empty(N,Node)],
                      empty(N,Node,Tag,SVs,_,_),
                      empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
                      Node) :-
  add_to(Dtr,Tag,SVs),
  add_to(Mother,Tag2,bot),
  fully_deref(Tag2,bot,TagOut,SVsOut),
  gen_emptynum(NewN).
match_cat_to_next_cat((sem_head> Dtr,Rest),Mother,RuleName,PrevDtrs,
                      [empty(N,Node)|PrevDtrsMid],
                      empty(N,Node,Tag,SVs,_,_),EmptyorRule,Node) :-
  add_to(Dtr,Tag,SVs),
  match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,
                    EmptyorRule,Node).
match_cat_to_next_cat((sem_head> Dtr),Mother,RuleName,PrevDtrs,[empty(N,Node)],
                      empty(N,Node,Tag,SVs,_,_),
                      empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
                      Node) :-
  add_to(Dtr,Tag,SVs),
  add_to(Mother,Tag2,bot),
  fully_deref(Tag2,bot,TagOut,SVsOut),
  gen_emptynum(NewN).
match_cat_to_next_cat((cats> Dtrs,Rest),Mother,RuleName,PrevDtrs,PrevDtrsMid,
                      Empty,EmptyorRule,Node) :-
  add_to(Dtrs,DtrsTag,bot),
  deref(DtrsTag,bot,_DTag,DSVs),
  functor(DSVs,DtrsType,_),
  (sub_type(ne_list,DtrsType)
  -> arg(1,DSVs,HdFS),
     Empty = empty(N,Node,Tag,SVs,_,_),
     ud(HdFS,Tag,SVs),
     arg(2,DSVs,TlFS),
     deref(TlFS,TlTag,TlSVs),
     functor(TlSVs,TlType,_),
     (sub_type(ne_list,TlType)
     -> PrevDtrsMid = [empty(N,Node)|PrevDtrsRest],
        EmptyorRule = alec_rule(RuleName,(remainder(TlTag,TlSVs),Rest),Node,Mother,
                                PrevDtrs,PrevDtrsRest)
      ; (sub_type(e_list,TlType)
        -> PrevDtrsMid = [empty(N,Node)|PrevDtrsMid2],
           match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid2,
                             EmptyorRule,Node)
         ; error_msg((nl,write('error: cats> value with sort, '),write(TlType),
                      write(' is not a valid argument (e_list or ne_list)')))
        )
     )
   ; (sub_type(e_list,DtrsType)
     -> match_cat_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,
                              Empty,EmptyorRule,Node)
      ; error_msg((nl,write('error: cats> value with sort, '),write(DtrsType),
                   write(' is not a valid argument (e_list or ne_list)')))
     )
  ).
match_cat_to_next_cat((cats> Dtrs),Mother,RuleName,PrevDtrs,PrevDtrsMid,
                      empty(N,Node,Tag,SVs,_,_),EmptyorRule,
                      Node) :-
  add_to(Dtrs,DtrsTag,bot),
  deref(DtrsTag,bot,_DTag,DSVs),
  functor(DSVs,DtrsType,_),
  (sub_type(ne_list,DtrsType)
  -> arg(1,DSVs,HdFS),
     ud(HdFS,Tag,SVs),
     arg(2,DSVs,TlFS),
     deref(TlFS,TlTag,TlSVs),
     functor(TlSVs,TlType,_),
     (sub_type(ne_list,TlType)
     -> PrevDtrsMid = [empty(N,Node)|PrevDtrsRest],
        EmptyorRule = alec_rule(RuleName,remainder(TlTag,TlSVs),Node,Mother,PrevDtrs,
                                PrevDtrsRest)
      ; (sub_type(e_list,TlType)
        -> add_to(Mother,Tag2,bot),
           fully_deref(Tag2,bot,TagOut,SVsOut),
           PrevDtrsMid = [empty(N,Node)],
           EmptyorRule = empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
           gen_emptynum(NewN)
         ; error_msg((nl,write('error: cats> value with sort, '),write(TlType),
                      write(' is not a valid argument (e_list or ne_list)')))
        )
     )
   ; (sub_type(e_list,DtrsType)
     -> error_msg((nl,write('error: rule '),write(RuleName),
                   write(' has no daughters')))
      ; error_msg((nl,write('error: cats> value with sort, '),write(DtrsType),
                   write(' is not a valid argument (e_list or ne_list)')))
     )
  ).
match_cat_to_next_cat((remainder(_,RSVs),Rest),Mother,RuleName,PrevDtrs,
                      PrevDtrsMid,empty(N,Node,Tag,SVs,_,_),
                      EmptyorRule,Node) :-
  arg(1,RSVs,HdFS),
  ud(HdFS,Tag,SVs),
  arg(2,RSVs,TlFS),
  deref(TlFS,TlTag,TlSVs),
  functor(TlSVs,TlType,_),
  (sub_type(ne_list,TlType)
  -> PrevDtrsMid = [empty(N,Node)|PrevDtrsRest],
     EmptyorRule = alec_rule(RuleName,remainder(TlTag,TlSVs),Node,Mother,PrevDtrs,
                             PrevDtrsRest)
   ; (sub_type(e_list,TlType)
     -> PrevDtrsMid = [empty(N,Node)|PrevDtrsMid2],
        match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid2,
                          EmptyorRule,Node)
      ; error_msg((nl,write('error: cats> value with sort, '),write(TlType),
                   write(' is not a valid argument (e_list or ne_list)')))
     )
  ).
match_cat_to_next_cat(remainder(_,RSVs),Mother,RuleName,PrevDtrs,PrevDtrsMid,
                      empty(N,Node,Tag,SVs,_,_),EmptyorRule,
                      Node) :-
  arg(1,RSVs,HdFS),
  ud(HdFS,Tag,SVs),
  arg(2,RSVs,TlFS),
  deref(TlFS,TlTag,TlSVs),
  functor(TlSVs,TlType,_),
  (sub_type(ne_list,TlType)
  -> PrevDtrsMid = [empty(N,Node)|PrevDtrsRest],
     EmptyorRule = alec_rule(RuleName,remainder(TlTag,TlSVs),Node,Mother,PrevDtrs,
                             PrevDtrsRest)
   ; (sub_type(e_list,TlType)
     -> add_to(Mother,Tag2,bot),
        fully_deref(Tag2,bot,TagOut,SVsOut),
        PrevDtrsMid = [empty(N,Node)],
        EmptyorRule = empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
        gen_emptynum(NewN)
      ; error_msg((nl,write('error: cats> value with sort, '),write(TlType),
                   write(' is not a valid argument (e_list or ne_list)')))
     )
  ).
match_cat_to_next_cat((goal> GoalDesc,Rest),Mother,RuleName,PrevDtrs,
                      PrevDtrsMid,Empty,EmptyorRule,Node) :-
  query_goal(GoalDesc),
%  call(Goal), --- query_goal/1 now calls its Goal
  match_cat_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,
                        Empty,EmptyorRule,Node).
match_cat_to_next_cat((goal> _),_,RuleName,_,_,_,_,_) :-
  error_msg((nl,write('error: rule '),write(RuleName),
             write(' has no daughters'))).
match_cat_to_next_cat((sem_goal> GoalDesc,Rest),Mother,RuleName,PrevDtrs,
                      PrevDtrsMid,Empty,EmptyorRule,Node) :-
  query_goal(GoalDesc),
%  call(Goal), --- query_goal/1 now calls its Goal
  match_cat_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,
                        Empty,EmptyorRule,Node).
match_cat_to_next_cat((sem_goal> _),_,RuleName,_,_,_,_,_) :-
  error_msg((nl,write('error: rule '),write(RuleName),
             write(' has no daughters'))).

% ------------------------------------------------------------------------------
% match_to_next_cat(+Dtrs:dtrs,+Mother:desc,+RuleName:atom,
%                   +PrevDtrs:s,-PrevDtrsRest:s,
%                   +RuleIqs:ineqs,-EmptyorRule:empty_or_rule,
%                   -Node:var_int)
% ------------------------------------------------------------------------------
% Same as match_cat_to_next_cat/8 but leftmost category has already been
% matched.  Now interpret all procedural attachments until next category
% is encountered or no daughters remain.
% ------------------------------------------------------------------------------

match_to_next_cat((cat> Dtr,Rest),Mother,RuleName,PrevDtrs,PrevDtrsRest,
                  alec_rule(RuleName,(cat> Dtr,Rest),Node,Mother,PrevDtrs,
                            PrevDtrsRest),
                  Node).
match_to_next_cat((cat> Dtr),Mother,RuleName,PrevDtrs,PrevDtrsRest,
                  alec_rule(RuleName,(cat> Dtr),Node,Mother,PrevDtrs,PrevDtrsRest),
                  Node).
match_to_next_cat((sem_head> Dtr,Rest),Mother,RuleName,PrevDtrs,PrevDtrsRest,
                  alec_rule(RuleName,(sem_head> Dtr,Rest),Node,Mother,PrevDtrs,
                            PrevDtrsRest),
                  Node).
match_to_next_cat((sem_head> Dtr),Mother,RuleName,PrevDtrs,PrevDtrsRest,
                  alec_rule(RuleName,(sem_head> Dtr),Node,Mother,PrevDtrs,PrevDtrsRest),
                  Node).
match_to_next_cat((cats> Dtrs,Rest),Mother,RuleName,PrevDtrs,PrevDtrsMid,
                  EmptyorRule,Node) :-
  add_to(Dtrs,DtrsTag,bot),
  deref(DtrsTag,bot,DTag,DSVs),
  functor(DSVs,DtrsType,_),
  (sub_type(ne_list,DtrsType)
  -> EmptyorRule = alec_rule(RuleName,(remainder(DTag,DSVs),Rest),Node,Mother,PrevDtrs,
                             PrevDtrsMid)
   ; (sub_type(e_list,DtrsType)
     -> match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,EmptyorRule,Node)
      ; error_msg((nl,write('error: cats> value with sort, '),write(DtrsType),
                   write(' is not a valid argument (e_list or ne_list)')))
     )
  ).
match_to_next_cat((cats> Dtrs),Mother,RuleName,PrevDtrs,PrevDtrsMid,
                  EmptyorRule,Node) :-
  add_to(Dtrs,DtrsTag,bot),
  deref(DtrsTag,bot,DTag,DSVs),
  functor(DSVs,DtrsType,_),
  (sub_type(ne_list,DtrsType)
  -> EmptyorRule = alec_rule(RuleName,remainder(DTag,DSVs),Node,Mother,PrevDtrs,
                             PrevDtrsMid)
   ; (sub_type(e_list,DtrsType)
     -> add_to(Mother,Tag,bot),
        fully_deref(Tag,bot,TagOut,SVsOut),
        PrevDtrsMid = [],
        EmptyorRule = empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
        gen_emptynum(NewN)
      ; error_msg((nl,write('error: cats> value with sort, '),write(DtrsType),
                   write(' is not a valid argument (e_list or ne_list)')))
     )
  ).
match_to_next_cat((goal> GoalDesc,Rest),Mother,RuleName,PrevDtrs,PrevDtrsMid,
                  EmptyorRule,Node) :-
  query_goal(GoalDesc),
%  call(Goal), --- query_goal/1 now calls its Goal
  match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,EmptyorRule,Node).
match_to_next_cat((goal> GoalDesc),Mother,RuleName,PrevDtrs,[],
                  empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
                  Node) :-
  query_goal(GoalDesc),
%  call(Goal), --- query_goal/1 now calls its Goal
  add_to(Mother,Tag,bot),
  fully_deref(Tag,bot,TagOut,SVsOut),
  gen_emptynum(NewN).
match_to_next_cat((sem_goal> GoalDesc,Rest),Mother,RuleName,PrevDtrs,
                  PrevDtrsMid,EmptyorRule,Node) :-
  query_goal(GoalDesc),
%  call(Goal), --- query_goal/1 now calls its Goal
  match_to_next_cat(Rest,Mother,RuleName,PrevDtrs,PrevDtrsMid,EmptyorRule,Node).
match_to_next_cat((sem_goal> GoalDesc),Mother,RuleName,PrevDtrs,[],
                  empty(NewN,Node,TagOut,SVsOut,PrevDtrs,RuleName),
                  Node) :-
  query_goal(GoalDesc),
%  call(Goal), --- query_goal/1 now calls its Goal
  add_to(Mother,Tag,bot),
  fully_deref(Tag,bot,TagOut,SVsOut),
  gen_emptynum(NewN).


% ------------------------------------------------------------------------------
% rule(Tag:var_tag, SVs:svs, Iqs:ineqs, Left:int, Right:int,
%      N:int,Chart:chart)                                              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(_,_,_,_,_,_) if_h [fail] :-
  \+ clause(alec_rule(_,_,_,_,_,_),true).
rule(Tag,SVs,Left,Right,N,Chart) if_h SubGoals :-
  empty_assoc(VarsIn),
  clause(alec_rule(RuleName,Daughters,Left,Mother,PrevDtrs,PrevDtrsRest),true),
  compile_dtrs(Daughters,Tag,SVs,Left,Right,N,SubGoalsMid,[],PrevDtrs,
               PrevDtrsRest,Mother,RuleName,Chart,true,VarsIn,_,FSPal,[],
               FSsOut),
  build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsMid,rule).

% ------------------------------------------------------------------------------
% compile_dtrs(Dtrs,Tag,SVs,Iqs,Left,Right,N,PGoals,PGoalsRest,Dtrs,DtrsRest,
%              Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut)
% ------------------------------------------------------------------------------
% compiles description Dtrs to apply rule to first category Tag-SVs,
% at position Left-Right in chart, producing a list of Prolog goals
% diff list PGoals-PGoalsRest;  Mother is result produced
% ------------------------------------------------------------------------------
compile_dtrs((cat> Dtr,Rest),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
             Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
             FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),
  DtrsMid = [N|DtrsRest],
  compile_dtrs_rest(Rest,Left,Right,PGoalsMid,PGoalsRest,Mother,
                    Dtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
                    FSsMid,FSsOut).
% 5/1/96 Octav -- added a clause for 'sem_head>' label
% (sem_head> daughters behave just like cat> daughters during parsing)
compile_dtrs((sem_head> Dtr,Rest),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
             Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
             FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,
       NVs),
  DtrsMid = [N|DtrsRest],
  compile_dtrs_rest(Rest,Left,Right,PGoalsMid,PGoalsRest,Mother,
                    Dtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
                    FSsMid,FSsOut).
compile_dtrs((cats> Dtrs,Rest),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
             PrevDtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,
             FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtrs,Tag2,bot,PGoals,
       [deref(Tag2,bot,_,DescSVs),
        DescSVs =.. [Sort|Vs],
        ((Sort == e_list) ->
          PGoal_elist
        ; (match_list(Sort,Vs,Tag,SVs,Right,N,DtrsMid,DtrsRest,Chart,NextRight),  % a_ correctly causes error
           PGoal_nelist))|PGoalsRest],CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_dtrs_rest(Rest,Left,NextRight,PGoalsMid_nelist,[],
               Mother,PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,
               Vars_nelist,FSPal,FSsMid,FSs_nelist),
  compile_dtrs(Rest,Tag,SVs,Left,Right,N,PGoalsMid_elist,[],
               PrevDtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsMid,
               Vars_elist,FSPal,FSsMid,FSs_elist),
  goal_list_to_seq(PGoalsMid_nelist,PGoal_nelist),
  goal_list_to_seq(PGoalsMid_elist,PGoal_elist),
  vars_merge(Vars_nelist,Vars_elist,VarsOut),
  fss_merge(FSs_nelist,FSs_elist,FSsOut).
compile_dtrs((remainder(RTag,RSVs),Rest),Tag,SVs,Left,Right,N,PGoals,
             PGoalsRest,Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,
             FSPal,FSsIn,FSsOut) :-
  !,PGoals = [arg(Arg,FSPal,RVar),
              arg(2,RVar,RVarSVs),
              RVarSVs =.. [Sort|Vs],
              match_list(Sort,Vs,Tag,SVs,Right,N,DtrsMid,DtrsRest,Chart,NextRight)|PGoalsMid],
  FSsMid = [seen(RTag,RSVs,RVar,Arg)|FSsIn],
  compile_dtrs_rest(Rest,Left,NextRight,PGoalsMid,PGoalsRest,Mother,
                    Dtrs,DtrsRest,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,
                    FSsMid,FSsOut).
compile_dtrs((goal> Goal,Rest),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
             Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
             FSsOut):-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,
               FSPal,FSsIn,FSsMid,NVs),
  compile_dtrs(Rest,Tag,SVs,Left,Right,N,PGoalsMid,PGoalsRest,
               Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
               FSsMid,FSsOut).
% 6/1/97 Octav -- added a clause for 'sem_goal>' label
% (sem_goal> daughters behave just like goal> daughters during parsing)
compile_dtrs((sem_goal> Goal,Rest),Tag,SVs,Left,Right,N,PGoals,
             PGoalsRest,Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,
             FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
               FSsIn,FSsMid,NVs),
  compile_dtrs(Rest,Tag,SVs,Left,Right,N,PGoalsMid,PGoalsRest,
               Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
               FSsMid,FSsOut).
compile_dtrs((cat> Dtr),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,Dtrs,
             [N],Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,Right,Tag2,bot,Dtrs,RuleName,Chart)|
                PGoalsRest],CBSafe,VarsMid,VarsOut,FSPal,FSsMid,FSsOut,NVs).
% 5/1/96 Octav -- added a clause for 'sem_head>' label
% (behaves the same as cat> during parsing)
compile_dtrs((sem_head> Dtr),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
     Dtrs,[N],Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
             FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,Right,Tag2,bot,Dtrs,RuleName,Chart)|
                PGoalsRest],CBSafe,VarsMid,VarsOut,FSPal,FSsMid,FSsOut,NVs).
% don't check inequations after mother since add_edge_deref does that
compile_dtrs((cats> Dtrs),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
             PrevDtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,
             FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtrs,Tag3,bot,PGoals,
      [deref(Tag3,bot,_,DescSVs),
       DescSVs =.. [Sort|Vs],
       ((Sort == e_list) ->
         fail
       ; (match_list(Sort,Vs,Tag,SVs,Right,N,DtrsMid,[],Chart,NextRight),
          PGoal))|PGoalsRest],CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs), % a_
  compile_desc(Mother,Tag2,bot,PGoalsMid,   %  correctly causes error
          [add_edge_deref(Left,NextRight,Tag2,bot,PrevDtrs,RuleName,
                          Chart)],
          CBSafe,VarsMid,VarsOut,FSPal,FSsMid,FSsOut,NVs),
  goal_list_to_seq(PGoalsMid,PGoal).
compile_dtrs(remainder(RTag,RSVs),Tag,SVs,Left,Right,N,PGoals,PGoalsRest,
             Dtrs,DtrsMid,Mother,RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
             FSsOut) :-
  !,PGoals = [arg(Arg,FSPal,RVar),
              arg(2,RVar,RVarSVs),
              RVarSVs =.. [Sort|Vs],
              match_list(Sort,Vs,Tag,SVs,Right,N,DtrsMid,[],Chart,NextRight)|PGoalsMid],
  FSsMid = [seen(RTag,RSVs,RVar,Arg)|FSsIn],
  empty_assoc(NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,NextRight,Tag2,bot,Dtrs,RuleName,Chart)|PGoalsRest],
               CBSafe,VarsIn,VarsOut,FSPal,FSsMid,FSsOut,NVs).
compile_dtrs(Foo,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_):-
  error_msg((nl,write_list([invalid,line,Foo,in,rule]),ttynl)).

% ------------------------------------------------------------------------------
% compile_dtrs_rest(Dtrs,Left,Right,IqsMid,PGoals,PGoalsRest,Mother,
%                   PrevDtrs,DtrsRest,RuleName,CBSafe,VarsIn,VarsOut,FSPal,
%                   FSsIn,FSsOut)
% ------------------------------------------------------------------------------
% same as compile_dtrs, only after first category on RHS of rule is
% found;  thus looks for an edge/7 if a cat> or cats> spec is found
% ------------------------------------------------------------------------------
compile_dtrs_rest((cat> Dtr,Rest),Left,Right,
            [get_edge(Right,Chart,N,NewRight,Tag,SVs,_,_)|PGoals],
            PGoalsRest,Mother,PrevDtrs,[N|DtrsRest],RuleName,Chart,CBSafe,VarsIn,
            VarsOut,FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_dtrs_rest(Rest,Left,NewRight,PGoalsMid,PGoalsRest,Mother,
                    PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
                    FSsMid,FSsOut).
% 5/1/96 - Octav -- added a clause for 'sem_head>' label
compile_dtrs_rest((sem_head> Dtr,Rest),Left,Right,
             [get_edge(Right,Chart,N,NewRight,Tag,SVs,_,_)|PGoals],
             PGoalsRest,Mother,PrevDtrs,[N|DtrsRest],RuleName,Chart,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_dtrs_rest(Rest,Left,NewRight,PGoalsMid,PGoalsRest,Mother,
                    PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
                    FSsMid,FSsOut).
compile_dtrs_rest((cats> Dtrs,Rest),Left,Right,PGoals,PGoalsRest,
                  Mother,PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtrs,Tag,bot,PGoals,
    [deref(Tag,bot,_,SVs),
     SVs =.. [Sort|Vs],
     match_list_rest(Sort,Vs,Right,NewRight,DtrsRest,DtrsRest2,Chart)|PGoalsMid],
     CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),          % a_ causes error
  compile_dtrs_rest(Rest,Left,NewRight,PGoalsMid,PGoalsRest,Mother,
                    PrevDtrs,DtrsRest2,RuleName,Chart,CBSafe,VarsMid,VarsOut,
                    FSPal,FSsMid,FSsOut).
compile_dtrs_rest((goal> Goal,Rest),Left,Right,PGoals,PGoalsRest,
                  Mother,PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,
               FSPal,FSsIn,FSsMid,NVs),
  compile_dtrs_rest(Rest,Left,Right,PGoalsMid,PGoalsRest,Mother,
                    PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,VarsOut,
                    FSPal,FSsMid,FSsOut).
% 6/1/97 Octav -- added a clause for 'sem_goal>' label
% (sem_goal> daughters behave just like goal> daughters during parsing)
compile_dtrs_rest((sem_goal> Goal,Rest),Left,Right,PGoals,PGoalsRest,
                  Mother,PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsIn,VarsOut,
                  FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
               FSsIn,FSsMid,NVs),
  compile_dtrs_rest(Rest,Left,Right,PGoalsMid,PGoalsRest,Mother,
                    PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsMid,VarsOut,FSPal,
                    FSsMid,FSsOut).
compile_dtrs_rest((cat> Dtr),Left,Right,
              [get_edge(Right,Chart,N,NewRight,Tag,SVs,_,_)|PGoals],
              PGoalsRest,Mother,PrevDtrs,[N],RuleName,Chart,CBSafe,VarsIn,VarsOut,
              FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,NewRight,Tag2,bot,
                               PrevDtrs,RuleName,Chart)|PGoalsRest],CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
% 5/1/96 - Octav -- added a clause for 'sem_head>' label
compile_dtrs_rest((sem_head> Dtr),Left,Right,
              [get_edge(Right,Chart,N,NewRight,Tag,SVs,_,_)|PGoals],
              PGoalsRest,Mother,PrevDtrs,[N],RuleName,Chart,CBSafe,VarsIn,VarsOut,
              FSPal,FSsIn,FSsOut):-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,SVs,PGoals,PGoalsMid,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,NewRight,Tag2,bot,
                               PrevDtrs,RuleName,Chart)|PGoalsRest],CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
% don't check inequations after mother since add_edge_deref does that
compile_dtrs_rest((cats> Dtrs),Left,Right,PGoals,PGoalsRest,
                  Mother,PrevDtrs,DtrsRest,RuleName,Chart,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtrs,Tag,bot,PGoals,
    [deref(Tag,bot,_,SVs),
     SVs =.. [Sort|Vs],
     match_list_rest(Sort,Vs,Right,NewRight,DtrsRest,[],Chart)|PGoalsMid],
    CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),               % a_ causes error
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,NewRight,Tag2,bot,
                               PrevDtrs,RuleName,Chart)|PGoalsRest],CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
% don't check inequations after mother since add_edge_deref does that
compile_dtrs_rest((goal> Goal),Left,Right,PGoals,PGoalsRest,Mother,
                  PrevDtrs,[],RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
                  FSsOut):-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
               FSsIn,FSsMid,NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,Right,Tag2,bot,
                               PrevDtrs,RuleName,Chart)|PGoalsRest],CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
% 6/1/97 Octav -- added a clause for 'sem_goal>' label
% (sem_goal> daughters behave just like goal> daughters during parsing)
% don't check inequations after mother since add_edge_deref does that
compile_dtrs_rest((sem_goal> Goal),Left,Right,PGoals,PGoalsRest,Mother,
                  PrevDtrs,[],RuleName,Chart,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
                  FSsOut):-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoals,PGoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
               FSsIn,FSsMid,NVs),
  compile_desc(Mother,Tag2,bot,PGoalsMid,
               [add_edge_deref(Left,Right,Tag2,bot,
                               PrevDtrs,RuleName,Chart)|PGoalsRest],CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
% don't check inequations after mother since add_edge_deref does that
compile_dtrs_rest(Foo,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_):-
  error_msg((nl,write_list([invalid,line,Foo,in,rule]),ttynl)).

% ------------------------------------------------------------------------------
% Description Compiler
% [User's Manual] [Reference Manual]
% compile_desc(Desc:desc, FS:fs, IqsIn:ineqs, IqsOut:ineqs,
%              Goals:goals, GoalsRest:goals, CBSafe:bool, VarsIn:avl,
%              VarsOut:avl, FSPal:var, FSsIn:fss, FSsOut:fss)
% ------------------------------------------------------------------------------
% Goals are the Prolog goals required to add the description Desc
% to the feature structure FS.  IqsIn and IqsOut are uninstantiated at
% compile time.  VarsIn and VarsOut are description-level variables that
% have been seen or may have been seen already.  If a variable has definitely
% not been seen yet and CBSafe is true, then it is safe to bind that variable
% at compile-time.
% ------------------------------------------------------------------------------
compile_desc(X,FS2,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,_,FSs,FSs,NVs) :-
  var(X),
  !,
  ( get_assoc(X,NVs,seen(Var)) -> true
  ; Var = X
  ),
  ( get_assoc(Var,VarsIn,Seen,VarsOut,seen)         % have we seen it before?
    -> ( Seen == seen -> Goals = [ud(Var,FS2)|GoalsRest] % yes
       ; % Seen == tricky,                        % maybe - check at run-time
         Goals = [(var(Var)
                  -> Var=FS2
                   ; ud(Var,FS2))|GoalsRest]
       )                                            % otherwise, no -
  ; ( CBSafe == true -> Var = FS2,  Goals = GoalsRest % bind var at compile-time
    ; % CBSafe == false,                              %  if safe
      Goals = [Var = FS2|GoalsRest]                   % otherwise at run-time
    ),
    put_assoc(Var,VarsIn,seen,VarsOut)  % mark as seen
  ).
compile_desc(Tag1-SVs1,FS2,Goals,GoalsRest,_CBSafe,Vars,Vars,FSPal,
             FSsIn,FSsOut,_):-  % shouldn't we map through NVs here?
  !,
  deref(Tag1,SVs1,DTag1,DSVs1),
%  (var(DSVs1) -> write(user_error,'variable SV'),
%                 Goals = [ud(FS2,DTag1,DSVs1,IqsIn,IqsOut)|GoalsRest],
%                 FSsOut = FSsIn
  find_fs(FSsIn,DTag1,DSVs1,Goals,[ud(FSVar,FS2)|GoalsRest],
            FSVar,FSPal,FSsOut).
%  ).
compile_desc([],FS,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,
             FSsOut,NVs):-
  !, compile_desc(e_list,FS,Goals,GoalsRest,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc([H|T],FS,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  !, compile_desc((hd:H,tl:T),FS,Goals,GoalsRest,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc(Path1 == Path2,FS,Goals,GoalsRest,_,Vars,Vars,_,FSs,FSs,_):-
  !, compile_pathval(Path1,FS,FSatPath1,Goals,GoalsMid),
  compile_pathval(Path2,FS,FSatPath2,
                  GoalsMid,[ud(FSatPath1,FSatPath2)|GoalsRest]).
compile_desc(=\= Desc,FS,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !,compile_desc(Desc,Tag2,bot,Goals,
      [ineq(FS,Tag2-bot)|GoalsRest],CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc(Feat:Desc,FS,[deref(FS,Tag,SVs),Goal|GoalsMid],
             GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, ( approp(Feat,_,_) -> true
     ; error_msg((nl,write_list([description,uses,unintroduced,feature,Feat]),ttynl))
     ),
  cat_atoms('featval_',Feat,Rel),
  Goal =.. [Rel,SVs,Tag,FSatFeat],
  compile_desc(Desc,FSatFeat,GoalsMid,GoalsRest,CBSafe,VarsIn,
               VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc((Desc1,Desc2),FS,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_desc(Desc1,FS,Goals,GoalsMid,CBSafe,VarsIn,VarsMid,FSPal,
                  FSsIn,FSsMid,NVs),
  compile_desc(Desc2,FS,GoalsMid,GoalsRest,CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
compile_desc((Desc1;Desc2),FS,
             [(Goals1Seq;Goals2Seq)|GoalsRest],GoalsRest,_,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  !, compile_desc(Desc1,FS,Goals1,[],false,VarsIn,VarsDisj1,FSPal,
                  FSsIn,FSsDisj1,NVs),
  compile_desc(Desc2,FS,Goals2,[],false,VarsIn,VarsDisj2,FSPal,FSsIn,
               FSsDisj2,NVs),
  goal_list_to_seq(Goals1,Goals1Seq),
  goal_list_to_seq(Goals2,Goals2Seq),
  vars_merge(VarsDisj1,VarsDisj2,VarsOut),
  fss_merge(FSsDisj1,FSsDisj2,FSsOut).
compile_desc(@ MacroName,FS,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, ( (MacroName macro Desc) -> true
     ; error_msg((nl,write_list([undefined,macro,MacroName,used,in,description]),ttynl))
     ),  % we used to backtrack on macro definitions here - bad move
  compile_desc(Desc,FS,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
               FSsIn,FSsOut,NVs).
compile_desc(a_ X,FS,[deref(FS,Tag,SVs),Goal|GoalsRest],
             GoalsRest,_,Vars,Vars,_,FSs,FSs,_) :-
  !, Goal =.. ['add_to_type_a_',SVs,Tag,X].
compile_desc(FunDesc,FS,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  functor(FunDesc,Functor,FunArity),
  findall(ResArg,clause(fun_spec(Functor,FunArity,ResArg),true),ResArgs), % could have more than one of these
  ResArgs = [RA1|RAsRest],                            % - that introduces ambiguity as to which arg is result.
  !,FunDesc =.. [_|FunDescArgs],
  name(Functor,FunName),
  append("fs_",FunName,RelName),
  name(Rel,RelName),
  compile_descs_fresh(FunDescArgs,FunArgs,Goals,[Goal|GoalsRest],CBSafe,VarsIn,VarsOut,
                      FSPal,FSsIn,FSsOut,NVs),
  compile_funs(RAsRest,RA1,Rel,FS,FunArgs,FunArity,Goal).
compile_desc(Type,FS,[deref(FS,Tag,SVs),Goal|GoalsRest],
             GoalsRest,_,Vars,Vars,_,FSs,FSs,_):-
  ( type(Type) -> true
  ; error_msg((nl,write_list([undefined,type,Type,used,in,description]),ttynl))
  ),
  cat_atoms('add_to_type_',Type,AddtotypeType),
  Goal =.. [AddtotypeType,SVs,Tag].

% ------------------------------------------------------------------------------
% compile_desc(Desc:desc, Tag:ref, SVs:svs, IqsIn:ineqs,
%              IqsOut:ineqs, Goals:goals, GoalsRest:goals, CBSafe:bool,
%              VarsIn:avl, VarsOut:avl, FSPal:var, FSsIn:fss,
%              FSsOut:fss)
% ------------------------------------------------------------------------------
% 12-place version of compile_desc/11
% ------------------------------------------------------------------------------
compile_desc(X,Tag2,SVs2,Goals,GoalsRest,_CBSafe,VarsIn,VarsOut,_,FSs,
             FSs,NVs) :-
  var(X),
  !,
  ( get_assoc(X,NVs,seen(Var)) -> true
  ; Var = X
  ),
  ( get_assoc(Var,VarsIn,Seen,VarsOut,seen)         % have we seen it before?
    -> ( Seen == seen -> Goals = [ud(Var,Tag2,SVs2)|GoalsRest] % yes
       ; % Seen == tricky,                        % maybe - check at run-time
         Goals = [(var(Var)
                  -> Var=Tag2-SVs2
                   ; ud(Var,Tag2,SVs2))|GoalsRest]
       )                                            % otherwise, no -
  ; Goals = [Var = Tag2-SVs2|GoalsRest],  % bind at run-time even if safe at compile-
                                        %  time to reduce structure copying in compiled code
    put_assoc(Var,VarsIn,seen,VarsOut)  % mark as seen
  ).
compile_desc(Tag1-SVs1,Tag2,SVs2,Goals,GoalsRest,_,Vars,Vars,FSPal,
             FSsIn,FSsOut,_):-
  !,
  deref(Tag1,SVs1,DTag1,DSVs1),
%  (var(DSVs1) -> write(user_error,'variable SV'),
%                 Goals = [ud(DTag1,DSVs1,Tag2,SVs2,IqsIn,IqsOut)|GoalsRest],
%                 FSsOut = FSsIn
  find_fs(FSsIn,DTag1,DSVs1,Goals,[ud(FSVar,Tag2,SVs2)|GoalsRest],
          FSVar,FSPal,FSsOut).
%  ).
compile_desc([],Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  !, compile_desc(e_list,Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
                  VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc([H|T],Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_desc((hd:H,tl:T),Tag,SVs,Goals,GoalsRest,CBSafe,
                  VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc(Path1 == Path2,Tag,SVs,Goals,GoalsRest,_,Vars,Vars,_,FSs,
             FSs,_):-
  !, compile_pathval(Path1,Tag,SVs,FSatPath1,Goals,GoalsMid),
  compile_pathval(Path2,Tag,SVs,FSatPath2,
                  GoalsMid,[ud(FSatPath1,FSatPath2)|GoalsRest]).
compile_desc(=\= Desc,Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
  !,compile_desc(Desc,Tag2,bot,Goals,
      [ineq(Tag-SVs,Tag2-bot)|GoalsRest],CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc(Feat:Desc,Tag,SVs,
             [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsMid],
             GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, ( approp(Feat,_,_) -> true
     ; error_msg((nl,write_list([description,uses,unintroduced,feature,Feat]),ttynl))
     ),
  cat_atoms('featval_',Feat,Rel),
  Goal =.. [Rel,SVsOut,TagOut,FSatFeat],
  compile_desc(Desc,FSatFeat,GoalsMid,GoalsRest,CBSafe,VarsIn,
               VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc((Desc1,Desc2),Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !, compile_desc(Desc1,Tag,SVs,Goals,GoalsMid,CBSafe,VarsIn,
                  VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_desc(Desc2,Tag,SVs,GoalsMid,GoalsRest,CBSafe,VarsMid,
               VarsOut,FSPal,FSsMid,FSsOut,NVs).
compile_desc((Desc1;Desc2),Tag,SVs,
             [(Goals1Seq;Goals2Seq)|GoalsRest],GoalsRest,_,VarsIn,VarsOut,FSPal,
             FSsIn,FSsOut,NVs):-
  !, compile_desc(Desc1,Tag,SVs,Goals1,[],false,VarsIn,VarsDisj1,FSPal,
                  FSsIn,FSsDisj1,NVs),
  compile_desc(Desc2,Tag,SVs,Goals2,[],false,VarsIn,VarsDisj2,FSPal,
               FSsIn,FSsDisj2,NVs),
  goal_list_to_seq(Goals1,Goals1Seq),
  goal_list_to_seq(Goals2,Goals2Seq),
  vars_merge(VarsDisj1,VarsDisj2,VarsOut),
  fss_merge(FSsDisj1,FSsDisj2,FSsOut).
compile_desc(@ MacroName,Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  !,
  ( (MacroName macro Desc) -> true
  ; error_msg((nl,write_list([undefined,macro,MacroName,used,in,description]),ttynl))
  ),   % we used to backtrack on macro definitions here - bad move
  compile_desc(Desc,Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
               VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_desc(a_ X,Tag,SVs,
             [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsRest],GoalsRest,_,Vars,
             Vars,_,FSs,FSs,_) :-
  !, Goal =.. ['add_to_type_a_',SVsOut,TagOut,X].
compile_desc(FunDesc,Tag,SVs,Goals,GoalsRest,CBSafe,VarsIn,
             VarsOut,FSPal,FSsIn,FSsOut,NVs):-
  functor(FunDesc,Functor,FunArity),
  findall(ResArg,clause(fun_spec(Functor,FunArity,ResArg),true),ResArgs), % could have more than one of these
  ResArgs = [RA1|RAsRest],                            % - that introduces ambiguity as to which arg is result.
  !,FunDesc =.. [_|FunDescArgs],
  name(Functor,FunName),
  append("fs_",FunName,RelName),
  name(Rel,RelName),
  compile_descs_fresh(FunDescArgs,FunArgs,Goals,[FS=Tag-SVs,Goal|GoalsRest],CBSafe,VarsIn,VarsOut,
                      FSPal,FSsIn,FSsOut,NVs),
  compile_funs(RAsRest,RA1,Rel,FS,FunArgs,FunArity,Goal).
compile_desc(Type,Tag,SVs,
             [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsRest],GoalsRest,_,Vars,
             Vars,_,FSs,FSs,_):-
  ( type(Type) -> true
  ; error_msg((nl,write_list([undefined,type,Type,used,in,description]),ttynl))
  ),
  cat_atoms('add_to_type_',Type,AddtotypeType),
  Goal =.. [AddtotypeType,SVsOut,TagOut].

% ------------------------------------------------------------------------------
% desc_varfs_body(+GoalDesc,-DescVars)
% ------------------------------------------------------------------------------
% DescVars is the set of ALE description variables in GoalDesc.
% ------------------------------------------------------------------------------

desc_varfs_body(GD,SortedDVs,SortedDFSs,OuterNVs) :-
  desc_varfs_body(GD,[],DVs,[],DFSs,[],OuterNVs),
  sort(DVs,SortedDVs),
  sort(DFSs,SortedDFSs).
desc_varfs_body((GD1,GD2),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_body(GD1,DVsIn,DVsMid,DFSsIn,DFSsOut,NVs,OuterNVs),
  desc_varfs_body(GD2,DVsMid,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).
desc_varfs_body((GD1;GD2),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_body(GD1,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_body(GD2,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_body((IfD -> ThenD ; ElseD),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_body(IfD,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_body(ThenD,DVsMid,DVsMid2,DFSsMid,DFSsMid2,NVs,OuterNVs),
  desc_varfs_body(ElseD,DVsMid2,DVsOut,DFSsMid2,DFSsOut,NVs,OuterNVs).
desc_varfs_body(\+ GD,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_body(GD,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).
desc_varfs_body(D1 =@ D2,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_desc(D1,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_desc(D2,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_body(true,DVs,DVs,DFSs,DFSs,_,_) :- !.
desc_varfs_body(fail,DVs,DVs,DFSs,DFSs,_,_) :- !.
desc_varfs_body(!,DVs,DVs,DFSs,DFSs,_,_) :- !.
desc_varfs_body((IfD -> ThenD),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_body(IfD,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_body(ThenD,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_body(prolog(_),DVs,DVs,DFSs,DFSs,_,_) :- !. % skip hooks - they might not be
                                                       %  ALE desc vars
desc_varfs_body(prolog(_,_),DVs,DVs,DFSs,DFSs,_,_) :- !. % skip hooks - they might not be
                                                       %  ALE desc vars
desc_varfs_body(when(Cond,Body),DVsIn,DVsOut,DFSsIn,DFSsOut,NVsIn,OuterNVs) :-
  !,desc_varfs_cond(Cond,DVsIn,DVsMid,DFSsIn,DFSsMid,NVsIn,NVsBody,OuterNVs),
  desc_varfs_body(Body,DVsMid,DVsOut,DFSsMid,DFSsOut,NVsBody,OuterNVs).
desc_varfs_body(AGD,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  AGD =.. [_|ArgDescs],
  desc_varfs_desc_list(ArgDescs,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).

desc_varfs_desc_list([],DVs,DVs,DFSs,DFSs,_,_).
desc_varfs_desc_list([D|DList],DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  desc_varfs_desc(D,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_desc_list(DList,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).

desc_varfs_desc(X,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  var(X),
  !, DFSsOut = DFSsIn,
     ( member_eq(X,NVs) -> DVsOut = DVsIn  % ignore variables with narrower scope - if
                                           %  they appear outside when/2, they refer to
                                           %  something else
     ; get_assoc(X,OuterNVs,seen(FreshVar)) -> DVsOut = [FreshVar|DVsIn] % but if we are in
                                           % that scope, then map to its fresh name
     ; DVsOut = [X|DVsIn]
     ).
desc_varfs_desc(FS,DVs,DVs,DFSsIn,[FS|DFSsIn],_,_) :-
  functor(FS,-,2),!.
desc_varfs_desc([],DVs,DVs,DFSs,DFSs,_,_) :- !.
desc_varfs_desc([H|T],DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_desc(H,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_desc(T,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_desc(_ == _,DVs,DVs,DFSs,DFSs,_,_) :- !.
desc_varfs_desc(=\= Desc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_desc(Desc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).
desc_varfs_desc(_:Desc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_desc(Desc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).
desc_varfs_desc((D1,D2),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_desc(D1,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_desc(D2,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_desc((D1;D2),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,desc_varfs_desc(D1,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_desc(D2,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_desc(@ MacroName,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  !,(MacroName macro Desc),
  desc_varfs_desc(Desc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).
desc_varfs_desc(a_ _,DVs,DVs,DFSs,DFSs,_,_) :- !.
desc_varfs_desc(FunDesc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  functor(FunDesc,Functor,FunArity),
  clause(fun_spec(Functor,FunArity,_),true),
  !, FunDesc =.. [_|ArgDescs],
  desc_varfs_desc_list(ArgDescs,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).
desc_varfs_desc(_Type,DVs,DVs,DFSs,DFSs,_,_).

desc_varfs_cond(X^Cond,DVsIn,DVsOut,DFSsIn,DFSsOut,NVsIn,NVsOut,OuterNVs) :-
  !,desc_varfs_cond(Cond,DVsIn,DVsOut,DFSsIn,DFSsOut,[X|NVsIn],NVsOut,OuterNVs).
desc_varfs_cond(Cond,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,NVs,OuterNVs) :-
  desc_varfs_cond0(Cond,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs).

desc_varfs_cond0((C1,C2),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  desc_varfs_cond0(C1,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_cond0(C2,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_cond0((C1;C2),DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  desc_varfs_cond0(C1,DVsIn,DVsMid,DFSsIn,DFSsMid,NVs,OuterNVs),
  desc_varfs_cond0(C2,DVsMid,DVsOut,DFSsMid,DFSsOut,NVs,OuterNVs).
desc_varfs_cond0(FS=Desc,DVsIn,DVsOut,DFSsIn,DFSsOut,NVs,OuterNVs) :-
  desc_varfs_desc(Desc,DVsIn,DVsMid,DFSsIn,DFSsOut,NVs,OuterNVs),
  ( member_eq(FS,NVs)
  -> error_msg((nl,write('narrowly quantified variable used on LHS of delay:' ),
write(FS=Desc),nl))
  ; get_assoc(FS,OuterNVs,seen(FreshVar)) -> DVsOut = [FreshVar|DVsMid]
  ; DVsOut = [FS|DVsMid]
  ).

map_vars([],[],_).
map_vars([V|Vs],[NV|NVs],Assoc) :-
    get_assoc(V,Assoc,seen(NV)) -> map_vars(Vs,NVs,Assoc)
  ; NV = V, map_vars(Vs,NVs,Assoc).

nv_fresh(unseen,seen(_)).
nv_fresh(seen(Var),seen(Var)).

nv_replace_desc(X,NX,Args,ArgsRest,NVs) :-
  var(X),
  !, ( get_assoc(X,NVs,seen(NX)) -> true
     ; NX = X),
     ( var(NX) -> NX=Tag-bot, Args = [Tag-bot|ArgsRest]
     ; Args = [NX|ArgsRest]).
nv_replace_desc(FS,NFS,Args,ArgsRest,NVs) :-
  functor(FS,-,2),
  !, ( get_assoc(FS,NVs,seen(NFS)) -> true
     ; NFS = FS),
     ( var(NFS) -> NFS=Tag-bot, Args = [Tag-bot|ArgsRest]
     ; Args = [NFS|ArgsRest]).
nv_replace_desc([],[],Args,Args,_) :- !.
nv_replace_desc([H|T],[NH|NT],Args,ArgsRest,NVs) :-
  !,nv_replace_desc(H,NH,Args,ArgsMid,NVs),
  nv_replace_desc(T,NT,ArgsMid,ArgsRest,NVs).
nv_replace_desc(P1==P2,P1==P2,Args,Args,_) :- !.
nv_replace_desc(=\= Desc,=\= NDesc,Args,ArgsRest,NVs) :-
  !,nv_replace_desc(Desc,NDesc,Args,ArgsRest,NVs).
nv_replace_desc(Feat:Desc,Feat:NDesc,Args,ArgsRest,NVs) :-
  !,nv_replace_desc(Desc,NDesc,Args,ArgsRest,NVs).
nv_replace_desc((D1,D2),(ND1,ND2),Args,ArgsRest,NVs) :-
  !,nv_replace_desc(D1,ND1,Args,ArgsMid,NVs),
  nv_replace_desc(D2,ND2,ArgsMid,ArgsRest,NVs).
nv_replace_desc((D1;D2),(ND1;ND2),Args,ArgsRest,NVs) :-
  !,nv_replace_desc(D1,ND1,Args,ArgsMid,NVs),
  nv_replace_desc(D2,ND2,ArgsMid,ArgsRest,NVs).
nv_replace_desc(@ Macro,@ NMacro,Args,ArgsRest,NVs) :-
  !, Macro =.. [Name|Descs],
  nv_replace_descs(Descs,NDescs,Args,ArgsRest,NVs),
  NMacro =.. [Name|NDescs].
nv_replace_desc(a_ X,a_ X,Args,Args,_) :- !.
nv_replace_desc(FunDesc,NF,Args,ArgsRest,NVs) :-
  functor(FunDesc,Functor,FunArity),
  clause(fun_spec(Functor,FunArity,_),true),
  !, FunDesc =.. [_|ArgDescs],
  nv_replace_descs(ArgDescs,NArgDescs,Args,ArgsRest,NVs),
  NF =.. [Functor|NArgDescs].
nv_replace_desc(Type,ND,Args,Args,_) :-
  type(Type) -> ND = Type
  ; error_msg((nl,write('undefined type '),write(Type),write('used in description'),nl)).


nv_replace_body((GD1,GD2),(NG1,NG2),Args,ArgsRest,NVs) :-
  !,nv_replace_body(GD1,NG1,Args,ArgsMid,NVs),
    nv_replace_body(GD2,NG2,ArgsMid,ArgsRest,NVs).
nv_replace_body((GD1;GD2),(NG1;NG2),Args,ArgsRest,NVs) :-
  !,nv_replace_body(GD1,NG1,Args,ArgsMid,NVs),
    nv_replace_body(GD2,NG2,ArgsMid,ArgsRest,NVs).
nv_replace_body((G1 -> G2 ; G3),(NG1 -> NG2 ; NG3),Args,ArgsRest,NVs) :-
  !,nv_replace_body(G1,NG1,Args,ArgsMid,NVs),
  nv_replace_body(G2,NG2,ArgsMid,ArgsMid2,NVs),
  nv_replace_body(G3,NG3,ArgsMid2,ArgsRest,NVs).
nv_replace_body((G1 -> G2),(NG1 -> NG2),Args,ArgsRest,NVs) :-
  !,nv_replace_body(G1,NG1,Args,ArgsMid,NVs),
  nv_replace_body(G2,NG2,ArgsMid,ArgsRest,NVs).
nv_replace_body((\+ G1),(\+ NG1),Args,ArgsRest,NVs) :-
  !,nv_replace_body(G1,NG1,Args,ArgsRest,NVs).
nv_replace_body(prolog(Hook),prolog(Hook),Args,Args,_) :-
  !.
nv_replace_body(prolog(NVs,Hook),prolog(NVs,Hook),Args,Args,_) :-
  !.
nv_replace_body(when(Cond,Body),when(NCond,NBody),Args,ArgsRest,NVs) :-
  !, nv_replace_cond(Cond,NCond,Args,ArgsMid,NVs,NewNVs),
  nv_replace_body(Body,NBody,ArgsMid,ArgsRest,NewNVs).
nv_replace_body(AtGoal,NAtGoal,FSs,FSsRest,NVs) :-  % also handles =@,true,false,!,=
  AtGoal =.. [Rel|Args],
  nv_replace_descs(Args,NArgs,FSs,FSsRest,NVs),
  NAtGoal =.. [Rel|NArgs].

nv_replace_cond(X^(Cond),FreshVar^(NCond),Args,ArgsRest,NVs,NewNVs) :-
  !, put_assoc(X,NVs,seen(FreshVar),NVsMid),
  nv_replace_cond(Cond,NCond,Args,ArgsRest,NVsMid,NewNVs).
nv_replace_cond(Cond,NCond,Args,ArgsRest,NVs,NVs) :-
  nv_replace_cond0(Cond,NCond,Args,ArgsRest,NVs).

nv_replace_cond0((C1,C2),(NC1,NC2),Args,ArgsRest,NVs) :-
  nv_replace_cond0(C1,NC1,Args,ArgsMid,NVs),
  nv_replace_cond0(C2,NC2,ArgsMid,ArgsRest,NVs).
nv_replace_cond0((C1;C2),(NC1;NC2),Args,ArgsRest,NVs) :-
  nv_replace_cond0(C1,NC1,Args,ArgsMid,NVs),
  nv_replace_cond0(C2,NC2,ArgsMid,ArgsRest,NVs).
nv_replace_cond0(FS=Desc,FS=NDesc,Args,ArgsRest,NVs) :-
  (var(FS) -> ArgsMid = Args ; Args = [FS|ArgsMid]),
  nv_replace_desc(Desc,NDesc,ArgsMid,ArgsRest,NVs).

nv_replace_descs([],[],Args,Args,_).
nv_replace_descs([D|Ds],[ND|NDs],Args,ArgsRest,NVs) :-
  nv_replace_desc(D,ND,Args,ArgsMid,NVs),
  nv_replace_descs(Ds,NDs,ArgsMid,ArgsRest,NVs).

%nv_replace_hook(Hook,NHook,NVs) :-
%  empty_assoc(VisIn),
%  nv_replace_hook(Hook,NHook,NVs,VisIn,_).

%nv_replace_hook(Hook,NHook,NVs,VisIn,VisOut) :-
%    get_assoc(Hook,VisIn,NHook) -> VisOut = VisIn
%  ; var(Hook) -> NHook = Hook,
%                 put_assoc(Hook,VisIn,NHook,VisOut)
%  ; put_assoc(Hook,VisIn,NHook,VisMid),
%    functor(Hook,Functor,N),
%    functor(NHook,Functor,N),
%    nv_replace_args(0,N,Hook,NHook,NVs,VisMid,VisOut).

%nv_replace_args(N,N,_,_,_,Vis,Vis) :- !.
%nv_replace_args(I,N,Hook,NHook,NVs,VisIn,VisOut) :-
%  NewI is I + 1,
%  arg(NewI,Hook,Arg),
%  arg(NewI,NHook,NArg),
%  ( get_assoc(Arg,NVs,seen(NArg)) -> VisMid = VisIn
%  ; nv_replace_hook(Arg,NArg,NVs,VisIn,VisMid)
%  ),
%  nv_replace_args(NewI,N,Hook,NHook,NVs,VisMid,VisOut).

nv_replace_goals(gdone).
nv_replace_goals(goal(GoalDesc,Goal,Args,ArgsRest,GoalsRest)) :-
  empty_assoc(NVs),
  nv_replace_body(GoalDesc,Goal,Args,ArgsRest,NVs),
  nv_replace_goals(GoalsRest).

replace_hook_fss(Goal,DFSs,PGoal,PGoals,PGoalsRest,FSPal,FSsIn,FSsOut) :-
  functor(Goal,Fun,N),
  functor(PGoal,Fun,N),
  replace_hook_fss_act(0,N,Goal,DFSs,PGoal,PGoals,PGoalsRest,FSPal,FSsIn,FSsOut).

replace_hook_fss_act(N,N,_,_,_,PGoals,PGoals,_,FSs,FSs) :- !.
replace_hook_fss_act(I,N,Goal,DFSs,PGoal,PGoals,PGoalsRest,FSPal,FSsIn,FSsOut) :-
  NewI is I + 1,
  arg(NewI,Goal,A),
  arg(NewI,PGoal,PA),
  ( var(A) -> PA=A, PGoalsMid = PGoals, FSsMid = FSsIn
  ; atomic(A) -> PA=A, PGoalsMid = PGoals, FSsMid = FSsIn
  ; deref(A,Tag,SVs) ->  % does it look like a FS?
      ( find_fs_seen(FSsIn,Tag,PA) -> PGoalsMid = PGoals, FSsMid = FSsIn
      ; find_fs_tricky(FSsIn,Tag,PA,PalArg,FSsMid)  % have we seen it before?
        -> PGoals = [(var(PA) -> arg(PalArg,FSPal,PA) ; true)|PGoalsMid]
      ; member_eq(A,DFSs) -> FSsMid = [seen(Tag,SVs,PA,PalArg)|FSsIn], % will we see
                     PGoals = [arg(PalArg,FSPal,PA)|PGoalsMid] % it later?
      ; replace_hook_fss(A,DFSs,PA,PGoals,PGoalsMid,FSPal,FSsIn,FSsMid)
      )    % otherwise, break it down - maybe we will recognise a substructure
  ; replace_hook_fss(A,DFSs,PA,PGoals,PGoalsMid,FSPal,FSsIn,FSsMid)
  ),
  replace_hook_fss_act(NewI,N,Goal,DFSs,PGoal,PGoalsMid,PGoalsRest,FSPal,FSsMid,FSsOut).

% ------------------------------------------------------------------------------
% vars_merge(+Vars1:avl,+Vars2:avl,-VarsMerge:avl)
% ------------------------------------------------------------------------------
% Given two AVL's of variables marked tricky or seen, produce a new AVL whose
% domain is the union of the two inputs, and whose values are defined as
% follows:
%
% Vs1/Vs2  |  -       tricky    seen
% ------------------------------------
% -        |  -       tricky    tricky
% tricky   |  tricky  tricky    tricky
% seen     |  tricky  tricky    seen
%
% Tricky variables are those that we cannot guarantee we will have seen and
% cannot guarantee that we will have not seen by the execution of the next
% item added to the Goal list.
% ------------------------------------------------------------------------------
vars_merge(Vars1,Vars2,VarsMerge) :-
  assoc_to_list(Vars1,VarsList1),
  assoc_to_list(Vars2,VarsList2),
  vars_merge_list(VarsList1,VarsList2,VarsListMerge),
  ord_list_to_assoc(VarsListMerge,VarsMerge).

vars_merge_list([],VarsList,VarsList).
vars_merge_list([Var1-Seen1|VarsList1],VarsList2,VarsListMerge) :-
  vars_merge_nelist(VarsList2,Var1,Seen1,VarsList1,VarsListMerge).

vars_merge_nelist([],Var1,Seen1,VarsList1,[Var1-Seen1|VarsList1]).
vars_merge_nelist([Var2-Seen2|VarsList2],Var1,Seen1,VarsList1,VarsListMerge) :-
  compare(Comp,Var1,Var2),
  vars_merge_nelist_act(Comp,Var1,Seen1,Var2,Seen2,VarsList1,VarsList2,
                        VarsListMerge).

vars_merge_nelist_act(=,VarMerge,Seen1,_VarMerge,Seen2,VarsList1,VarsList2,
                      [VarMerge-SeenMerge|VarsListMerge]) :-
  ( Seen1==seen,Seen2==seen -> SeenMerge = seen
  ; SeenMerge = tricky
  ),
  vars_merge_list(VarsList1,VarsList2,VarsListMerge).

vars_merge_nelist_act(<,Var1,_,Var2,Seen2,VarsList1,VarsList2,
                      [Var1-tricky|VarsListMerge]) :-
  vars_merge_nelist(VarsList1,Var2,Seen2,VarsList2,VarsListMerge).
vars_merge_nelist_act(>,Var1,Seen1,Var2,_,VarsList1,VarsList2,
                      [Var2-tricky|VarsListMerge]) :-
  vars_merge_nelist(VarsList2,Var1,Seen1,VarsList1,VarsListMerge).

% ------------------------------------------------------------------------------
% tricky_vars_merge(+HookVarsList:vars,+VarsIn:avl,-VarsMerge:avl)
% ------------------------------------------------------------------------------
% Adds hook variables to AVL of seen/tricky variables.  Since we can only
%  assume that the user leaves a var. unbound or bound to a legitimate FS,
%  it works as follows:
%
%  Hookvar was: -      ---> tricky
%               tricky ---> tricky
%               seen   ---> seen
% ------------------------------------------------------------------------------
tricky_vars_merge([],Vars,Vars).
tricky_vars_merge([HVar|HookVarsList],VarsIn,VarsMerge) :-
   get_assoc(HVar,VarsIn,_Seen)   % if it is there at all, leave it unchanged
   -> tricky_vars_merge(HookVarsList,VarsIn,VarsMerge)
    ; put_assoc(HVar,VarsIn,tricky,VarsMid),   % otherwise, add it as tricky
      tricky_vars_merge(HookVarsList,VarsMid,VarsMerge).

tricky_fss_merge(DFSs,FSsIn,FSsOut) :-
  key_fss(FSsIn,KFSsIn),
  deref_list(DFSs,DFSsOut),
  keysort(KFSsIn,SortedKFSsIn),
  keysort(DFSsOut,SortedDFSs),
  tricky_kfss_merge(SortedDFSs,SortedKFSsIn,KFSsOut),
  dekey_list(KFSsOut,FSsOut).

tricky_kfss_merge([],KFSs,KFSs).
tricky_kfss_merge([Tag-SVs|DFSs],KFSsIn,KFSsOut) :-
  tricky_kfss_merge(KFSsIn,Tag,SVs,DFSs,KFSsOut).

tricky_kfss_merge([],Tag,SVs,DFSs,KFSsOut) :-
  tricky_kfss_flush(DFSs,Tag,SVs,KFSsOut).
tricky_kfss_merge([KTag-KEntry|KFSs],Tag,SVs,DFSs,KFSsOut) :-
  compare(Comp,KTag,Tag),
  tricky_kfss_merge_act(Comp,KTag,KEntry,Tag,SVs,KFSs,DFSs,KFSsOut).

tricky_kfss_merge_act(=,KTag,KEntry,_KTag,_,KFSs,DFSs,KFSsOut) :-
  DFSs = [Tag-SVs|DFSsRest]  % DFSs may have duplicates because the same FS could
  -> compare(Comp,KTag,Tag), %  have appeared with different degrees of referencing
     tricky_kfss_merge_act(Comp,KTag,KEntry,Tag,SVs,KFSs,DFSsRest,KFSsOut)
   ; % DFSs == []            %  (and keysort doesn't eliminate duplicates)
     KFSsOut = KFSs.
tricky_kfss_merge_act(<,KTag,KEntry,Tag,SVs,KFSs,DFSs,[KTag-KEntry|KFSsOut]) :-
  tricky_kfss_merge(KFSs,Tag,SVs,DFSs,KFSsOut).
tricky_kfss_merge_act(>,KTag,KEntry,Tag,SVs,KFSs,DFSs,
      [Tag-tricky(Tag,SVs,_,_)|KFSsOut]) :-
  DFSs = [Tag2-SVs2|DFSsRest]
  -> compare(Comp,KTag,Tag2),
     tricky_kfss_merge_act(Comp,KTag,KEntry,Tag2,SVs2,KFSs,DFSsRest,KFSsOut)
   ; % DFSs == []
     KFSsOut = KFSs.

tricky_kfss_flush([],Tag,SVs,[Tag-tricky(Tag,SVs,_,_)]).
tricky_kfss_flush([Tag2-SVs2|DFSs],Tag,SVs,KFSsOut) :-
  Tag == Tag2
  -> tricky_kfss_flush(DFSs,Tag,SVs,KFSsOut)
   ; KFSsOut = [Tag-tricky(Tag,SVs,_,_)|KFSsRest],
     tricky_kfss_flush(DFSs,Tag2,SVs2,KFSsRest).

% ------------------------------------------------------------------------------
% find_fs(+FSsIn:fss,+Tag:tag,+SVs:svs,-Goals:goals,-GoalsRest:goals,
%         -FSVar:var,+FSPal:var,-FSsOut:fss)
% ------------------------------------------------------------------------------
% Determine whether Tag-SVs has been seen before, or may have been seen before
% (tricky) in the current execution path.  If it was seen, use the same
% variable for it as before.  If it was not seen, add it to the register of
% FSs, FSsOut, and add an arg/3 call to the execution path that binds its
% variable to an argument of the FS palette (which argument will be determined
% by build_fs_palette/4).
% ------------------------------------------------------------------------------
find_fs(FSsIn,Tag,_,Goals,GoalsRest,FSVar,_,FSsOut) :-
  find_fs_seen(FSsIn,Tag,FSVar),
  !, FSsOut = FSsIn, GoalsRest = Goals.
find_fs(FSsIn,Tag,_,Goals,GoalsRest,FSVar,FSPal,FSsOut) :-
  find_fs_tricky(FSsIn,Tag,FSVar,Arg,FSsOut),
  !, Goals = [(var(FSVar) -> arg(Arg,FSPal,FSVar) ; true)|GoalsRest].
find_fs(FSsIn,Tag,SVs,[arg(Arg,FSPal,FSVar)|GoalsRest],GoalsRest,FSVar,FSPal,
        [seen(Tag,SVs,FSVar,Arg)|FSsIn]).

find_fs_seen(FSs,Tag,FSVar) :-
  FSs = [FSFirst|FSsRest],
  ( FSFirst = seen(SeenTag,_,STVar,_)
  -> ( SeenTag == Tag -> FSVar = STVar
      ; find_fs_seen(FSsRest,Tag,FSVar)
     )
   ; find_fs_seen(FSsRest,Tag,FSVar)
  ).

find_fs_tricky(FSsIn,Tag,FSVar,Arg,FSsOut) :-
  FSsIn = [FSInFirst|FSsInRest],
  ( FSInFirst = tricky(TrickyTag,TrickySVs,TTVar,Arg)
  -> ( TrickyTag == Tag
     -> FSVar = TTVar,
        FSsOut = [seen(TrickyTag,TrickySVs,TTVar,Arg)|FSsInRest]
      ; FSsOut = [FSInFirst|FSsOutRest],
        find_fs_tricky(FSsInRest,Tag,FSVar,Arg,FSsOutRest)
     )
   ; FSsOut = [FSInFirst|FSsOutRest],
     find_fs_tricky(FSsInRest,Tag,FSVar,Arg,FSsOutRest)
  ).

% ------------------------------------------------------------------------------
% build_fs_palette(+FSs:fss,+FSPal:var,-Goals:goals,+GoalsRest:goals,
%                  +Iqs:ineqs)
% ------------------------------------------------------------------------------
% The FS-palette is a collection of instantiated feature structures that occur
%  in compiled code as a result of EFD-closure in the parser compiler, or
%  lexical rule closure in the generator compiler.  These are asserted into
%  the internal database and reloaded at run-time at the neck of every FS-
%  bearing rule in order to improve compile-time efficiency, and reduce copying
%  of structure in the compiled code.
% Building the FS-palette involves determining which argument position each
%  FS occurs in (this position is linked to the arg/3 call in the code that
%  binds a variable to its FS), and adding extra tags to the palette and
%  arg/3 calls at the neck to ensure that structure-sharing with tags in
%  inequations is not lost.
% ------------------------------------------------------------------------------
build_fs_palette([],_,Goals,Goals,_).
build_fs_palette([SeenorTricky|FSs],FSPal,[instance(Ref,Inst),
                                           arg(1,Inst,FSPal)|GoalsRest],
                 GoalsRest,Source) :-
  build_fs_palette_args(FSs,SeenorTricky,1,_,PalArgs,[]),
%  build_fs_palette_iqs(Iqs,SeenorTricky,FSs,ArgNum,FSPal,PalArgsRest,GoalsMid,
%                       GoalsRest,[]),
  AssertedFSPal =.. [fspal|PalArgs],
  assert(AssertedFSPal,Ref),
  assert(fspal_ref(Source,Ref)).

build_fs_palette_args([],SeenorTricky,ArgIn,ArgOut,[Tag-SVs|Rest],Rest) :-
  arg(1,SeenorTricky,Tag),
  arg(2,SeenorTricky,SVs),
  arg(4,SeenorTricky,ArgIn),
  ArgOut is ArgIn + 1.
build_fs_palette_args([SeenorTricky2|FSs],SeenorTricky,ArgIn,ArgOut,
                      [Tag-SVs|PalArgs],Rest) :-
  arg(1,SeenorTricky,Tag),
  arg(2,SeenorTricky,SVs),
  arg(4,SeenorTricky,ArgIn),
  NewArg is ArgIn + 1,
  build_fs_palette_args(FSs,SeenorTricky2,NewArg,ArgOut,PalArgs,Rest).

%build_fs_palette_iqs([],_,_,_,_,[],Goals,Goals,_).
%build_fs_palette_iqs([Ineq|Iqs],SeenorTricky,FSs,ArgIn,FSPal,PalArgs,Goals,
%                     GoalsRest,TagsIn) :-
%  build_fs_palette_ineq(Ineq,SeenorTricky,FSs,ArgIn,ArgOut,FSPal,PalArgs,
%                        PalArgsRest,Goals,GoalsMid,TagsIn,TagsOut),
%  build_fs_palette_iqs(Iqs,SeenorTricky,FSs,ArgOut,FSPal,PalArgsRest,GoalsMid,
%                       GoalsRest,TagsOut).

%build_fs_palette_ineq(done,_,_,Arg,Arg,_,PalArgs,PalArgs,Goals,Goals,Tags,
%                      Tags).
%build_fs_palette_ineq(ineq(Tag1,_,Tag2,_,IneqRest),SeenorTricky,FSs,ArgIn,
%                      ArgOut,FSPal,PalArgs,PalArgsRest,Goals,GoalsRest,TagsIn,
%                      TagsOut) :-
%  ( member_eq(Tag1,TagsIn)
%  -> TagsMid = TagsIn, PalArgs = PalArgsMid,
%     Goals = GoalsMid, ArgNext = ArgIn
%   ; fspal_member_eq(FSs,SeenorTricky,Tag1)
%     -> TagsMid = [Tag1|TagsIn],
%        PalArgs = [Tag1|PalArgsMid],
%        Goals = [arg(ArgIn,FSPal,Tag1)|GoalsMid],
%        ArgNext is ArgIn + 1
%      ; TagsMid = TagsIn, PalArgs = PalArgsMid,
%        Goals = GoalsMid, ArgNext = ArgIn
%  ),
%  ( member_eq(Tag2,TagsMid)
%  -> TagsMid2 = TagsMid, PalArgsMid = PalArgsMid2,
%     GoalsMid = GoalsMid2, ArgNext2 = ArgNext
%   ; fspal_member_eq(FSs,SeenorTricky,Tag2)
%     -> TagsMid2 = [Tag2|TagsMid],
%        PalArgsMid = [Tag2|PalArgsMid2],
%        GoalsMid = [arg(ArgNext,FSPal,Tag2)|GoalsMid2],
%        ArgNext2 is ArgNext + 1
%      ; TagsMid2 = TagsMid, PalArgsMid = PalArgsMid2,
%        GoalsMid = GoalsMid2, ArgNext2 = ArgNext
%  ),
%  build_fs_palette_ineq(IneqRest,SeenorTricky,FSs,ArgNext2,ArgOut,FSPal,
%                        PalArgsMid2,PalArgsRest,GoalsMid2,GoalsRest,TagsMid2,
%                        TagsOut).

%fspal_member_eq([],SeenorTricky,Tag2) :-
%   arg(1,SeenorTricky,Tag1),
%   Tag1 == Tag2
% ; arg(2,SeenorTricky,SVs),
%   term_variables(SVs,Tags),
%   member_eq(Tag2,Tags).
%fspal_member_eq([SeenorTricky2|FSs],SeenorTricky,Tag2) :-
%   arg(1,SeenorTricky,Tag1),
%   Tag1 == Tag2
% ; arg(2,SeenorTricky,SVs),
%   term_variables(SVs,Tags),
%   member_eq(Tag2,Tags)
% ; fspal_member_eq(FSs,SeenorTricky2,Tag2).

% ------------------------------------------------------------------------------
% fss_merge(+FSs1:fss,+FSs2:fss,-MergedFSs:fss)
% ------------------------------------------------------------------------------
% Merge two lists of seen/tricky FSs (used to build FS-palette).
% ------------------------------------------------------------------------------
fss_merge(FSs1,FSs2,FSsMerge) :-
  key_fss(FSs1,KFSs1),
  key_fss(FSs2,KFSs2),
  keysort(KFSs1,SortedKFSs1),
  keysort(KFSs2,SortedKFSs2),
  kfss_merge(SortedKFSs1,SortedKFSs2,FSsMerge).

kfss_merge([],KFSs,FSsMerge) :-
  dekey_list(KFSs,FSsMerge).
kfss_merge([Tag1-Entry1|KFSs1],KFSs2,FSsMerge) :-
  kfss_merge_nelist(KFSs2,Tag1,Entry1,KFSs1,FSsMerge).

kfss_merge_nelist([],_Tag1,Entry1,KFSs1,[Entry1|FSs1]) :-
  dekey_list(KFSs1,FSs1).
kfss_merge_nelist([Tag2-Entry2|KFSs2],Tag1,Entry1,KFSs1,FSsMerge) :-
  compare(Comp,Tag1,Tag2),
  kfss_merge_nelist_act(Comp,Tag1,Entry1,Tag2,Entry2,KFSs1,KFSs2,FSsMerge).

kfss_merge_nelist_act(=,Tag,Entry1,_Tag,Entry2,KFSs1,KFSs2,[MergeEntry|FSsMerge]) :-
  arg(3,Entry1,Var),
  arg(3,Entry2,Var),  % unify FS variables in entries
  functor(Entry1,Kind1,_),
  functor(Entry2,Kind2,_),
  ( Kind1 == seen         % determine merged Kind according to table above
  -> ( Kind2 == seen
     -> MergeKind = seen
      ; % Kind2 == tricky,
        MergeKind = tricky
     )
   ; % Kind1 = tricky,
     MergeKind = tricky
  ),
  functor(MergeEntry,MergeKind,4),
  arg(1,MergeEntry,Tag),
  arg(3,MergeEntry,Var),
  arg(2,Entry1,SVs),
  arg(2,MergeEntry,SVs),
  arg(4,Entry1,PalArg),
  arg(4,MergeEntry,PalArg),
  kfss_merge(KFSs1,KFSs2,FSsMerge).
kfss_merge_nelist_act(<,Tag1,Entry1,Tag2,Entry2,KFSs1,KFSs2,
                      [MergeEntry|FSsMerge]) :-
  functor(MergeEntry,tricky,4),
  arg(1,MergeEntry,Tag1),
  arg(2,Entry1,SVs1),
  arg(2,MergeEntry,SVs1),
  arg(3,Entry1,Var1),
  arg(3,MergeEntry,Var1),
  arg(4,Entry1,PalArg),
  arg(4,MergeEntry,PalArg),
  kfss_merge_nelist(KFSs1,Tag2,Entry2,KFSs2,FSsMerge).
kfss_merge_nelist_act(>,Tag1,Entry1,Tag2,Entry2,KFSs1,KFSs2,
                      [MergeEntry|FSsMerge]) :-
  functor(MergeEntry,tricky,4),
  arg(1,MergeEntry,Tag2),
  arg(2,Entry2,SVs2),
  arg(2,MergeEntry,SVs2),
  arg(3,Entry2,Var2),
  arg(3,MergeEntry,Var2),
  arg(4,Entry2,PalArg),
  arg(4,MergeEntry,PalArg),
  kfss_merge_nelist(KFSs2,Tag1,Entry1,KFSs1,FSsMerge).

% ------------------------------------------------------------------------------
% key_fss(+FSs:fss,-KeyedFSs:fss)
% ------------------------------------------------------------------------------
% Key a list of FSs by their tags.
% ------------------------------------------------------------------------------
key_fss([],[]).
key_fss([FSEntry|FSs],[Tag-FSEntry|KFSs]) :-
  arg(1,FSEntry,Tag),
  key_fss(FSs,KFSs).

dekey_list([],[]).
dekey_list([_-FSEntry|KFSs],[FSEntry|FSsMerge]) :-
  dekey_list(KFSs,FSsMerge).

% ------------------------------------------------------------------------------
% compile_pathval(Path:path,FSIn:fs,FSOut:fs,
%                 IqsIn:ineqs,IqsOut:ineqs,
%                 Goals:goals, GoalsRest:goals)
% ------------------------------------------------------------------------------
% 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,Goals,Goals) :- !.
compile_pathval([Feat|Feats],FS,FSAtPath,
                [deref(FS,Tag,SVs),Goal|GoalsMid],GoalsRest):-
  !, ( approp(Feat,_,_) -> true
     ; error_msg((nl,write_list([undefined,feature,Feat,used,in,path,[Feat|Feats]]),ttynl))
     ),
  cat_atoms('featval_',Feat,Rel),
  Goal =.. [Rel,SVs,Tag,FSAtFeat],
  compile_pathval(Feats,FSAtFeat,FSAtPath,GoalsMid,GoalsRest).
compile_pathval(P,_,_,_,_,_,_) :-
  error_msg((nl,write('pathval: illegal path specified - '),
                write(P))).

% ------------------------------------------------------------------------------
% compile_pathval(Path:path,RefIn:ref,SVsIn:svs,FSOut:fs,
%                 IqsIn:ineqs,IqsOut:ineqs,
%                 Goals:goals, GoalsRest:goals)
% ------------------------------------------------------------------------------
% 6-place version of compile_pathval/5
% ------------------------------------------------------------------------------
compile_pathval([],Tag,SVs,Tag-SVs,Goals,Goals) :- !.
compile_pathval([Feat|Feats],Tag,SVs,FSAtPath,
                [deref(Tag,SVs,TagOut,SVsOut),Goal|GoalsMid],GoalsRest):-
  !, ( approp(Feat,_,_) -> true
     ; error_msg((nl,write_list([undefined,feature,Feat,used,in,path,[Feat|Feats]]),ttynl))
     ),
  cat_atoms('featval_',Feat,Rel),
  Goal =.. [Rel,SVsOut,TagOut,FSAtFeat],
  compile_pathval(Feats,FSAtFeat,FSAtPath,GoalsMid,GoalsRest).
compile_pathval(P,_,_,_,_,_) :-
  error_msg((nl,write('illegal path specified - '),
                write(P))).

% ------------------------------------------------------------------------------
% Functional Descriptions
% [User's Manual]
% compile_fun(Fun:fun,FS:fs,IqsIn:ineqs,IqsOut:ineqs,
%             Goals:goals,GoalsRest:goals,CBSafe:bool,VarsIn:vars,
%             VarsOut:vars,FSPal:var,FSsIn:fss,FSsOut:fss)
% ------------------------------------------------------------------------------
% Goals-RoalsRest is difference list of goals needed to determine that FS
%  satisfies functional constraint Fun
% ------------------------------------------------------------------------------
compile_funs([],ResArg,Rel,FS,FunArgs,FunArity,SpecGoal) :-
  compile_fun(ResArg,Rel,FS,FunArgs,FunArity,SpecGoal).
compile_funs([RA2|ResArgs],ResArg,Rel,FS,FunArgs,FunArity,(SpecGoal;GoalsRest)) :-
  compile_fun(ResArg,Rel,FS,FunArgs,FunArity,SpecGoal),
  compile_funs(ResArgs,RA2,Rel,FS,FunArgs,FunArity,GoalsRest).

compile_fun(ResArg,Rel,FS,FunArgs,FunArity,SpecGoal) :-
  PreLen is ResArg - 1, PostLen is FunArity - ResArg + 1,
  length(PreArgs,PreLen), length(PostArgs,PostLen),
  append(PreArgs,PostArgs,FunArgs),
%                    append(PostArgs,[IqsMid,IqsOut],PostRelArgs),
  append(PreArgs,[FS|PostArgs],RelArgs),
  SpecGoal =.. [Rel|RelArgs].

%compile_fun(FunDesc,FS,IqsIn,IqsOut,Goals,GoalsRest,CBSafe,VarsIn,VarsOut,FSPal,
%            FSsIn,FSsOut,NVs) :-
%  FunDesc =.. [Rel|ArgDescs],
%  compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,Goals,
%                      [deref(FS,Tag,SVs),
%                       fsolve(Fun,Tag,SVs,IqsMid,IqsOut)|GoalsRest],
%                      CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs),
%  Fun =.. [Rel|Args].

% ------------------------------------------------------------------------------
% compile_fun(Fun:fun,Ref:ref,SVs:svs,IqsIn:ineqs,IqsOut:ineqs,
%             Goals:goals,GoalsRest:goals,CBSafe:bool,VarsIn:vars,
%             VarsOut:vars,FSPal:var,FSsIn:fss,FSsOut:fss)
% ------------------------------------------------------------------------------
% 7-place version of compile_fun/6
% ------------------------------------------------------------------------------
%compile_fun(FunDesc,Tag,SVs,IqsIn,IqsOut,Goals,GoalsRest,CBSafe,VarsIn,
%            VarsOut,FSPal,FSsIn,FSsOut,NVs) :-
%  FunDesc =.. [Rel|ArgDescs],
%  compile_descs_fresh(ArgDescs,Args,IqsIn,IqsMid,Goals,
%                      [fsolve(Fun,Tag,SVs,IqsMid,IqsOut)|GoalsRest],
%                      CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs),
%  Fun =.. [Rel|Args].


% ------------------------------------------------------------------------------
% alex(+Exception)
% ------------------------------------------------------------------------------
% ALE exception handler
% ------------------------------------------------------------------------------
alex(Exception) :-
  format(user_error,'{ALE: ERROR: ',[]),
  ale_exception(Exception),
  format(user_error,'}~n~n',[]),
  flush_output(user_error), abort.

ale_exception(upward_closure(Feat,T,VRs)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
    format(user_error,'incompatible restrictions on feature ~a at type ~a: ~@',
           [Feat,T,write_term(user_error,VRs,Options)]).
ale_exception(no_lub(T1,T2,Mins)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
    format(user_error,'consistent ~a and ~a have multiple mgus: ~@',
           [T1,T2,write_term(Mins,Options)]).
ale_exception(subtype_cycle(T,Path)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
    format(user_error,'subtyping cycle at ~a: ~@',[T,write_term(user_error,Path,Options)]).
ale_exception(approp_cycle(T,Path)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
    format(user_error,'appropriateness cycle following path ~@ from type ~a',
           [write_term(user_error,Path,Options),T]).
ale_exception(sub_lhs_var(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,' illegal variable occurrence in ',[]),
  write_term(user_error,Clause,Options).
ale_exception(intro_lhs_var(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,' illegal variable occurrence in ',[]),
  write_term(user_error,Clause,Options).
ale_exception(sub_rhs_var(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,' illegal variable occurrence in ',[]),
  write_term(user_error,Clause,Options).
ale_exception(intro_rhs_var(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,' illegal variable occurrence in ',[]),
  write_term(user_error,Clause,Options).
ale_exception(intro_vr_var(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,' illegal variable occurrence in ',[]),
  write_term(user_error,Clause,Options).
ale_exception(ext_rhs_var(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,' illegal variable occurrence in ',[]),
  write_term(user_error,Clause,Options).
ale_exception(sub_lhs_abar) :-
  !,format(user_error,'subtype/feature specification given for a_/1 atom',[]).
ale_exception(intro_lhs_abar) :-
  !,format(user_error,'subtype/feature specification given for a_/1 atom',[]).
ale_exception(sub_lhs_other(Term)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Term,Options),
  format(user_error,' sub ... - user-defined types must be Prolog atoms',[]).
ale_exception(intro_lhs_other(Term)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Term,Options),
  format(user_error,' intro ... - user-defined types must be Prolog atoms',[]).
ale_exception(sub_rhs_other(LHS,Term)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,
         ' ~a sub [...~@...] - user-defined types must be Prolog atoms',
         [LHS,write_term(user_error,Term,Options)]).
ale_exception(ext_rhs_other(Term)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,
         ' ext [...~@...] - user-defined types must be Prolog atoms',
         [write_term(user_error,Term,Options)]).
ale_exception(sub_rhs_notlist(Clause,Term)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - expected list of types, found: ',[]),
  write_term(user_error,Term,Options).
ale_exception(ext_rhs_notlist(Clause,Term)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - expected list of types, found: ',[]),
  write_term(user_error,Term,Options).
ale_exception(cyclic_abar_restriction(F,R,Clause,ArgNo)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,'arg ~d: feature ~a has cyclic a_/1 atom ',[ArgNo,F]),
  write_term(user_error,R,Options),
  format(user_error,' as its value restriction',[]).
ale_exception(intro_rhs_notlist(Clause,Term)) :-
!,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - expected list of feature:value_restriction, found: ',
         []),
  write_term(user_error,Term,Options).
ale_exception(bot_feats(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - bot has appropriate features',[]).
ale_exception(bot_subsumed(S)) :-
  !,format(user_error,'~a subsumes bot',[S]).
ale_exception(bot_ext) :-
  !,format(user_error,'bot cannot be extensional',[]).
ale_exception(abar_subsumed(S)) :-
  !,format(user_error,'a_/1 atom declared subsumed by type ~a',[S]).
ale_exception(feat_notatom(F,Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - features must be Prolog atoms, found ',[]),
  write_term(user_error,F,Options).
ale_exception(vr_other(R,Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,
         ' - value restrictions must be Prolog atoms or a_/1 atoms, found ',
         []),
  write_term(user_error,R,Options).
ale_exception(fr_other(FR,Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - expected feature:value_restriction, found ',[]),
  write_term(user_error,FR,Options).
ale_exception(duplicate_sub(S)) :-
  !,format(user_error,'~a multiply defined',[S]).
ale_exception(duplicate_intro(S)) :-
  !,format(user_error,'multiple feature specifications for type ~a',[S]).
ale_exception(duplicate_vr(F,S)) :-
  !,format(user_error,'multiple specification for ~a in declaration of ~a',
           [F,S]).
ale_exception(duplicate_ext(AllEs)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,'multiple ext/1 declarations found: ~n',[]),
  ( member(Es,AllEs),
    format(user_error,'  ~@~n',[write_term(user_error,Es,Options)])
  ; true
  ).
ale_exception(no_stmatrix) :-
  !,format(user_error,
           'compiled code for sub/2 not found: run compile_sub_type/1 first',
           []).
ale_exception(ext_nomax(E)) :-
  !,format(user_error,'extensional type ~a is not maximal',[E]).
ale_exception(feat_intro(F,Mins)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
    format(user_error,'feature ~a multiply introduced at ~@',
           [F,write_term(user_error,Mins,Options)]).

ale_exception(no_lex) :-
  !,format(user_error,'no lexicon found: run compile_gram/1 first',[]).
ale_exception(unk_word(W)) :-
  !,format(user_error,'unknown word: ~a is not in the lexicon',[W]).
ale_exception(X) :-
  write(user_error,X).

ale_warning(no_types_defined) :-
  !,format(user_error,'no types defined',[]).
ale_warning(duplicate_types(S,Clause,ArgNo)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - arg ~d: ~a appears more than once',[ArgNo,S]).
ale_warning(duplicate_decl(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,' - declaration appears more than once',[]).
ale_warning(duplicate_feat(F,VR,T)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,'feature ~a declared on type ~a with value restriction ',
         [F,T]),
  write_term(user_error,VR,Options),
  format(user_error,' more than once',[]).
ale_warning(implicit_mins(ImplicitMins)) :-
  !,format(user_error,'assuming the following types are immediately subsumed by bot: ',[]),
  write_list(ImplicitMins,user_error).
ale_warning(implicit_maxs(ImplicitMaxs)) :-
  !,format(user_error,'assuming the following types are maximally specific: ',[]),
  write_list(ImplicitMaxs,user_error).
ale_warning(unary_branch(T,U)) :-
  !,format(user_error,'unary branch from ~a to ~a',[T,U]).
ale_warning(no_features) :-
  !,format(user_error,'no features declared',[]).
ale_warning(ground_abar_restriction(F,R,Clause,ArgNo)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,'arg ~d: feature ~a has ground a_/1 atom ',[ArgNo,F]),
  write_term(user_error,R,Options),
  format(user_error,' as its value restriction',[]).
ale_warning(abar_ext(Clause)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  write_term(user_error,Clause,Options),
  format(user_error,'all a_/1 atoms are automatically extensional',[]).
ale_warning(nontriv_upward_closure(F,T,V,R)) :-
  !,prolog_flag(toplevel_print_options,Options,Options),
  format(user_error,'non-trival upward closure of feature ~a at type ~a: ',[F,T]),
  format(user_error,' declared ~@, closed to ~@',[write_term(user_error,V,Options),
                                                  write_term(user_error,R,Options)]).
ale_warning(join_nopres(F,T1,T2)) :-
  !,format(user_error,'homomorphism condition fails for ~a in ~a and ~a',[F,T1,T2]).
ale_warning(X) :-
  write(user_error,X).


% ==============================================================================
% Compiler
% [User's Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% compile_gram(File:file)
% ------------------------------------------------------------------------------
% compiles grammar from File;  all commands set up same way, with optional
% argument for file, which is recompiled, if necessary
% ------------------------------------------------------------------------------

:- dynamic alec/1.
:- dynamic sub_rhstype/1, ext_or_intro_rhstype/1, extensional/1.
:- dynamic stmatrix_num/2, stmatrix_dim/1.
:- dynamic num_type/2, type_num/2.
:- dynamic lexicon_updating/0.
:- multifile user:term_expansion/2.
:- multifile alec_catch_hook/2.

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),
  (clause(ale_compiling(File),true) -> % current_stream(File,_,S),
                                    % seek(S,-1,current,_), % reset end_of_file
                                    alec_catch(Code)
  ; clause(ale_debugging,true) -> assertz(ale_debug(File)),
                                  fail % Code = end_of_file
  ).
%  ; (Code = end_of_file)).

term_expansion((WordStart ---> DescOrGoal),[(WordStart ---> DescOrGoal),
                                            (:- multifile (lex)/2),
                                            (:- dynamic (lex)/2)|Code]) :-
  lexicon_updating,
  ( var(DescOrGoal) -> Desc = DescOrGoal, GoalStart = true
  ; functor(DescOrGoal,goal,2) -> arg(1,DescOrGoal,Desc),
                                  arg(2,DescOrGoal,GoalStart)
  ; Desc = DescOrGoal, GoalStart = true
  ),
  secret_noadderrs,
  bagof((lex(Word,FS) :- Body),(lex_act(Word,FS,Goals,WordStart,Desc,GoalStart),
        goal_list_to_seq(Goals,Body)),Code),
  secret_adderrs.

%term_expansion((empty Desc),[(empty Desc),
%                             (:- multifile (empty_cat)/4),
%                             (:- dynamic (empty_cat)/4)|Code]) :-
%  lexicon_updating,
%  secret_noadderrs,
%  bagof(empty_cat(N,TagOut,SVsOut,IqsOut),
%        (add_to(Desc,Tag,bot,[],IqsIn),
%         gen_emptynum(N),
%         fully_deref_prune(Tag,bot,TagOut,SVsOut,IqsIn,IqsOut)),
%        Code),
%  secret_adderrs.

touch(File) :-
  file_exists(File,[read]) -> true
  ; open(File,write,S),
    close(S).

alec_catch(Code) :-
  retract(alec(Stage))
  -> on_exception(ale(Exception),alec_catch_hook(Stage,Code),alex(Exception))
   ; (Code = end_of_file).

%alec_catch_hook(subtype,[(:- discontiguous sub_type/2)|Code]) :-
%  !,multi_hash(1,(sub_type)/2,Code,[end_of_file]).
alec_catch_hook(unifytype,[(:- discontiguous unify_type/3)|Code]) :-
  !,multi_hash(1,(unify_type)/3,Code,[end_of_file]).
alec_catch_hook(approp,[(:- discontiguous approp/3)|Code]) :-
  !,multi_hash(1,(approp)/3,Code,[end_of_file]).
alec_catch_hook(approps,Code) :-
  multi_hash(0,(approps)/3,Code,[end_of_file]).
%alec_catch_hook(ext,Code) :-
%  !,compile_ext(Code,[end_of_file]).
alec_catch_hook(iso,Code) :-
  !,multi_hash(0,(iso_sub_seq)/3,Code,[end_of_file]).
alec_catch_hook(check,Code) :-
%  !,multi_hash(0,(check_sub_seq)/5,Code,CodeMid),
  multi_hash(0,(check_pre_traverse)/4,Code,CodeRest),
  multi_hash(0,(check_post_traverse)/3,CodeRest,[end_of_file]).
%alec_catch_hook(fun,Code) :-
%  !,compile_fun(Code,[end_of_file]).
%alec_catch_hook(fsolve,Code) :-
%  !,multi_hash(0,(fsolve)/5,Code,[end_of_file]).
alec_catch_hook(ct,Code) :-
  !,multi_hash(0,(ct)/4,Code,[end_of_file]).
%alec_catch_hook(mgsc,Code) :-
%  !,multi_hash(0,(mgsc)/4,Code,[end_of_file]).
alec_catch_hook(addtype,[(:- discontiguous add_to_type/3)|Code]) :-
  !,multi_hash(1,(add_to_type)/3,Code,[end_of_file]).
%alec_catch_hook(at3,Code) :-
%  !,compile_add_to_type3(Code,[end_of_file]).
alec_catch_hook(featval,[(:- discontiguous featval/4)|Code]) :-
  !,multi_hash(1,(featval)/4,Code,[end_of_file]).
%alec_catch_hook(fv4,Code) :-
%  !,compile_featval4(Code).
alec_catch_hook(u,[(:- discontiguous u/4)|Code]) :-
  !,multi_hash(1,(u)/4,Code,[end_of_file]).
alec_catch_hook(subsume,[(:- discontiguous subsume_type/13)|Code]) :-
  !,multi_hash(1,(subsume_type)/13,Code,[end_of_file]).
alec_catch_hook(dcs,Code) :-
  !,compile_dcs(Code,CodeRest),
  multi_hash(0,(when_approp)/3,CodeRest,[end_of_file]).
alec_catch_hook(lexrules,Code) :-
  !,multi_hash(0,(lex_rule)/8,Code,[end_of_file]).
alec_catch_hook(lex,Code) :-
  !,(lexicon_consult
     -> (Code = [(:- multifile (lex)/2),(:- dynamic (lex)/2)|CodeRest])
      ; (Code = CodeRest)),
  multi_hash(0,(lex)/2,CodeRest,[end_of_file]).
alec_catch_hook(empty,Code) :-
  !,%(lexicon_consult
    % -> (Code = [(:- multifile (empty_cat)/4),
    %             (:- dynamic (empty_cat)/4)|CodeRest])
    %  ; (Code = CodeRest)),
  multi_hash(0,(empty_cat)/6,Code,[end_of_file]).
alec_catch_hook(rules,Code) :-
  !,multi_hash(0,(rule)/6,Code,[end_of_file]).
alec_catch_hook(chain,Code) :-
  !,multi_hash(0,(chain_rule)/10,Code,[end_of_file]).
alec_catch_hook(chained,Code) :-
  !,multi_hash(0,(chained)/6,Code,[end_of_file]).
alec_catch_hook(nochain,Code) :-
  !,multi_hash(0,(non_chain_rule)/6,Code,[end_of_file]).
alec_catch_hook(generate,Code) :-
  !,multi_hash(0,(generate)/4,Code,[end_of_file]).
%alec_catch_hook(_,Code) :-
%  retract(ale_compiling(_)),
%  (Code = end_of_file).

compile_gram(File) :-
  abolish_preds,
  reconsult(File),
  compile_gram.

abolish_preds :-
  abolish((empty)/1), abolish((rule)/2), abolish((lex_rule)/2),
  abolish(('--->')/2), abolish((sub)/2),
  abolish((if)/2), abolish((macro)/2),
  abolish((ext)/1), abolish((cons)/2),
  abolish((intro)/2),
% 5/1/96 - Octav -- added abolish/2 calls for generation predicates
  abolish((semantics)/1),
  abolish(('+++>')/2), abolish((fun)/1).

compile_gram :-
  touch('.alec_throw'),
  absolute_file_name('.alec_throw',AbsFileName),
  retractall(ale_compiling(_)),
  assert(ale_compiling(AbsFileName)),
  compile_sig_act,
  compile_fun_act,
  compile_cons_act,
  compile_logic_act,
  compile_subsume_act,
  compile_dcs_act,
  compile_grammar_act,
  retract(ale_compiling(_)).

compile_sig(File):-
  abolish((sub)/2),abolish((ext)/1),
  abolish((intro)/2),
  reconsult(File),
  compile_sig.

compile_sig:-
  touch('.alec_throw'),
  absolute_file_name('.alec_throw',AbsFileName),
  retractall(ale_compiling(_)),
  assert(ale_compiling(AbsFileName)),
  compile_sig_act,
  retract(ale_compiling(_)).

compile_sig_act :-
  compile_sub_type_act(_,_,_,_), % (SortedSubIntros,SortedIntros,SortedExts,STMatrix),
  compile_approp_act, % (SortedSubIntros,SortedIntros,STMatrix),
  compile_extensional_act. % (SortedExts).

compile_sub_type(File):-
  abolish((sub)/2),abolish((intro)/2),
  reconsult(File),
  compile_sub_type.

compile_sub_type :-
  touch('.alec_throw'),
  absolute_file_name('.alec_throw',AbsFileName),
  retractall(ale_compiling(_)),
  assert(ale_compiling(AbsFileName)),
  compile_sub_type_act(_,_,_,_),
  retract(ale_compiling(_)).

compile_sub_type_act(SortedSubIntros,SortedIntros,SortedExts,STMatrix) :-
  alec_announce('Compiling type unification...'),
  abolish((unify_type)/3), retractall(sub_rhstype(_)),
  retractall(ext_or_intro_rhstype(_)), retractall(type_num(_,_)),
  retractall(num_type(_,_)), retractall(stmatrix_num(_,_)),
  retractall(stmatrix_dim(_)),
% PHASE 0:  1) Prolog hygiene,
%           2) check that bot and a_/1 atoms are not abused,
%           3) sort sub/intro/ext declarations, warn on RHS duplicates,
%              throw exception on LHS duplicates,
%           4) tabulate types on RHSs of sub/intro/ext declarations
  ((no_types_defined new_if_warning_else_fail
    (\+current_predicate(sub,_ sub _),
     \+current_predicate(intro,_ intro _))) -> MarkedSortedSubs = [],
                                               SortedIntros = []
  ; verify_sub_declarations(MarkedSortedSubs),
    verify_intro_declarations(SortedIntros)
  ),
  verify_ext_declaration(SortedExts),

% PHASE 1: 1) collect default minimal types (RHS of intro or ext or any LHS
%                                            but not RHS of sub),
%          2) collect default maximal types (LHS of intro or any RHS
%                                            but not LHS of sub),
%          3) build subsumption adjacency graph from sorted sub declarations,
%          4) warn on unary branches,
%          5) remove bot from subsumption graph - can be handled specially.
  strip_subs(MarkedSortedSubs,SortedSubLHSs,SortedSubs,SortedSubIntros),
  strip_keys(SortedIntros,SortedIntroLHSs),
  ord_union(SortedIntroLHSs,SortedSubLHSs,SortedLHSDefMins),
  esetof(Min,(clause(ext_or_intro_rhstype(Min),true),
              \+ clause(sub_rhstype(Min),true)),SortedRHSDefMins),
  ord_union(SortedLHSDefMins,SortedRHSDefMins,SortedDefMins),
  ( select(bot-DeclaredMins,SortedSubs,SortedMinSubs)
  -> ord_subtract(SortedDefMins,DeclaredMins,ImplicitMins)
  ; SortedMinSubs = SortedSubs,
    ImplicitMins = SortedDefMins
  ),
  ale(implicit_mins(ImplicitMins)) new_if_warning (ImplicitMins \== []),
  esetof(Max,defmax(Max),SortedDefMaxs),
  add_vertices(SortedMinSubs,SortedDefMaxs,SubGraph),
  ale(implicit_maxs(SortedDefMaxs)) new_if_warning (SortedDefMaxs \== []),

%
% [Reference Manual]
% PHASE 2: 1) topologically sort vertices of subsumption graph,
%          2) translate graph to topologically ordered numerical indices
%             and reflexively close (resulting graph is an upper-triangular
%             Boolean matrix),
%          3) transitively close graph, yielding subtype matrix,
%          4) extract and assert rows of subtype matrix.
  ( top_sort(SubGraph,TopSortedTypes) -> true
  ; member(T-Neibs,SubGraph),
    member(S,Neibs),
    min_path(S,T,SubGraph,Path,_),
    raise_exception(ale(subtype_cycle(T,[T|Path])))
  ),

  num_types(TopSortedTypes,1,DimPlus1),  % bot is number 0
  Dim is DimPlus1 - 1,
  seed_refl_close_zmatrix(SubGraph,Dim,SubMatrix),

  upper_tri_trans_close(Dim,SubMatrix,STMatrix),

  length(RowMatrix,Dim),
  rconvert_stm(STMatrix,RowMatrix,1,Dim,Dim),
  hash_stm_rows(RowMatrix,1),
  assert(stmatrix_dim(Dim)),

% PHASE 3: compile unify_type/3
  assert(alec(unifytype)),
  \+ \+ consult('.alec_throw').


verify_sub_declarations(MarkedSortedSubs) :-
  ( current_predicate(sub,_ sub _)
  -> findall(S-SubRHS,
     (S sub Ss,
     % Error checks invariant to structure of Ss:
      ( var(S) -> raise_exception(ale(sub_lhs_var(S sub Ss)))
      ; functor(S,a_,1) -> raise_exception(ale(sub_lhs_abar))
      ; atom(S) -> true
      ; raise_exception(ale(sub_lhs_other(S)))
      ),
     % Error checks for combined sub/intro declarations:
      ( Ss = (Ts intro FRs) ->
        ((S = bot, FRs \== []) -> raise_exception(ale(bot_feats(S sub Ss)))
        ; verify_subtype_list(Ts,S,(S sub Ss),2,SortedSs),
          verify_featrestr_list(FRs,(S sub Ss),3),
          SubRHS = intro(SortedSs,FRs)
        )
     % Error checks for simple sub declarations
      ; % Ss is list of types
        verify_subtype_list(Ss,S,(S sub Ss),2,SortedSs),
        SubRHS = SortedSs
      )
     ),MarkedSubs)
  ; MarkedSubs = []
  ),
  keysort(MarkedSubs,MarkedSortedSubs),      % sort, but dups are still there
  no_duplicates_ksorted(MarkedSortedSubs,
         dup(L1,_,R1,R2,A1,A2,
             ((functor(R1,intro,2) -> arg(1,R1,A1) ; A1 = R1),
              (functor(R2,intro,2) -> arg(1,R2,A2) ; A2 = R2)),
             duplicate_decl(sub(L1,R1)),
             ale(duplicate_sub(L1)))).

verify_intro_declarations(SortedIntros) :-
  ( current_predicate(intro,_ intro _) ->
    findall(S-FRs,
     (S intro FRs,
      ( var(S) -> raise_exception(ale(intro_lhs_var(S intro FRs)))
      ; functor(S,a_,1) -> raise_exception(ale(intro_lhs_abar))
      ; (S = bot, FRs \== []) ->
                       raise_exception(ale(bot_feats(S intro FRs)))
      ; atom(S) -> true
      ; raise_exception(ale(intro_lhs_other(S)))
      ),
      verify_featrestr_list(FRs,(S intro FRs),2)
     ),Intros)
  ; Intros = []
  ),
  keysort(Intros,SortedIntros).          % sort, but dups are still there

verify_ext_declaration(SortedExts) :-
  current_predicate(ext,ext(_))
  -> ( exactly_once(Es1,ext(Es1),AllEs,ale(duplicate_ext(AllEs)))
     -> verify_exttype_list(Es1,ext(Es1),1,SortedExts)
     ; true
     )
  ; SortedExts = [].

verify_subtype_list(Ss,LHS,Clause,ArgNo,SortedSs) :-
  is_list(Ss) ->
    sort_no_dups(Ss,SortedSs,Clause,ArgNo),
    ( member(T,SortedSs), % failure-drive through list to check arguments
      ( var(T) -> raise_exception(ale(sub_rhs_var(Clause)))
      ; (T = bot) -> raise_exception(ale(bot_subsumed(LHS)))
      ; functor(T,a_,1) -> raise_exception(ale(abar_subsumed(LHS)))
      ; atom(T) -> assert(sub_rhstype(T))
      ; raise_exception(ale(sub_rhs_other(LHS,T)))
      ),
      fail
    ; true
    )
  ; raise_exception(ale(sub_rhs_notlist(Clause,Ss))).

verify_exttype_list(Ss,Clause,ArgNo,SortedSs) :-
  is_list(Ss) ->
    sort_no_dups(Ss,SortedSs,Clause,ArgNo),
    ( member(T,SortedSs), % failure-drive through list to check arguments
      ( var(T) -> raise_exception(ale(ext_rhs_var(Clause)))
      ; (T == bot) -> raise_exception(ale(bot_ext))
      ; functor(T,a_,1) -> (abar_ext(Clause) warning)
      ; atom(T) ->  assert(ext_or_intro_rhstype(T))
      ; raise_exception(ale(ext_rhs_other(T)))
      ),
      fail
    ; true
    )
  ; raise_exception(ale(ext_rhs_notlist(Clause,Ss))).

verify_featrestr_list(FRs,Clause,ArgNo) :-
  ( is_list(FRs) -> % check intro component
    ( member(FR,FRs), % failure-drive through list to check arguments
      ( var(FR) -> raise_exception(ale(intro_rhs_var(Clause)))
      ; (FR = (F:R)) ->
          ( atom(F) -> true
          ; raise_exception(ale(feat_notatom(F,Clause)))
          ),
          ( atom(R) -> (R \== bot -> assert(ext_or_intro_rhstype(R)) ; true)
          ; var(R) -> raise_exception(ale(intro_vr_var(Clause)))
                       % R can be a variable if parametric types are added
          ; (R = (a_ X)) -> ale(cyclic_abar_restriction(F,R,Clause,ArgNo))
                      if_error cyclic_term(X),
                    ground_abar_restriction(F,R,Clause,ArgNo)
                              new_if_warning ground(X)
          ; raise_exception(ale(vr_other(R,Clause)))
          )
      ; raise_exception(ale(fr_other(FR,Clause)))
      ),
      fail
    ; true
    )
  ; raise_exception(ale(intro_rhs_notlist(Clause,FRs)))
  ).

% ------------------------------------------------------------------------------
% sort_no_dups(+List,-Sorted,+Clause,+ArgNo)
% ------------------------------------------------------------------------------
% Sorted is the result of sorting List and removing duplicates.  If a duplicate
%  is found, a warning (duplicate_types/3) is issued with a pointer to argument
%  number ArgNo of user-defined Clause.
% This code is based on the Edinburgh Prolog standard.
% ------------------------------------------------------------------------------
sort_no_dups(List,Sorted,Clause,ArgNo) :-
  sort_no_dups(List,-1,S,[],Clause,ArgNo),
  Sorted = S.

sort_no_dups([],_,[],[],_,_).
sort_no_dups([Head|Tail],Lim,Sorted,Rest,Clause,ArgNo) :-
  samrun_no_dups(Tail,[Head|T],Head,T,Run,Rest0,Clause,ArgNo),
  sort_no_dups(Rest0,1,Lim,Run,Sorted,Rest,Clause,ArgNo).

sort_no_dups([Head|Tail],J,Lim,Run0,Sorted,Rest,Clause,ArgNo) :-
  J =\= Lim, !,
  samrun_no_dups(Tail,[Head|T],Head,T,Run1,Rest0,Clause,ArgNo),
  sort_no_dups(Rest0,1,J,Run1,Run2,Rest1,Clause,ArgNo),
  merge_no_dups(Run0,Run2,Run,Clause,ArgNo),
  K is J<<1,
  sort_no_dups(Rest1,K,Lim,Run,Sorted,Rest,Clause,ArgNo).
sort_no_dups(Rest,_,_,Sorted,Sorted,Rest,_,_).

% ------------------------------------------------------------------------------
% samrun_no_dups(List,Q1,Q2,End,Run,Rest,Clause,ArgNo)
% ------------------------------------------------------------------------------
% List is a list of elements, Rest is some tail of that list,
% Run is an ordered _set_ of the difference between List and Rest,
% Q1 is the ./2 cell containing the first element of List.
% Q2 is the last element of Run.
% End is the tail of Run.
% ------------------------------------------------------------------------------
samrun_no_dups([],Run,_,[],Run,[],_,_).
samrun_no_dups([Head|Tail],Begin,Last,End,Run,Rest,Clause,ArgNo) :-
  compare(X,Head,Last),
  samrunt_no_dups(X,Head,Tail,Begin,Last,End,Run,Rest,Clause,ArgNo).

samrunt_no_dups(>,Head,Tail,Begin,_,[Head|NewEnd],Run,Rest,Clause,ArgNo) :-
  samrun_no_dups(Tail,Begin,Head,NewEnd,Run,Rest,Clause,ArgNo).
samrunt_no_dups(=,_,Tail,Begin,Last,End,Run,Rest,Clause,ArgNo) :-
  (duplicate_types(Last,Clause,ArgNo) warning),
  samrun_no_dups(Tail,Begin,Last,End,Run,Rest,Clause,ArgNo).
samrunt_no_dups(<,Head,Tail,Begin,Last,End,Run,Rest,Clause,ArgNo) :-
  Begin = [First|_],
  compare(X,Head,First),
  samrunh_no_dups(X,Head,Tail,Begin,Last,End,Run,Rest,Clause,ArgNo).

samrunh_no_dups(<,Head,Tail,Begin,Last,End,Run,Rest,Clause,ArgNo) :-
  samrun_no_dups(Tail,[Head|Begin],Last,End,Run,Rest,Clause,ArgNo).
samrunh_no_dups(=,Head,Tail,Begin,Last,End,Run,Rest,Clause,ArgNo) :-
  (duplicate_types(Head,Clause,ArgNo) warning),
  samrun_no_dups(Tail,Begin,Last,End,Run,Rest,