% [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,Clause,ArgNo).
samrunh_no_dups(>,Head,Tail,Run,_,[],Run,[Head|Tail],_,_).

% ------------------------------------------------------------------------------
% merge_no_dups/5
% ------------------------------------------------------------------------------
% like SICStus ord_union/3 but warns on duplicates
% ------------------------------------------------------------------------------
merge_no_dups([],Set,Set,_,_).
merge_no_dups([O|Os],Ns,Set,Clause,ArgNo) :-
  merge_no_dups(Ns,O,Os,Set,Clause,ArgNo).

merge_no_dups([],O,Os,[O|Os],_,_).
merge_no_dups([N|Ns],O,Os,Set,Clause,ArgNo) :-
  compare(C,O,N),
  merge_no_dups(C,O,Os,N,Ns,Set,Clause,ArgNo).

merge_no_dups(<,O1,Os,N,Ns,[O1|Set],Clause,ArgNo) :-
  merge_no_dups(Os,N,Ns,Set,Clause,ArgNo).
merge_no_dups(=,_,Os,N,Ns,[N|Set],Clause,ArgNo) :-
  (duplicate_types(N,Clause,ArgNo) warning),
  merge_no_dups(Os,Ns,Set,Clause,ArgNo).
merge_no_dups(>,O,Os,N1,Ns,[N1|Set],Clause,ArgNo) :-
  merge_no_dups(Ns,O,Os,Set,Clause,ArgNo).

% ------------------------------------------------------------------------------
% strip_subs(+MarkedSortedSubs,-SortedSubLHSs,-SortedSubs,-SortedSubIntros)
% ------------------------------------------------------------------------------
% This predicate triages MarkedSortedSubs into sub/2 declarations with
%  (SortedSubIntros) and without (SortedSubs) the optional intro/2 modifier.
%  SortedSubLHSs is a list of the types that occur on the LHS of either kind
%  of declaration but are not found on the RHS of a sub/2 declaration.
% ------------------------------------------------------------------------------
strip_subs([],[],[],[]).
strip_subs([TS-MRHS|MSSubs],SubLHSs,[TS-Ss|Subs],SubIntros) :-
  ( functor(MRHS,intro,2)
  -> arg(1,MRHS,Ss), arg(2,MRHS,FRs),
     SubIntros = [TS-FRs|SubIntrosRest]
  ; MRHS = Ss, SubIntros = SubIntrosRest
  ),
  ale(unary_branch(TS,U)) new_if_warning (Ss = [U]),
  ( clause(sub_rhstype(TS),true) -> SubLHSs = SubLHSsRest
  ; TS = bot -> SubLHSs = SubLHSsRest
  ; SubLHSs = [TS|SubLHSsRest]
  ),
  strip_subs(MSSubs,SubLHSsRest,Subs,SubIntrosRest).

% ------------------------------------------------------------------------------
% strip_keys(+KeyedList,-List)
% ------------------------------------------------------------------------------
% List is KeyedList without its keys.
% ------------------------------------------------------------------------------
strip_keys([],[]).
strip_keys([T-_|KeySs],LHSs) :-
  ( clause(sub_rhstype(T),true) -> LHSs = LHSsRest
  ; LHSs = [T|LHSsRest]
  ),
  strip_keys(KeySs,LHSsRest).

% ------------------------------------------------------------------------------
% defmax(?Max)
% ------------------------------------------------------------------------------
% Max is a default maximally specific type.
% ------------------------------------------------------------------------------
defmax(Max) :-
  current_predicate(sub,(_ sub _))
  -> ( clause(sub_rhstype(Max),true)
     ; clause(ext_or_intro_rhstype(Max),true)
     ; current_predicate(intro,_ intro _) -> Max intro _
     ),
     \+ (Max sub _)
  ; ( clause(sub_rhstype(Max),true)
    ; clause(ext_or_intro_rhstype(Max),true)
    ; current_predicate(intro,_ intro _) -> Max intro _
    ).

% ------------------------------------------------------------------------------
% no_duplicates_ksorted(+KeyedList,dup(-K1,-K2,-RHS1,-RHS2,?Arg1,?Arg2,+ArgBindGoal,
%                                      +Warning,+Exception))
% ------------------------------------------------------------------------------
% For every pair of adjacent keys on KeyedList, K1 and K2, with right-hand-sides
%  RHS1 and RHS2, if K1 = K2 and ArgBindGoal is true, then Warning is issued (if
%  Arg1 and Arg2 are variants) or Exception is raised (not variants).  Typically,
%  ArgBindGoal, Warning and Exception contain one or more of K1, K2, RHS1, RHS2,
%  Arg1 or Arg2 upon invocation.
% ------------------------------------------------------------------------------
no_duplicates_ksorted([],_).
no_duplicates_ksorted([T-RHS|Ks],Dup) :-
  no_duplicates_ksorted_act(Ks,T,RHS,Dup).
no_duplicates_ksorted_act([],_,_,_).
no_duplicates_ksorted_act([T2-RHS2|Ks],T1,RHS1,Dup) :-
T1 = T2
-> \+ \+ (Dup = dup(T1,T2,RHS1,RHS2,Arg1,Arg2,ArgBindGoal,Warning,Exception),
           call(ArgBindGoal),
           ( Warning new_if_warning_else_fail variant(Arg1,Arg2)
           -> true
           ; raise_exception(Exception)
           )
          )
; no_duplicates_ksorted_act(Ks,T2,RHS2,Dup).

% ------------------------------------------------------------------------------
% exactly_once(-Sol,+Goal,-AllSolutions,+Exception)
% ------------------------------------------------------------------------------
% Goal succeeds exactly once with Sol.  If it does not succed, then fail.  If
%  it succeeds more than once, then AllSolutions are the solutions and Exception
%  is raised.
% ------------------------------------------------------------------------------
% fail if 0, succeed if 1, throw exception if >1.
exactly_once(Sol,Goal,AllSols,Exception) :-
  findall(Sol,call(Goal),AllSols),
  ( AllSols == [] -> fail
  ; AllSols = [Sol] -> true
  ; raise_exception(Exception)
  ).

% ------------------------------------------------------------------------------
% num_types(+Types,+In:int,-Out:int)
% ------------------------------------------------------------------------------
% Types is sorted in topological order.  Its members are assigned the integers
%  from In (inclusive) to Out (exclusive).
% ------------------------------------------------------------------------------
num_types([],N,N).
num_types([T|Types],NIn,NOut) :-
  assert(type_num(T,NIn)),
  assert(num_type(NIn,T)),
  NMid is NIn + 1,
  num_types(Types,NMid,NOut).

% ==============================================================================
% ZCQ MATRIX ARITHMETIC
% [User's Manual] [Reference Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% seed_refl_close_zmatrix(+RowGraph,+Dim,-ZM)
% ------------------------------------------------------------------------------
% Build a Dim x Dim ZCQ matrix from its row-indexed representation, and
%  reflexively close it.
% ------------------------------------------------------------------------------
seed_refl_close_zmatrix([],_,_).
seed_refl_close_zmatrix([T-Neibs|GraphRest],Dim,ZM) :-
  clause(type_num(T,N),true),
  seed_elt_zcu(N,N,Dim,ZM),  % reflexive closure occurs here
  seed_row_zmatrix(Neibs,N,GraphRest,Dim,ZM).

seed_row_zmatrix([],_,GraphRest,Dim,ZM) :-
  seed_refl_close_zmatrix(GraphRest,Dim,ZM).
seed_row_zmatrix([T|Neibs],N,GraphRest,Dim,ZM) :-
  clause(type_num(T,M),true),
  seed_elt_zcu(N,M,Dim,ZM),
  seed_row_zmatrix(Neibs,N,GraphRest,Dim,ZM).

% ------------------------------------------------------------------------------
% seed_elt_zcu(+I,+J,+Dim,?ZM)
% ------------------------------------------------------------------------------
% Place a 1 in ZM[I,J].  ZM is Dim x Dim.
% Preconditions: 1) 1 <= I <= Dim,
%            and 2) 1 <= J <= Dim.
% ------------------------------------------------------------------------------
seed_elt_zcu(1,J,Dim,ZM) :-
  !,seed_elt_zcu1(J,Dim,ZM).
seed_elt_zcu(I,J,Dim,zcu(A,B,C)) :-
  D2 is (Dim+1) >> 1,
  ( I > D2 -> NewI is I - D2, NewJ is J - D2,
              NewDim is Dim - D2,
              seed_elt_zcu(NewI,NewJ,NewDim,C)
  ; J > D2 -> NewJ is J - D2, CDim is Dim - D2,
              seed_elt_zmatrix(I,NewJ,D2,CDim,B)
  ; seed_elt_zcu(I,J,D2,A)
  ).

seed_elt_zcu1(1,Dim,ZM) :-
  !,seed_origin_zcu(Dim,ZM).
seed_elt_zcu1(J,Dim,zcu(A,B,_)) :-
  D2 is (Dim+1) >> 1,
  ( J > D2 -> NewJ is J - D2, CDim is Dim - D2,
              seed_elt_zmatrix1(NewJ,D2,CDim,B)
  ; seed_elt_zcu1(J,D2,A)
  ).

seed_origin_zcu(1,1) :- !.
seed_origin_zcu(Dim,zcu(A,_,_)) :-
  NewDim is (Dim+1) >> 1,
  seed_origin_zcu(NewDim,A).

% ------------------------------------------------------------------------------
% seed_elt_zmatrix(I,J,RDim,CDim,ZM)
% ------------------------------------------------------------------------------
% Place a 1 in ZM[I,J].  ZM is a RDim x Cdim submatrix.
% Preconditions: 1) 1 <= I <= RDim,
%                2) 1 <= J <= CDim,
%            and 3) either RDim==CDim or they differ by 1
% ------------------------------------------------------------------------------
seed_elt_zmatrix(1,J,RDim,CDim,ZM) :-
  !,seed_elt_zmatrix1(J,RDim,CDim,ZM).
seed_elt_zmatrix(2,J,RDim,CDim,ZM) :-
  !,seed_elt_zmatrix2(J,RDim,CDim,ZM).
seed_elt_zmatrix(I,J,RDim,CDim,zcm(A,B,D,C)) :-
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  ( I > RD2 -> ( J > CD2 -> NewI is I - RD2, NewJ is J-CD2,
                            NewRDim is RDim - RD2, NewCDim is CDim - CD2,
                            seed_elt_zmatrix(NewI,NewJ,NewRDim,NewCDim,C)
       ; NewI is I - RD2, NewRDim is RDim - RD2,
seed_elt_zmatrix(NewI,J,NewRDim,CD2,D)
               )
  ; J > CD2 -> NewJ is J - CD2, NewCDim is CDim - CD2,
               seed_elt_zmatrix(I,NewJ,RD2,NewCDim,B)
  ; seed_elt_zmatrix(I,J,RD2,CD2,A)
  ).

seed_elt_zmatrix1(1,RDim,CDim,ZM) :-
  !,seed_origin_zmatrix(RDim,CDim,ZM).
seed_elt_zmatrix1(2,RDim,CDim,ZM) :-
  !,seed_elt_zmatrix12(RDim,CDim,ZM).
seed_elt_zmatrix1(J,RDim,CDim,zcm(A,B,_,_)) :-
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  ( J > CD2 -> NewJ is J - CD2, NewCDim is CDim - CD2,
               seed_elt_zmatrix1(NewJ,RD2,NewCDim,B)
  ; seed_elt_zmatrix1(J,RD2,CD2,A)
  ).

seed_elt_zmatrix2(1,RDim,CDim,ZM) :-
  !,seed_elt_zmatrix21(CDim,RDim,ZM). % swap column and row dimensions
seed_elt_zmatrix2(2,RDim,CDim,ZM) :-
  !,seed_elt_zmatrix22(RDim,CDim,ZM).
seed_elt_zmatrix2(3,RDim,CDim,ZM) :-
  !,seed_elt_zmatrix23(RDim,CDim,ZM).
seed_elt_zmatrix2(J,RDim,CDim,zcm(A,B,_,_)) :- % J > 3, so CDim > 3, so RDim > 2
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  ( J > CD2 -> NewJ is J - CD2, NewCDim is CDim - CD2,
               seed_elt_zmatrix2(NewJ,RD2,NewCDim,B)
  ; seed_elt_zmatrix2(J,RD2,CD2,A)
  ).

% column and row dimensions swapped
seed_elt_zmatrix21(1,_2,zc21(_,1)) :- !.
seed_elt_zmatrix21(2,RDim,ZM) :-
  !,seed_elt_zmatrix21_x2(RDim,ZM).
seed_elt_zmatrix21(3,RDim,ZM) :-
  !,seed_elt_zmatrix21_x3(RDim,ZM).
seed_elt_zmatrix21(CDim,RDim,zcm(A,_,_,_)) :-  % CDim > 3, so RDim > 2
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  seed_elt_zmatrix21(CD2,RD2,A).

seed_elt_zmatrix21_x2(2,zcm(_,_,1,_)).
seed_elt_zmatrix21_x2(3,zcm(zc21(_,1),_,_,_)).

seed_elt_zmatrix21_x3(2,zcm(_,_,zc12(1,_),_)) :- !.
seed_elt_zmatrix21_x3(_3or4,zcm(zcm(_,_,1,_),_,_,_)).

seed_elt_zmatrix22(2,CDim,ZM) :-
  !,seed_elt_zmatrix22_2(CDim,ZM).
seed_elt_zmatrix22(3,CDim,ZM) :-
  !,seed_elt_zmatrix22_3(CDim,ZM).
seed_elt_zmatrix22(RDim,CDim,zcm(A,_,_,_)) :-  % RDim > 3, so CDim > 2
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  seed_elt_zmatrix22(RD2,CD2,A).

seed_elt_zmatrix22_2(2,zcm(_,_,_,1)).
seed_elt_zmatrix22_2(3,zcm(_,_,zc12(_,1),_)).

seed_elt_zmatrix22_3(2,zcm(_,zc21(_,1),_,_)) :- !.
seed_elt_zmatrix22_3(_3or4,zcm(zcm(_,_,_,1),_,_,_)).

seed_elt_zmatrix23(2,_3,zcm(_,_,_,1)) :- !.  % probably should have column-indexed
seed_elt_zmatrix23(3,CDim,ZM) :-             %  this one like seed_elt_zmatrix21/3.
  !,seed_elt_zmatrix23_3(CDim,ZM).
seed_elt_zmatrix23(4,CDim,ZM) :-
  !,seed_elt_zmatrix23_4(CDim,ZM).
seed_elt_zmatrix23(5,CDim,ZM) :-
  !,seed_elt_zmatrix23_5(CDim,ZM).
seed_elt_zmatrix23(RDim,CDim,zcm(A,_,_,_)) :- % RDim > 5, so CDim > 4
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  seed_elt_zmatrix23(RD2,CD2,A).

seed_elt_zmatrix23_3(3,zcm(_,zc21(_,1),_,_)).
seed_elt_zmatrix23_3(4,zcm(_,zcm(_,_,1,_),_,_)).

seed_elt_zmatrix23_4(3,zcm(_,zc21(_,1),_,_)).
seed_elt_zmatrix23_4(4,zcm(_,zcm(_,_,1,_),_,_)).
seed_elt_zmatrix23_4(5,zcm(zcm(_,_,_,1),_,_,_)).

seed_elt_zmatrix23_5(4,zcm(_,zcm(zc21(_,1),_,_,_),_,_)) :- !.
seed_elt_zmatrix23_5(_5or6,zcm(zcm(_,zc21(_,1),_,_),_,_,_)).

seed_origin_zmatrix(1,CDim,ZM) :-
  !,seed_origin_zmatrix1(CDim,ZM).
seed_origin_zmatrix(2,CDim,ZM) :-
  !,seed_origin_zmatrix2(CDim,ZM).
seed_origin_zmatrix(RDim,CDim,zcm(A,_,_,_)) :-
  NewRDim is (RDim+1) >> 1,
  NewCDim is (CDim+1) >> 1,
  seed_origin_zmatrix(NewRDim,NewCDim,A).

seed_origin_zmatrix1(1,1).
seed_origin_zmatrix1(2,zc12(1,_)).

seed_origin_zmatrix2(1,zc21(1,_)).
seed_origin_zmatrix2(2,zcm(1,_,_,_)).
seed_origin_zmatrix2(3,zcm(zc12(1,_),_,_,_)).

seed_elt_zmatrix12(1,_2,zc12(_,1)) :- !.
seed_elt_zmatrix12(2,CDim,ZM) :-
  !,seed_elt_zmatrix12_2(CDim,ZM).
seed_elt_zmatrix12(3,CDim,ZM) :-
  !,seed_elt_zmatrix12_3(CDim,ZM).
seed_elt_zmatrix12(RDim,CDim,zcm(A,_,_,_)) :-  % RDim > 3, therefore CDim > 2
  RD2 is (RDim+1) >> 1,
  CD2 is (CDim+1) >> 1,
  seed_elt_zmatrix12(RD2,CD2,A).

% CDim==1 not possible: we asked for I==1,J==2
seed_elt_zmatrix12_2(2,zcm(_,1,_,_)).
seed_elt_zmatrix12_2(3,zcm(zc12(_,1),_,_,_)).

seed_elt_zmatrix12_3(2,zcm(_,zc21(1,_),_,_)) :- !.
seed_elt_zmatrix12_3(_3or4,zcm(zcm(_,1,_,_),_,_,_)).

% ------------------------------------------------------------------------------
% upper_tri_trans_close(+Dim,+Matrix,-StarMatrix)
% [Reference Manual] [Reference Manual]
% ------------------------------------------------------------------------------
% StartMatrix is transitive closure of Matrix.  Matrix has 1s on its diagonal,
%   and is upper-triangular.  Both Matrix and StartMatrix are Dim x Dim.
% In a Boolean semiring: (A B) = (A* A*BC*)
%                        (0 C) = (0    C* )
% ------------------------------------------------------------------------------
upper_tri_trans_close(1,ZM,ZM) :- !.
upper_tri_trans_close(Dim,zcu(A,B,C),zcu(AStar,D,CStar)) :-
  ADim is (Dim+1) >> 1,
  CDim is Dim - ADim,
  upper_tri_trans_close(ADim,A,AStar),
  upper_tri_trans_close(CDim,C,CStar),
  mult_um(B,AStar,AStarB),
  mult_mu(AStarB,CStar,D).

% calcuate C = A*B, A is upper-triangular with 1s on diagonal
% (AA AB) (BA BB) = (AA*BA + AB*BD  AA*BB + AB*BC)
% ( 0 AC) (BD BC)   (    AC*BD          AC*BC    )
%
mult_um(0,_,0) :- !.
mult_um(1,A,A).
mult_um(zc12(BA,BB),_1,zc12(BA,BB)).
mult_um(zc21(BA,BD),zcu(_1,AB,_Also1),C) :-
    AB = 0 -> ( (BA = 0,BD = 0) -> C = 0 ; C = zc21(BA,BD))
  ; BA == 1 -> C = zc21(1,BD)
  ; BD == 1 -> C = zc21(1,BD)
  ; (BD = 0 -> C = 0 ; C = zc21(0,1)).

mult_um(zcm(BA,BB,BD,BC),zcu(AA,AB,AC),C) :-
  mult_um(BA,AA,CA1),  % A can't be 0, zc12 or zc21, and because
  mult_mm(AB,BD,CA2),  %  B is not 0, 1 or zc12, A can't be 1
  sum(CA1,CA2,CA),
  mult_um(BB,AA,CB1),
  mult_mm(AB,BC,CB2),
  sum(CB1,CB2,CB),
  mult_um(BD,AC,CD),
  mult_um(BC,AC,CC),
  ( (CA = 0,CB = 0,CD = 0,CC = 0) -> C = 0
  ; C = zcm(CA,CB,CD,CC)
  ).

% calcuate C = A*B
% (AA AB) (BA BB) = (AA*BA + AB*BD  AA*BB + AB*BC)
% (AD AC) (BD BC)   (AD*BA + AC*BD  AD*BB + AC*BC)
%
mult_mm(0,_,0) :- !.
mult_mm(1,B,B).
mult_mm(zc21(AA,AD),B,C) :-
  mult_mm_zc21(B,AA,AD,C).
mult_mm(zc12(AA,AB),B,C) :-
  mult_mm_zc12(B,AA,AB,C).
mult_mm(zcm(AA,AB,AD,AC),B,C) :-
  mult_mm_zcm(B,AA,AB,AD,AC,C).

mult_mm_zc21(0,_,_,0) :- !.
mult_mm_zc21(1,CA,CD,zc21(CA,CD)).
mult_mm_zc21(zc12(BA,BB),AA,AD,C) :-
  ( AA = 0 -> ( AD = 0 -> C = 0
      ; BA == 1 -> C = zcm(0,0,1,BB)
      ; BB == 1 -> C = zcm(0,0,0,1)
      ; C = 0
      )
  ; AD = 0 -> ( BA == 1 -> C = zcm(1,BB,0,0)
      ; BB == 1 -> C = zcm(0,1,0,0)
      ; C = 0
      )
  ; BA == 1 -> C = zcm(1,BB,1,BB)
  ; BB == 1 -> C = zcm(0,1,0,1)
  ; C = 0
  ).

mult_mm_zc12(0,_,_,0) :- !.
mult_mm_zc12(zc21(BA,BD),AA,AB,C) :-
  AA = 0 -> ( AB = 0 -> C = 0  % should we require sparseness, i.e. AA || AB?
    ; BD = 0 -> C = 0
    ; C = 1
    )
  ; BA = 0 -> ( AB = 0 -> C = 0
      ; BD = 0 -> C = 0
      ; C = 1
      )
  ; C = 1.
mult_mm_zc12(zcm(BA,BB,BD,BC),AA,AB,C) :-
  AA = 0 -> ( AB = 0 -> C = 0  % B must be 2x2, or else CDim > RDim + 1
    ; BD == 1 -> C = zc12(1,BC)
    ; BC == 1 -> C = zc12(0,1)
    ; C = 0
    )
  ; AB = 0 -> ( BA == 1 -> C = zc12(1,BB)
      ; BB == 1 -> C = zc12(0,1)
      ; C = 0
      )
  ; BA == 1 -> ( BB == 1 -> C = zc12(1,1)
       ; BC == 1 -> C = zc12(1,1)
       ; C = zc12(1,0)
       )
  ; BD == 1 -> ( BB == 1 -> C = zc12(1,1)
       ; BC == 1 -> C = zc12(1,1)
       ; C = zc12(1,0)
       )
  ; BB == 1 -> C = zc12(0,1)
  ; BC == 1 -> C = zc12(0,1)
  ; C = 0.

mult_mm_zcm(0,_,_,_,_,0) :- !.
mult_mm_zcm(zc21(BA,BD),AA,AB,AD,AC,C) :-  % then A is 2x2
  BA = 0 -> ( BD = 0 -> C = 0
    ; AB == 1 -> C = zc21(1,AC)
    ; AC == 1 -> C = zc21(0,1)
    ; C = 0
    )
  ; BD = 0 -> ( AA == 1 -> C = zc21(1,AD)
      ; AD == 1 -> C = zc21(0,1)
      ; C = 0
      )
  ; AA == 1 -> ( AD == 1 -> C = zc21(1,1)
       ; AC == 1 -> C = zc21(1,1)
       ; C = zc21(1,0)
       )
  ; AB == 1 -> ( AD == 1 -> C = zc21(1,1)
       ; AC == 1 -> C = zc21(1,1)
       ; C = zc21(1,0)
       )
  ; AD == 1 -> C = zc21(0,1)
  ; AC == 1 -> C = zc21(0,1)
  ; C = 0.
mult_mm_zcm(zcm(BA,BB,BD,BC),AA,AB,AD,AC,C) :-
  mult_mm(AA,BA,CA1),    % to require sparseness, we would need to check
  mult_mm(AB,BD,CA2),    %  (CA || CB || CD || CC) here
  sum(CA1,CA2,CA),
  mult_mm(AA,BB,CB1),
  mult_mm(AB,BC,CB2),
  sum(CB1,CB2,CB),
  mult_mm(AD,BA,CD1),
  mult_mm(AC,BD,CD2),
  sum(CD1,CD2,CD),
  mult_mm(AD,BB,CC1),
  mult_mm(AC,BC,CC2),
  sum(CC1,CC2,CC),
  ( (CA=0,CB=0,CD=0,CC=0) -> C = 0
  ; C = zcm(CA,CB,CD,CC)
  ).

% calcuate C = A*B, B is upper-triangular with 1s on diagonal
% (AA AB) (BA BB) = (AA*BA  AA*BB + AB*BC)
% (AD AC) (0  BC)   (AD*BA  AD*BB + AC*BC)
%
mult_mu(0,_,0) :- !.
mult_mu(1,B,B).
mult_mu(zc21(AA,AD),_1,zc21(AA,AD)).
mult_mu(zc12(AA,AB),zcu(_1,BB,_Also1),C) :-
  BB = 0 -> ( (AA=0,AB=0) -> C = 0 ; C = zc12(AA,AB))
  ; AA == 1 -> C = zc12(AA,1)
  ; AB == 1 -> C = zc12(AA,1)
  ; (AA = 0 -> C = 0 ; C = zc12(1,0)).
mult_mu(zcm(AA,AB,AD,AC),zcu(BA,BB,BC),C) :-
  mult_mu(AA,BA,CA),
  mult_mm(AA,BB,CB1),
  mult_mu(AB,BC,CB2),
  sum(CB1,CB2,CB),
  mult_mu(AD,BA,CD),
  mult_mm(AD,BB,CC1),
  mult_mu(AC,BC,CC2),
  sum(CC1,CC2,CC),
  ( (CA=0,CB=0,CD=0,CC=0) -> C = 0
  ; C = zcm(CA,CB,CD,CC)
  ).

% calculate C = A+B
sum(0,B,B) :- !.
sum(1,_,1) :- !.
sum(A,B,C) :-
    B = 0 -> C = A
  ; sum_nozero(A,B,C).

sum_nozero(zc12(AA,AB),zc12(BA,BB),zc12(CA,CB)) :-
  sum(AA,BA,CA),
  sum(AB,BB,CB).
sum_nozero(zc21(AA,AD),zc21(BA,BD),zc21(CA,CD)) :-
  sum(AA,BA,CA),
  sum(AD,BD,CD).
sum_nozero(zcm(AA,AB,AD,AC),zcm(BA,BB,BD,BC),zcm(CA,CB,CD,CC)) :-
  sum(AA,BA,CA),
  sum(AB,BB,CB),
  sum(AC,BC,CC),
  sum(AD,BD,CD).

% ------------------------------------------------------------------------------
% rconvert_stm(+ZCMatrix,-RowMatrix,+Col,+RDim,+CDim)
% ------------------------------------------------------------------------------
% Convert the RDim x CDim submatrix ZCMatrix to row-indexed form.  ZCMatrix
%  is offset by Col columns within its larger matrix.
% ------------------------------------------------------------------------------
% Precondition: RowMatrix is proper
% Postcondition: each row is proper
rconvert_stm(0,RowMatrix,_Col,_NumRows,_NumCols) :-
  terminate_rows(RowMatrix).
rconvert_stm(1,[[Col]],Col,_1,_Also1).
rconvert_stm(zc12(A,B),RowMatrix,Col,_1,_2) :-
  A = 0 -> ( B = 0 -> RowMatrix = [[]]
   ; BCol is Col + 1,
     RowMatrix = [[BCol]]
   )
  ; ( B = 0 -> RowMatrix = [[Col]]
    ; BCol is Col + 1,
      RowMatrix = [[Col,BCol]]
    ).
rconvert_stm(zc21(A,D),RowMatrix,Col,_2,_1) :-
  A = 0 -> ( D = 0 -> RowMatrix = [[],[]]
   ; RowMatrix = [[],[Col]]
   )
  ; ( D = 0 -> RowMatrix = [[Col],[]]
    ; RowMatrix = [[Col],[Col]]
    ).
rconvert_stm(zcu(A,B,C),RowMatrix,Col,NumRows,NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,CRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm(B,BRowMatrix,BCCol,ABRows,BCCols),
  CRows is NumRows - ABRows,
  rconvert_stm(C,CRowMatrix,BCCol,CRows,BCCols).
rconvert_stm(zcm(A,B,D,C),RowMatrix,Col,NumRows,NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm(B,BRowMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  rconvert_stm_tail(D,DRowMatrix,CRowMatrix,Col,CDRows,ADCols),
  rconvert_stm(C,CRowMatrix,BCCol,CDRows,BCCols).

% Precondition: RowMatrix is proper
% Postcondition: TailMatrix is proper, same length as RowMatrix,
%  and contains tails of its rows
rconvert_stm_tail(0,RowMatrix,RowMatrix,_Col,_NumRows,_NumCols).
rconvert_stm_tail(1,[[Col|Tail]],[Tail],Col,_1,_Also1).
rconvert_stm_tail(zc12(A,B),RowMatrix,TailMatrix,Col,_1,_2) :-
  A = 0 -> ( B = 0 -> RowMatrix = [Tail], TailMatrix = RowMatrix
   ; BCol is Col + 1,
     RowMatrix = [[BCol|Tail]], TailMatrix = [Tail]
   )
  ; ( B = 0 -> RowMatrix = [[Col|Tail]], TailMatrix = [Tail]
    ; BCol is Col + 1,
      RowMatrix = [[Col,BCol|Tail]], TailMatrix = [Tail]
    ).
rconvert_stm_tail(zc21(A,D),RowMatrix,TailMatrix,Col,_2,_1) :-
  A = 0 -> ( D = 0 -> RowMatrix = [TailA,TailD], TailMatrix = RowMatrix
   ; RowMatrix = [TailA,[Col|TailD]], TailMatrix = [TailA,TailD]
   )
  ; ( D = 0 -> RowMatrix = [[Col|TailA],TailD], TailMatrix = [TailA,TailD]
    ; RowMatrix = [[Col|TailA],[Col|TailD]], TailMatrix = [TailA,TailD]
    ).
rconvert_stm_tail(zcu(A,B,C),RowMatrix,TailMatrix,Col,NumRows,NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,CRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols).
rconvert_stm_tail(zcm(A,B,D,C),RowMatrix,TailMatrix,Col,NumRows,NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  rconvert_stm_tail(D,DRowMatrix,CRowMatrix,Col,CDRows,ADCols),
  rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols).

% Precondition: RowMatrix is proper
% PostCondition: TailMatrix is improper and contains tails of rows of RowMatrix,
%  TailRestMatrix is tail of TailMatrix
rconvert_stm_opentail(0,RowMatrix,TailMatrix,TailRestMatrix,_Col,_NumRows,_NumCols) :-
  append(RowMatrix,TailRestMatrix,TailMatrix).
rconvert_stm_opentail(1,[[Col|Tail]],[Tail|TailRest],TailRest,Col,_1,_Also1).
rconvert_stm_opentail(zc12(A,B),RowMatrix,TailMatrix,TailRestMatrix,Col,_1,_2) :-
  A = 0 -> ( B = 0 -> RowMatrix = [Tail], TailMatrix = [Tail|TailRestMatrix]
   ; BCol is Col + 1,
     RowMatrix = [[BCol|Tail]], TailMatrix = [Tail|TailRestMatrix]
   )
  ; ( B = 0 -> RowMatrix = [[Col|Tail]], TailMatrix = [Tail|TailRestMatrix]
    ; BCol is Col + 1,
      RowMatrix = [[Col,BCol|Tail]], TailMatrix = [Tail|TailRestMatrix]
    ).
rconvert_stm_opentail(zc21(A,D),RowMatrix,TailMatrix,TailRestMatrix,Col,_2,_1) :-
  A = 0 -> ( D = 0 -> RowMatrix = [TailA,TailD],
              TailMatrix = [TailA,TailD|TailRestMatrix]
   ; RowMatrix = [TailA,[Col|TailD]], TailMatrix = [TailA,TailD|TailRestMatrix]
   )
  ; ( D = 0 -> RowMatrix = [[Col|TailA],TailD],
       TailMatrix = [TailA,TailD|TailRestMatrix]
    ; RowMatrix = [[Col|TailA],[Col|TailD]], TailMatrix = [TailA,TailD|TailRestMatrix]
    ).
rconvert_stm_opentail(zcu(A,B,C),RowMatrix,TailMatrix,TailRestMatrix,Col,NumRows,
      NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,CRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  rconvert_stm_opentail(C,CRowMatrix,CTailMatrix,TailRestMatrix,BCCol,CDRows,BCCols).
rconvert_stm_opentail(zcm(A,B,D,C),RowMatrix,TailMatrix,TailRestMatrix,Col,NumRows,
      NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  rconvert_stm_tail(D,DRowMatrix,CRowMatrix,Col,CDRows,ADCols),
  rconvert_stm_opentail(C,CRowMatrix,CTailMatrix,TailRestMatrix,BCCol,CDRows,BCCols).

% Precondition: RowMatrix is proper
% Postcondition: TailMatrix is proper and contains tails of first NumRows rows
%  of RowMatrix, RestMatrix is remaining rows of RowMatrix.
rconvert_stm_open(0,RowMatrix,RestMatrix,TailMatrix,_Col,NumRows,_NumCols) :-
  length(TailMatrix,NumRows),
  append(TailMatrix,RestMatrix,RowMatrix).
rconvert_stm_open(1,[[Col|Tail]|Rest],Rest,[Tail],Col,_1,_Also1).
rconvert_stm_open(zc12(A,B),RowMatrix,RestMatrix,TailMatrix,Col,_1,_2) :-
  A = 0 -> ( B = 0 -> RowMatrix = [Tail|RestMatrix], TailMatrix = [Tail]
   ; BCol is Col + 1,
     RowMatrix = [[BCol|Tail]|RestMatrix], TailMatrix = [Tail]
   )
  ; ( B = 0 -> RowMatrix = [[Col|Tail]|RestMatrix], TailMatrix = [Tail]
    ; BCol is Col + 1,
      RowMatrix = [[Col,BCol|Tail]|RestMatrix], TailMatrix = [Tail]
    ).
rconvert_stm_open(zc21(A,D),RowMatrix,RestMatrix,TailMatrix,Col,_2,_1) :-
  A = 0 -> ( D = 0 -> RowMatrix = [TailA,TailD|RestMatrix], TailMatrix = [TailA,TailD]
   ; RowMatrix = [TailA,[Col|TailD]|RestMatrix], TailMatrix = [TailA,TailD]
   )
  ; ( D = 0 -> RowMatrix = [[Col|TailA],TailD|RestMatrix], TailMatrix = [TailA,TailD]
    ; RowMatrix = [[Col|TailA],[Col|TailD]|RestMatrix], TailMatrix = [TailA,TailD]
    ).
rconvert_stm_open(zcu(A,B,C),RowMatrix,RestMatrix,TailMatrix,Col,NumRows,NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  length(CRowMatrix,CDRows),
  append(CRowMatrix,RestMatrix,DRowMatrix),
  rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols).
rconvert_stm_open(zcm(A,B,D,C),RowMatrix,RestMatrix,TailMatrix,Col,NumRows,NumCols) :-
  ABRows is (NumRows+1) >> 1,
  ADCols is (NumCols+1) >> 1,
  rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols),
  BCCol is Col + ADCols,
  BCCols is NumCols - ADCols,
  rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols),
  CDRows is NumRows - ABRows,
  rconvert_stm_open(D,DRowMatrix,RestMatrix,CRowMatrix,Col,CDRows,ADCols),
  rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols).

terminate_rows([]).
terminate_rows([[]|Rest]) :-
  terminate_rows(Rest).

% ==============================================================================

% ------------------------------------------------------------------------------
% hash_stm_rows(RowMatrix,N)
% ------------------------------------------------------------------------------
% Assert the rows of RowMatrix, beginning with index N.
% ------------------------------------------------------------------------------
hash_stm_rows([],_).
hash_stm_rows([Row|STMatrix],N) :-
  assert(stmatrix_num(N,Row)),
  NPlus1 is N + 1,
  hash_stm_rows(STMatrix,NPlus1).

% ==============================================================================
% compile_approp/0,1
% [User's Manual] [Reference Manual]
% ==============================================================================

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

compile_approp :-
  touch('.alec_throw'),
  absolute_file_name('.alec_throw',AbsFileName),
  retractall(ale_compiling(_)),
  assert(ale_compiling(AbsFileName)),
%  verify_subintro_declarations(SortedSubIntros),
%  verify_intro_declarations(SortedIntros),
%  rebuild_stmatrix(STMatrix),
  compile_approp_act, % (SortedSubIntros,SortedIntros,STMatrix),
  retract(ale_compiling(_)).

verify_subintro_declarations(SortedSubIntros) :-
  ( current_predicate(sub,_ sub _)
  -> findall(S-FRs,
     (S sub Ts intro FRs,
     % Error checks invariant to structure of Ss:
      ( var(S) -> raise_exception(ale(sub_lhs_var(S sub Ts intro FRs)))
      ; functor(S,a_,1) -> raise_exception(ale(sub_lhs_abrar))
      ; atom(S) -> true
      ; raise_exception(ale(sub_lhs_other(S)))
      ),
     % Error checks for combined sub/intro declarations:
      ((S = bot,
        FRs \== []) -> raise_exception(ale(bot_feats(S sub Ts intro FRs)))
      ; verify_featrestr_list(FRs,(S sub Ts intro FRs),3)
      )
     ),SubIntros)
  ; SubIntros = []
  ),
  keysort(SubIntros,SortedSubIntros).      % sort, but dups are still there

rebuild_stmatrix(STMatrix) :-
  findall(N-Row,clause(stmatrix_num(N,Row),true),STMatrix),
  ( STMatrix == [] -> raise_exception(ale(no_stmatrix))
  ; true
  ).

compile_approp_act :-
  alec_announce('Compiling appropriateness...'),
  abolish((approp)/3), abolish((approps)/3),
  ensure_sub_intro,
  ale(bot_feats(bot sub Ss intro [F:R|FRs])) if_error
        (bot sub Ss intro [F:R|FRs]),
  ale(bot_feats(bot intro [F:R|FRs])) if_error
        (bot intro [F:R|FRs]),
  ale(no_features) new_if_warning
        (\+ (_ sub _ intro [_:_|_]),
         \+ (_ intro [_:_|_])),
  ale(duplicate_vr(F,S)) if_error
            ( S sub _ intro FRs,
              duplicated(F:_,FRs)
            ; S intro FRs2,
              duplicated(F:_,FRs2)),
  ale(duplicate_intro(S)) if_error
       (S sub _ intro _,
        S intro _
       ;bagof(IType,FRs^(IType intro FRs),ITypes),
        duplicated(S,ITypes)),            % multiple sub/2 taken care of above
  ( ( ( S sub _ intro FRs
      ; S intro FRs),
      member((_:(a_ X)),FRs),
      cyclic_term(X)
    ) -> error_msg((nl,write_list([atom,'a_',X,is,cyclic,in,declaration,of,S]),ttynl))
    ; true
  ),
  ale(ground_abar_restriction(F,(a_ X),Clause,ArgNo)) new_if_warning
            ( ( S sub _ intro FRs, Clause = (S sub _ intro FRs), ArgNo = 3
              ; S intro FRs, Clause = (S intro FRs), ArgNo = 2),
              member((F:(a_ X)),FRs),
              ground(X)),
  assert(alec(approp)),
  \+ \+ compile('.alec_throw'),
  assert(alec(approps)),
  \+ \+ compile('.alec_throw'),
  retractall(subsume_ready),
  assert(subsume_ready),      % mark as ready for subtest
  ale(approp_cycle(S,Fs)) if_error
     ( type(S), feat_cycle(S,Fs) ),
  ale(nontriv_upward_closure(F,S,T2,T1)) new_if_warning
     ( approp(F,S,T1), restricts(S,F,T2),
       \+ variant(T1,T2)),
  ale(join_nopres(F,S1,S2)) new_if_warning
     non_join_pres(_,F,S1,S2).

ensure_sub_intro :-
(\+current_predicate(sub,(_ sub _)) -> assertz((_ sub _ :- fail)) ; true),
(\+current_predicate(intro,(_ intro _)) -> assertz((_ intro _ :- fail))
  ; true).

%compile_approp_act(SortedSubIntros,SortedIntros,STMatrix) :-
%  alec_announce('Compiling appropriateness...'),
%  abolish((approp)/3), abolish((approps)/3),
%  trace, %DEBUG
%  ( no_features new_if_warning_else_fail (SortedSubIntros == [],SortedIntros == [])
%  ; no_duplicates_ksorted(SortedIntros,
%       dup(L1,_,R1,R2,A1,A2,(R1 = A1, R2 = A2),duplicate_decl(intro(L1,R1)),
%           ale(duplicate_intro(L1)))),
%    build_vrqmatrix(SortedSubIntros,SortedIntros,VRQMatrix), % build V

%    qtranspose(VRQMatrix,VRQMatrixTpose),
%    transpose(STMatrix,STMatrixTpose),
%    qmultiply(STMatrixTpose,VRQMatrixTpose,RQMatrix),    % build R = ST * V

%    qtranspose(RQMatrix,RQMatrixTpose),
%    verify_upward_closure(VRQMatrixTpose,RQMatrixTpose), % warn on non-trivial up. closures

%    build_stiqmatrixtpose(RQMatrixTpose,STMatrix,VRQMatrix,STIQMatrixTPose),
%    qtranspose(STIQMatrixTPose,STIQMatrix),              % build ST * I

%    convolute(RQMatrix,CMatrix),                         % build C = convolution of R
%    (  top_sort(CMatrix,_)                            % check for appropriateness cycles
%    -> true
%     ; member(T-Neibs,CMatrix),
%       member(S,Neibs),
%       min_path(S,T,CMatrix,Path,_),
%       raise_exception(ale(approp_cycle(T,[T|Path])))
%    ),

%% --- MUST CHANGE approp/3
%    assert(alec(approp)),
%    \+ \+ compile('.alec_throw'),
%    assert(alec(approps)),
%    \+ \+ compile('.alec_throw'),
%    retractall(subsume_ready),
%    assert(subsume_ready),      % mark as ready for subtest

%    verify_join_preservation(RQMatrix,STIQMatrix)

%  ).

build_vrqmatrix([],SIntros,VRQMatrix) :-
  !,build_vrqmatrix_one(SIntros,VRQMatrix).
build_vrqmatrix(SIntros1,SIntros2,VRQMatrix) :-
  SIntros2 = [T2-FRs2|SIntros2Rest]
  -> SIntros1 = [T1-FRs1|SIntros1Rest],
     clause(type_num(T1,N1),true),
     clause(type_num(T2,N2),true),
     compare(Op,N1,N2),
     build_vrqmatrix_act(Op,N1,FRs1,SIntros1Rest,N2,FRs2,SIntros2Rest,
VRQMatrix)
   ; build_vrqmatrix_one(SIntros1,VRQMatrix).

build_vrqmatrix_act(<,N1,FRs1,SIntros1,N2,FRs2,SIntros2,
                    [N1-N1Row|VRQMatrix]) :-
  replace_colons(FRs1,KFRs1),
  keysort(KFRs1,SortedFRs1),
  no_duplicates_ksorted(SortedFRs1,dup(F1,_,VR1,VR2,A1,A2,
                        (VR1 = A1, VR2 = A2, clause(num_type(N1,T1),true)),
                        duplicate_feat(F1,VR1,T1),
                        ale(duplicate_vr(F1,T1)))),
  flatten_keys(SortedFRs1,N1Row),
  build_vrqmatrix_rest(SIntros1,N2,FRs2,SIntros2,VRQMatrix).
build_vrqmatrix_act(>,N1,FRs1,SIntros1,N2,FRs2,SIntros2,
                    [N2-N2Row|VRQMatrix]) :-
  replace_colons(FRs2,KFRs2),
  keysort(KFRs2,SortedFRs2),
  no_duplicates_ksorted(SortedFRs2,dup(F1,_,VR1,VR2,A1,A2,
                        (VR1 = A1, VR2 = A2, clause(num_type(N2,T2),true)),
                        duplicate_feat(F1,VR1,T2),
                        ale(duplicate_vr(F1,T2)))),
  flatten_keys(SortedFRs2,N2Row),
  build_vrqmatrix_rest(SIntros2,N1,FRs1,SIntros1,VRQMatrix).
build_vrqmatrix_act(=,N,FRs1,SIntros1,_N,FRs2,SIntros2,[N-NRow|VRQMatrix]) :-
  duplicate_decl(intro(T,FRs1)) if_warning_else_fail
                  (variant(FRs1,FRs2), clause(num_type(N,T),true))
  -> replace_colons(FRs1,KFRs1),
     keysort(KFRs1,SortedFRs1),
     no_duplicates_ksorted(SortedFRs1,dup(F1,_,VR1,VR2,A1,A2,
                              (VR1 = A1, VR2 = A2, clause(num_type(N,T),true)),
                                          duplicate_feat(F1,VR1,T),
                                          ale(duplicate_vr(F1,T)))),
     flatten_keys(SortedFRs1,NRow),
     build_vrqmatrix(SIntros1,SIntros2,VRQMatrix)
  ; clause(num_type(N,T),true),
    raise_exception(ale(duplicate_intro(T))).

build_vrqmatrix_rest([],N2,FRs2,SIntros2,[N2-N2Row|VRQMatrix]) :-
  replace_colons(FRs2,KFRs2),
  keysort(KFRs2,SortedFRs2),
  no_duplicates_ksorted(SortedFRs2,dup(F1,_,VR1,VR2,A1,A2,
                        (VR1 = A1, VR2 = A2, clause(num_type(N2,T2),true)),
                        duplicate_feat(F1,VR1,T2),
                        ale(duplicate_vr(F1,T2)))),
  flatten_keys(SortedFRs2,N2Row),
  build_vrqmatrix_one(SIntros2,VRQMatrix).
build_vrqmatrix_rest([T1-FRs1|SIntros1],N2,FRs2,SIntros2,VRQMatrix) :-
  clause(type_num(T1,N1),true),
  compare(Op,N1,N2),
  build_vrqmatrix_act(Op,N1,FRs1,SIntros1,N2,FRs2,SIntros2,VRQMatrix).

build_vrqmatrix_one([],[]).
build_vrqmatrix_one([T-FRs|SIntros],[N-NRow|VRQMatrix]) :-
  clause(type_num(T,N),true),
  replace_colons(FRs,KFRs),
  keysort(KFRs,SortedFRs),
  no_duplicates_ksorted(SortedFRs,dup(F1,_,VR1,VR2,A1,A2,
                        (VR1 = A1, VR2 = A2),
                        duplicate_feat(F1,VR1,T),
                        ale(duplicate_vr(F1,T)))),
  flatten_keys(SortedFRs,NRow),
  build_vrqmatrix_one(SIntros,VRQMatrix).

replace_colons([],[]).
replace_colons([F:R|FRs],[F-R|KFRs]) :-
  replace_colons(FRs,KFRs).

flatten_keys([],[]).
flatten_keys([K-V|KVs],[K,V|FlattenedKVs]) :-
  flatten_keys(KVs,FlattenedKVs).

restore_keys([],[]).
restore_keys([K,V|FlattenedKVs],[K-V|KVs]) :-
  restore_keys(FlattenedKVs,KVs).

qtranspose(Graph, Transpose) :-
        qtranspose_edges(Graph, TEdges, []),
        sort(TEdges, TEdges2),
        vertices(Graph, Vertices),
        qgroup_edges(Vertices, TEdges2, Transpose).

qtranspose_edges([]) --> [].
qtranspose_edges([Vertex-Neibs|G]) -->
        qtranspose_edges(Neibs, Vertex),
        qtranspose_edges(G).

qtranspose_edges([], _) --> [].
qtranspose_edges([Neib,Q|Neibs], Vertex) --> [q(Neib,Vertex,Q)],
        qtranspose_edges(Neibs, Vertex).

qgroup_edges([], _, []).
qgroup_edges([Vertex|Vertices], Edges, [Vertex-Neibs|G]) :-
        qgroup_edges(Edges, Vertex, Neibs, RestEdges),
        qgroup_edges(Vertices, RestEdges, G).

qgroup_edges([q(V0,X,Q)|Edges], V, [X,Q|Neibs], RestEdges) :- V0==V, !,
        qgroup_edges(Edges, V, Neibs, RestEdges).
qgroup_edges(Edges, _, [], Edges).

qmultiply([],_,[]).
qmultiply([Row1-Cols1|M1],QM2Tpose,[Row1-QCols3|QM3]) :-
  qmultiply_row(QM2Tpose,Cols1,QCols3,M1,QM2Tpose,QM3,Row1).

qmultiply_row([],_,[],M1,QM2Tpose,QM3,_) :-
  qmultiply(M1,QM2Tpose,QM3).
qmultiply_row([Col2-QRows|QM2TposeRest],Cols1,QCols3,M1,QM2Tpose,QM3,Row1) :-
  ( qintersect(Cols1,QRows,[],Q)          % [] is used to represent sub-bot
  -> ( Q == [] -> QCols3 = QCols3Rest
     ; QCols3 = [Col2,Q|QCols3Rest]
     ),
     qmultiply_row(QM2TposeRest,Cols1,QCols3Rest,M1,QM2Tpose,QM3,Row1)
  ; clause(num_type(Row1,T1),true),       % unify_type/3 failed somewhere
    pretty_vrs(QRows,VRs),
    raise_exception(ale(upward_closure(Col2,T1,VRs)))
  ).

qintersect([],_,Q,Q).
qintersect([C|Cols],[R,QR|QRows],QIn,QOut) :-
  compare(Op,C,R),
  qintersect_act(Op,C,Cols,R,QR,QRows,QIn,QOut).

qintersect_act(<,_,Cols,R,QR,QRows,QIn,QOut) :-
  qintersect_col(Cols,R,QR,QRows,QIn,QOut).
qintersect_act(>,C,Cols,_,_,QRows,QIn,QOut) :-
  qintersect_row(QRows,C,Cols,QIn,QOut).
qintersect_act(=,_C,Cols,_AlsoC,QR,QRows,QIn,QOut) :-
  qunify_type(QIn,QR,QMid),
  qintersect(Cols,QRows,QMid,QOut).

qintersect_col([],_,_,_,Q,Q).
qintersect_col([C|Cols],R,QR,QRows,QIn,QOut) :-
  compare(Op,C,R),
  qintersect_act(Op,C,Cols,R,QR,QRows,QIn,QOut).

qintersect_row([],_,_,Q,Q).
qintersect_row([R,QR|QRows],C,Cols,QIn,QOut) :-
  compare(Op,C,R),
  qintersect_act(Op,C,Cols,R,QR,QRows,QIn,QOut).

qunify_type([],T,T) :- !.   % sub-bot unification
qunify_type(T1,T2,T3) :- unify_type(T1,T2,T3).

pretty_types([],[]).
pretty_types([N|Ns],[T|Ts]) :-
  clause(num_type(N,T),true),
  pretty_types(Ns,Ts).

pretty_vrs([],[]).
pretty_vrs([N,QR|QRows],[T:QR|QRs]) :-
  clause(num_type(N,T),true),
  pretty_vrs(QRows,QRs).

verify_upward_closure([],[]).
verify_upward_closure([Feat-VRQRows|VRQMatrixTpose],[_Feat-RQRows|RQMatrixTpose]) :-
  verify_upward_closure_feat(VRQRows,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat).

verify_upward_closure_feat([],_,VRQMatrixTPose,RQMatrixTPose,_) :-
  verify_upward_closure(VRQMatrixTPose,RQMatrixTPose).
verify_upward_closure_feat([VN,VQ|VRQRows],[RN,RQ|RQRows],VRQMatrixTpose,RQMatrixTPose,
                           Feat) :-
  compare(Op,VN,RN),
  verify_ucf_act(Op,VN,VQ,VRQRows,RN,RQ,RQRows,VRQMatrixTpose,RQMatrixTPose,Feat).

% verify_ucf_act(<,...): R contains all the rows that V does
verify_ucf_act(>,VN,VQ,VRQRows,_,_,[RN,RQ|RQRows],VRQMatrixTpose,RQMatrixTpose,Feat) :-
  compare(Op,VN,RN),
  verify_ucf_act(Op,VN,VQ,VRQRows,RN,RQ,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat).
verify_ucf_act(=,VN,VQ,VRQRows,_VN,RQ,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat) :-
  ( variant(VQ,RQ) -> true
  ; clause(num_type(VN,T),true),
    (nontriv_upward_closure(Feat,T,VQ,RQ) warning)
  ),
  verify_upward_closure_feat(VRQRows,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat).

build_stiqmatrixtpose([],_,_,[]).
build_stiqmatrixtpose([VCol-RQRows|RQMatrixTpose],STMatrix,VRQMatrix,
                      [VCol-SQRows|STIQMatrixTpose]) :-
  qdelta(RQRows,RRows),
  ( memberchk(VRow-RRows,STMatrix)
  -> memberchk(VRow-VRQCols,VRQMatrix),
     append(_,[VCol,V|_],VRQCols),
     qproject(RRows,V,SQRows),
     build_stiqmatrixtpose(RQMatrixTpose,STMatrix,VRQMatrix,STIQMatrixTpose)
  ; map_minimal(RRows,RMins),
    raise_exception(ale(feat_intro(VCol,RMins)))
  ).

qdelta([],[]).
qdelta([Col,_|QCols],[Col|Cols]) :-
  qdelta(QCols,Cols).

qproject([],_,[]).
qproject([Col|Cols],V,[Col,V|QCols]) :-
  qproject(Cols,V,QCols).

convolute([],[]).
convolute([N-QCols|QMatrix],[T-Cols|Matrix]) :-
  clause(num_type(N,T),true),
  convolute_cols(QCols,Cols,QMatrix,Matrix).

convolute_cols([],[],QMatrix,Matrix) :-
  convolute(QMatrix,Matrix).
convolute_cols([_,Q|QCols],Cols,QMatrix,Matrix) :-
  ( functor(Q,a_,1) -> Cols = ColsRest  % a_/1 atoms have no features
  ; Q == bot -> Cols = ColsRest         % neither does bot
  ; Cols = [Q|ColsRest]
  ),
  convolute_cols(QCols,ColsRest,QMatrix,Matrix).

verify_join_preservation(RQMatrix,STIQMatrix) :-
  unify_type(A,B,C), A @< B, B \== C,  A \== C, % no repetition, no subtypes
  atom(C),                                      % no a_/1 atoms
  clause(type_num(A,NA),true),
  clause(type_num(B,NB),true),
  clause(type_num(C,NC),true),
  memberchk(NA-RA,RQMatrix),
  memberchk(NB-RB,RQMatrix),
  memberchk(NC-RC,RQMatrix),
  memberchk(NC-STIC,STIQMatrix),
  unify_vector(RA,RB,RAB),
  unify_vector(RAB,STIC,JP),
  vjp_act(JP,RC,A,B,C),
  fail.
verify_join_preservation(_,_).

vjp_act([],[],_,_,_).
vjp_act([F,QJ|JP],[_F,QC|RC],A,B,C) :-
  ( variant(QJ,QC) -> true
  ; join_nopres(F,A,B) warning,
    ( clause(standard_non_jp(A,B,C),true) -> true
    ; assert(standard_non_jp(A,B,C))
    )
  ),
  vjp_act(JP,RC,A,B,C).

unify_qvector([],V,V).
unify_qvector([F1,Q1|V1],[F2,Q2|V2],[FRes,QRes|VRes]) :-
  compare(Op,F1,F2),
  uqv_act(Op,F1,Q1,V1,F2,Q2,V2,FRes,QRes,VRes).

uqv_act(<,F1,Q1,V1,F2,Q2,V2,F1,Q1,VRes) :-
  uqv_act2(V1,F2,Q2,V2,VRes).
uqv_act(>,F1,Q1,V1,F2,Q2,V2,F2,Q2,VRes) :-
  uqv_act2(V2,F1,Q1,V1,VRes).
uqv_act(=,F,Q1,V1,_F,Q2,V2,F,QRes,VRes) :-
  unify_type(Q1,Q2,QRes),
  unify_qvector(V1,V2,VRes).

uqv_act2([],F,Q,V,[F,Q|V]).
uqv_act2([F1,Q1|V1],F2,Q2,V2,[FRes,QRes|VRes]) :-
  compare(Op,F1,F2),
  uqv_act(Op,F1,Q1,V1,F2,Q2,V2,FRes,QRes,VRes).


compile_extensional(File) :-
  abolish((ext)/1),
  reconsult(File),
  compile_extensional.

compile_extensional :-
  touch('.alec_throw'),
  absolute_file_name('.alec_throw',AbsFileName),
  retractall(ale_compiling(_)),
  assert(ale_compiling(AbsFileName)),
%  verify_ext_declaration(SortedExts),
  compile_extensional_act, % (SortedExts),
  retract(ale_compiling(_)).

compile_extensional_act :- % (SortedExts) :-
  alec_announce('Compiling extensionality declarations...'),
  retractall(extensional(_)),
  retractall(ext_sub_type(_)),retractall(ext_sub_structs(_,_,_,_,_,_)),
  abolish((iso_sub_seq)/3), % abolish((check_sub_seq)/5),
  abolish((check_pre_traverse)/4),abolish((check_post_traverse)/3),
%  assert(alec(ext)),
%  \+ \+ compile('.alec_throw'),
  \+ \+ compile_ext_assert, % (SortedExts),
  \+ \+ compile_ext_sub_assert,
  assert(alec(iso)),
  \+ \+ compile('.alec_throw'),
  assert(alec(check)),
  \+ \+ compile('.alec_throw').

compile_ext_assert :- % (Es) :-
  current_predicate(ext,ext(_)),
  ext(Es), % should be passed as arg
  member(T,Es),
  ( maximal(T) -> assert(extensional(T))
  ; raise_exception(ext_nomax(T))
  ),
  fail.
compile_ext_assert :-
  assert(extensional(a_ _)).


compile_ext_sub_assert :-
  setof(T,E^(clause(extensional(E),true),sub_type(T,E)),ExtSuperTypes),
  member(T,ExtSuperTypes),
  assert(ext_sub_type(T)),
  fail.
compile_ext_sub_assert :-
  esetof(ValueType-MotherType,F^(approp(F,MotherType,ValueType)),
         TposeApprops),
  vertices_edges_to_ugraph([],TposeApprops,TposeAppropGraph),
  top_sort(TposeAppropGraph,AppropTypes),
  compile_ext_sub_assert_act(AppropTypes).

compile_ext_sub_assert_act([]).
compile_ext_sub_assert_act([T|Ts]) :-
  approps(T,FRs,_),
  compile_ext_sub_assert_type(FRs,Vs,NewFSs,FSs,Goals,GoalsRest),
  ( Goals == GoalsRest -> compile_ext_sub_assert_act(Ts)
  ; SVs =.. [T|Vs],
    assert(ext_sub_structs(T,SVs,NewFSs,FSs,Goals,GoalsRest)),
    compile_ext_sub_assert_act(Ts)
  ).

compile_ext_sub_assert_type([],[],FSs,FSs,Goals,Goals).
compile_ext_sub_assert_type([_:R|FRs],[V|Vs],NewFSs,FSs,Goals,GoalsRest) :-
   ext_sub_type(R) -> NewFSs = fs(Tag,SVs,FSsMid),
                      Goals = [deref(V,Tag,SVs)|GoalsMid],
                      compile_ext_sub_assert_type(FRs,Vs,FSsMid,FSs,GoalsMid,
                                                  GoalsRest)
; clause(ext_sub_structs(R,V,NewFSs,FSsMid,Goals,GoalsMid),true) ->
   % this is available if needed because we topologically sorted the types
                      compile_ext_sub_assert_type(FRs,Vs,FSsMid,FSs,GoalsMid,
                                                  GoalsRest)
; compile_ext_sub_assert_type(FRs,Vs,NewFSs,FSs,Goals,GoalsRest).


compile_cons(File) :-
  abolish((cons)/2),
  reconsult(File),
  compile_cons.

%-------------------------------------------------------------------------------
% Type Constraints
% [User's Manual]
%-------------------------------------------------------------------------------

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

compile_cons_act :-
  alec_announce('Compiling type constraints...'),
  abolish((ct)/4), retractall(constrained(_)),
%  retract_fs_palettes(ct),
  (current_predicate(cons,(_ cons _)) ->
            [bot,has,constraints] if_error
                 ( bot cons _ ),
            [multiple,constraint,declarations,for,CType] if_error
                 (bagof(CT,Cons^(CT cons Cons),CTypes),
                  duplicated(CType,CTypes)),
            [constraint,declaration,given,for,atom] if_error
                 ( (a_ _) cons _ ),
%      ['=@',accessible,by,procedural,attachment,calls,from,constraint,for,Type]
%            if_warning (current_predicate(if,(_ if _)),
%                        find_xeqs([],EGs),
%                        Type cons _ goal Gs,
%                        find_xeq_act(Gs,EGs)),
      assert(alec(ct)),
      \+ \+ compile('.alec_throw')
  ; ([no,constraints,found] if_warning true)
  ).

find_xeqs(Accum,EGs) :-
  findall(EG,find_xeq(Accum,EG),NewAccum,Accum),
  find_xeqs_act(NewAccum,Accum,EGs).

find_xeqs_act(EGs,EGs,EGs) :- !.
find_xeqs_act(NewAccum,_,EGs) :-
  find_xeqs(NewAccum,EGs).

find_xeq(Accum,G/N) :-
  (Head if Body),
  functor(Head,G,N),
  \+member(G/N,Accum),
  find_xeq_act(Body,Accum).

find_xeq_act(=@(_,_),_) :- !.
find_xeq_act((G1,_),Accum) :-
  find_xeq_act(G1,Accum),
  !.
find_xeq_act((_,G2),Accum) :-
  find_xeq_act(G2,Accum),
  !.
find_xeq_act((G1 -> G2),Accum) :-
  ( find_xeq_act(G1,Accum)
  ; find_xeq_act(G2,Accum)
  ),
  !.
find_xeq_act((G1;_),Accum) :-
  find_xeq_act(G1,Accum),
  !.
find_xeq_act((_;G2),Accum) :-
  find_xeq_act(G2,Accum),
  !.
find_xeq_act((\+ G),Accum) :-
  find_xeq_act(G,Accum),
  !.
find_xeq_act(At,Accum) :-
  functor(At,AG,AN),
  member(AG/AN,Accum).

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

compile_logic_act :-
  compile_mgsc_act,
  compile_add_to_type_act,
  compile_featval_act,
  compile_u_act.

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

compile_mgsc_act :-
  alec_announce('Compiling most general satisfiers...'),
  abolish((mgsc)/4),
  \+ \+ compile_mgsat_assert.
%  assert(alec(mgsc)),
%  compile('.alec_throw').

%mgsc(T,FS,IqsIn,IqsOut) if_b SubGoals :-
%  clause(mgsat(T,FS,IqsIn,IqsOut,SubGoals,[]),true).

compile_mgsat_assert:-
  esetof(ValueType-MotherType,F^(approp(F,MotherType,ValueType),
                                 \+ ValueType = (a_ _)),TposeApprops),
  setof(T,non_a_type(T),Types),
  vertices_edges_to_ugraph(Types,TposeApprops,TposeAppropGraph),
  top_sort(TposeAppropGraph,AppropTypes),  % build t'pose graph since top_sort
  assert(mgsc((a_ X),_-(a_ X),CGs,CGs)),  % returns reverse ordering
  map_mgsat(AppropTypes).

map_mgsat([]).
map_mgsat([T|AppropTypes]) :-
  approps(T,FRs,_),
  map_mgsat_act(FRs,Vs,ConsGoals,ConsGoalsMid),
  SVs =.. [T|Vs],
  mgsat_cons(T,FS,ConsGoalsMid2,ConsGoalsRest),
  ( ConsGoalsMid2 == ConsGoalsRest    % if there are no constraints at this type, then instantiate
  -> assert(mgsc(T,_-SVs,ConsGoals,ConsGoalsMid))  % var now - add_to_type etc. will bind to this at
                                                   % compile-time if ConsGoals == ConsGoalsMid, and
                                % bind at run-time after executing ConsGoals-ConsGoalsMid otherwise.
  ; ConsGoalsMid = [(FS = _-SVs)|ConsGoalsMid2], % Otherwise, take care of values, then instantiate,
    assert(mgsc(T,FS,ConsGoals,ConsGoalsRest))   % then take care of root constraints.  add_to_type
                                % etc. will bind FS after the entire ConsGoals-ConsGoalsRest stream.
  ),
  map_mgsat(AppropTypes).

map_mgsat_act([],[],ConsGoals,ConsGoals).
map_mgsat_act([_:TypeRestr|FRs],[FS|Vs],ConsGoals,
      ConsGoalsRest) :-
  clause(mgsc(TypeRestr,FS,ConsGoals,ConsGoalsMid),true),
  map_mgsat_act(FRs,Vs,ConsGoalsMid,ConsGoalsRest).

mgsat_cons(Type,FS,ConsGoals,ConsGoalsRest) :-
  findall(T,(clause(constrained(T),true),
             sub_type(T,Type)),ConsTypes),
  map_cons(ConsTypes,FS,ConsGoals,ConsGoalsRest).

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

compile_add_to_type_act :-
  alec_announce('Compiling type promotion...'),
  abolish((add_to_type)/3),
  assert(alec(addtype)),
  \+ \+ consult('.alec_throw').  % HACK: compiling takes too much memory, not much RT loss - and
% for some reason, Win32 SICStus needs to consult this
%  assert(alec(at3)),
%  compile('.alec_throw').

%compile_add_to_type3(Code,CodeRest) :-
%  findall((Goal :-
%             deref(FS,Tag,SVs),
%             Goal2),
%          (non_a_type(Type),   % types other than a_/1 atoms
%           cat_atoms('add_to_type_',Type,Rel),
%           Goal =.. [Rel,FS],
%           Goal2 =.. [Rel,SVs,Tag]),
%          Code,
%          [('add_to_type_a_'(FS,X) :-
%              deref(FS,Tag,SVs),
%              'add_to_type_a_'(SVs,Tag,X))|CodeRest]).


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

compile_featval_act :-
  alec_announce('Compiling feature selection...'),
  abolish((featval)/4),
  ( ((_ sub _ intro _)
    ; (_ intro _))
    -> (assert(alec(featval)),
        \+ \+ compile('.alec_throw'))
%        assert(alec(fv4)),
%        compile('.alec_throw'))
  ; true).


%compile_featval4(Code) :-
%  setof(Clause,
%        Feat^Goal^Goal2^Rel^Type^Subs^FRs^R^(
%                          (Clause = (Goal :-
%                                       deref(FS,Tag,SVs),
%                                       Goal2)),
%                          ( (Type subs Subs intro FRs),
%                            member(Feat:R,FRs),
%                            cat_atoms('featval_',Feat,Rel),
%                            Goal =.. [Rel,FS,FSOut],
%                            Goal2 =.. [Rel,SVs,Tag,FSOut]
%                          ; (Type intro FRs),
%                            member(Feat:R,FRs),
%                            cat_atoms('featval_',Feat,Rel),
%                            Goal =.. [Rel,FS,FSOut],
%                            Goal2 =.. [Rel,SVs,Tag,FSOut])),
%        CodeNoEnd),
%  append(CodeNoEnd,[end_of_file],Code).

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

compile_u_act :-
  alec_announce('Compiling unification...'),
  abolish((u)/4),
  assert(alec(u)),
  \+ \+ consult('.alec_throw').  % HACK: compiling takes too long, not much RT loss

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

compile_subsume_act :-
  no_subsumption
  -> true
   ; (retract(subsume_ready),parsing)
     -> alec_announce('Compiling subsumption checking...'),
        abolish((subsume_type)/13),
        assert(alec(subsume)),
        \+ \+ compile('.alec_throw')
      ; true.

compile_grammar(File):-
  abolish((empty)/1),abolish((rule)/2),
  abolish((lex_rule)/2),
% 5/1/96 - Octav -- added abolish/2 calls for generation predicates
  abolish(('--->')/2),
  abolish((semantics)/1),
  reconsult(File),
  compile_grammar.

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

compile_grammar_act :-
  compile_lex_rules_act,
  compile_lex_act,
  compile_rules_act,
% 5/1/96 - Octav -- added call for compilation of generation predicate
  compile_generate_act.

compile_lex_rules(File):-
  abolish((lex_rule)/2),
  reconsult(File),
  compile_lex_rules.

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

compile_lex_rules_act :-
  abolish((lex_rule)/8), % retract_fs_palettes(lex_rule),
(parsing ->
    alec_announce('Compiling lexical rules...'),
  ( [no,lexical,rules,found] if_warning_else_fail
        (\+ current_predicate(lex_rule,lex_rule(_,_)))
    -> true
% 5/1/96 - Octav -- added test to signal lack of 'morphs' specification
     ; ([lexical,rule,RuleName,lacks,morphs,specification] if_error
          ((RuleName lex_rule _ **> _ if _)
          ;(RuleName lex_rule _ **> _)),
        assert(alec(lexrules)),
        \+ \+ consult('.alec_throw'))  % would compile but routinely exceeds 256-var limit
  )
; true).

compile_lex(File):-
% 5/1/96 - Octav -- added abolish/2 calls for generation predicates
  abolish(('--->')/2),abolish((lex_rule)/2),abolish((semantics)/1),
  reconsult(File),
  compile_lex.

%-------------------------------------------------------------------------------
% Lexical Entries
% [User's Manual]
%-------------------------------------------------------------------------------

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

compile_lex_act :-
  abolish((lex)/2), retract_fs_palettes(lex),
  secret_noadderrs,
  (parsing ->
    alec_announce('Compiling lexicon...'),
    [no,lexicon,found] if_warning
      (\+ current_predicate('--->',(_ ---> _))),
    assert(alec(lex)),
    (lexicon_consult -> \+ \+ consult('.alec_throw')
                      ; \+ \+ compile('.alec_throw'))
  ; true
  ),
  secret_adderrs.

% update_lex(+File)
% -----------------
% add the lexical entries in File to the lexicon, closing under lexical rules.
update_lex(File) :-
  lexicon_consult,
  assert(lexicon_updating),
  reconsult(File),
  retract(lexicon_updating).

% retract_lex(+LexSpec)
% ---------------------
% retract the lexical entries specified by LexSpec, not closing under lexical
%  rules.  LexSpec is either a word, or a list of words.
retract_lex(LexSpec) :-
  ( current_predicate(lex,lex(_,_,_))
  -> ( predicate_property(lex(_,_,_),dynamic) -> (LexSpec = [_|_]
                                                 -> retract_lex_list(LexSpec)
                                                 ; retract_lex_one(LexSpec)
                                                 )
     ; error_msg((nl,write('retract_lex/1: lexicon is currently static'),nl))
     )
  ; error_msg((nl,write('retract_lex/1: no compiled lexicon in memory'),nl))
  ).

retract_lex_list([]).
retract_lex_list([Lex|LexRest]) :-
  retract_lex_one(Lex),
  retract_lex_list(LexRest).

retract_lex_one(Word) :-
  call_residue((clause(lex(Word,FS),Body,Ref), call(Body),
                extensionalise(FS), deref(FS,Tag,SVs)),Residue),
  ((current_predicate(portray_lex,portray_lex(_,_,_,_)),
    portray_lex(Word,Tag,SVs,Residue)) -> true
  ; nl, write('WORD: '), write(Word),
    nl, write('ENTRY: '), nl,
    pp_fs_res(Tag,SVs,Residue),ttynl
  ),
  write('RETRACT? '),ttyflush,read(y),
  erase(Ref),
  fail.
retract_lex_one(_).

retractall_lex(LexSpec) :-
  LexSpec = [_|_]
   -> retractall_lex_list(LexSpec)
    ; retractall(lex(LexSpec,_,_,_)).
retractall_lex_list([]).
retractall_lex_list([Lex|LexRest]) :-
  retractall(lex(Lex,_,_,_)),
  retract_lex_list(LexRest).

% export_words(+Stream,+Delimiter)
% --------------------------------
% Write the words in the current lexicon in a Delimiter-separated list to
%  Stream
export_words(Stream,Delimiter) :-
  setof(Word,FS^lex(Word,FS),Words),
  export_words_act(Words,Stream,Delimiter).
export_words_act([],_,_).
export_words_act([W|Ws],Stream,Delimiter) :-
  write(Stream,W),write(Stream,Delimiter),
  export_words_act(Ws,Stream,Delimiter).

:- dynamic emptynum/1.
:- dynamic alec_rule/7.
:- dynamic fspal_ref/2.

%compile_empty(File):-
%  abolish((empty)/1),
%  reconsult(File),
%  compile_empty.

%-------------------------------------------------------------------------------
% Empty Categories
% [User's Manual]
%-------------------------------------------------------------------------------

%compile_empty :-
%  touch('.alec_throw'),
%  absolute_file_name('.alec_throw',AbsFileName),
%  retractall(ale_compiling(_)),
%  assert(ale_compiling(AbsFileName)),
%  compile_empty_act,
%  retract(ale_compiling(_)).

%compile_empty_act :-
%  abolish((empty_cat)/4),
%  retractall(emptynum(_)),
%  assert(emptynum(-1)),
%  secret_noadderrs,
%  (parsing
%  -> alec_announce('Compiling empty categories...'),
%     (assert(alec(empty)),
%                    (lexicon_consult -> consult('.alec_throw')
%                                      ; compile('.alec_throw')))
%   ; true),
%  secret_adderrs.

%retract_empty :-
%  empty_cat(N,Tag,SVs,IqsIn),
%  extensionalise(Tag,SVs,IqsIn),
%  check_inequal(IqsIn,IqsOut),
%  nl, write('EMPTY CATEGORY: '),
%  pp_fs_col(Tag,SVs,IqsOut,4),
%  ttynl, write('RETRACT? '),ttyflush,read(y),
%  retract(empty_cat(N,Tag,SVs,IqsIn)),
%  fail.
%retract_empty.

%retractall_empty :-
%  retractall(empty_cat(_,_,_,_)).

compile_rules(File):-
% 5/1/96 - Octav -- added abolish/2 calls for generation predicates
  abolish((rule)/2),abolish((empty)/1),
  reconsult(File),
  compile_rules.

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

retract_fs_palettes(Source) :-
  retract(fspal_ref(Source,Ref)),
  erase(Ref),
  fail
; true.

compile_rules_act :-
  alec_announce('Compiling empty categories and phrase structure rules...'),
  abolish((empty_cat)/6), retractall(emptynum(_)), assert(emptynum(-1)),
  abolish((rule)/6), abolish((chain_rule)/10),
  abolish((non_chain_rule)/6),abolish((chained)/6),
  retractall(alec_rule(_,_,_,_,_,_)),
%  retract_fs_palettes(chained),  retract_fs_palettes(chain_rule),
%  retract_fs_palettes(non_chain_rule),  retract_fs_palettes(rule),
  ( [no,phrase,structure,rules,found] if_warning_else_fail
         (\+ current_predicate(rule,rule(_,_)))
    -> true
% 5/1/96 - Octav -- added 'sem_head>' in the list of labels tested for
  ; [rule,RuleName,has,no,'cat>','cats>',or,'sem_head>',specification]
      if_error ((RuleName rule _ ===> Body),
                \+ cat_member(Body),
                \+ cats_member(Body),
        \+ sem_head_member(Body)),
% 5/1/96 - Octav -- added check for multiple occurences of 'sem_head>' label
    [rule,RuleName,has,multiple,'sem_head>',specifications]
      if_error ((RuleName rule _ ===> Body),
        multiple_heads(Body)),
% 6/10/97 - Octav -- added check for bad 'sem_goal>' labels
    [rule,RuleName,has,wrongly,placed,'sem_goal>',specifications]
      if_error ((RuleName rule _ ===> Body),
                bad_sem_goal(Body))),
  (parsing -> (secret_noadderrs,
               assert(alec(empty)),
               \+ \+ consult('.alec_throw'),
               secret_adderrs,
               assert(alec(rules)),
               \+ \+ consult('.alec_throw'))  % HACK - should be compile/1 but too many vars
            ; true),
% 5/1/96 - Octav -- added secret_noadderrs/0 to prevent printing 'unification
%   failure' messages during chaining compilation
% 7/1/98 - Gerald -- changed secret_noadderrs/0 calls to have scope only
%   over relevant (non-chain) lexical compilation
  (generating ->
% 5/1/96 - Octav -- added compilation of chain rules for generation
    ( [no,chain,rules,found] if_warning_else_fail
         (\+ (current_predicate(rule,(_ rule _)),
      (_ rule _ ===> Body), split_dtrs(Body,_,_,_,_,_)))
    -> true
     ; assert(alec(chain)),
       \+ \+ compile('.alec_throw'),
       assert(alec(chained)),
       \+ \+ compile('.alec_throw')),
% 5/1/96 - Octav - added compilation of non_chain rules for generation
    ( [no,non_chain,rules,found] if_warning_else_fail
         (\+ (current_predicate(rule,(_ rule _)),
              (_ rule _ ===> Body), \+ split_dtrs(Body,_,_,_,_,_)),
          \+ current_predicate(empty,empty(_)),
          \+ current_predicate('--->',(_ ---> _)))
    -> true
     ; (assert(alec(nochain)),
        \+ \+ compile('.alec_throw')))
  ; true).

% 5/1/96 - Octav -- added rules to compile the generation predicate
compile_generate(File) :-
  abolish((semantics)/1),
  reconsult(File),
  compile_generate.

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

compile_generate_act :-
  abolish((generate)/4),
  (generating ->
    alec_announce('Compiling semantics directive...'),
  (  [no,semantics,directive,found] if_warning_else_fail
      (\+ current_predicate(semantics,semantics(_)))
  -> true
  ; semantics(Pred), functor(Goal,Pred,2),
    ([no,Pred,definite,clause,found] if_warning_else_fail
      (\+ (current_predicate(if,(_ if _)), (Goal if _)))
    -> true
     ; (assert(alec(generate)),
        \+ \+ compile('.alec_throw'))))
  ; true).

compile_dcs(File):-
  abolish((if)/2),
  reconsult(File),
  compile_dcs.

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

compile_dcs_act :-
  alec_announce('Compiling definite clauses...'),
  retractall(fun_exp(_,_)),
%  retract_fs_palettes(dcs),
  [no,definite,clauses,found] if_warning
    (\+ current_predicate(if,if(_,_))),
  assert(alec(dcs)),
  \+ \+ compile('.alec_throw').

:- dynamic fun_exp/2.
compile_dcs(Code,CodeRest) :-
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  findall((CompiledHead :- CompiledBody),
  ( ( current_predicate('+++>',(_ +++> _)),
      (FunDesc +++> Result),
      functor(FunDesc,Rel,FunArity),
         RelArity is FunArity + 1,
              fun_expand_act(0,FunArity,FunDesc,ArgDescs,Result),
              ( clause(fun_exp(Rel,RelArity),true) -> true
      ; assert(fun_exp(Rel,RelArity))),
      Body = true
            ; current_predicate(if,if(_,_)),
      (Head if Body),
      functor(Head,Rel,RelArity),
      Head =.. [_|ArgDescs]
    ),
            compile_descs(ArgDescs,Args,CompiledBodyList,CompiledBodyRest,
                          true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs),
%              append(Args,[IqsIn,IqsOut],CompiledArgs),
            cat_atoms('fs_',Rel,CompiledRel),
            CompiledHead =.. [CompiledRel|Args],
            compile_body(Body,CompiledBodyRest,[],true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs),
    FSsOut = [],
%            build_fs_palette(FSsOut,FSPal,CompiledBodyList,CompiledBodyMid,dcs),
            goal_list_to_seq(CompiledBodyList,CompiledBody)),
          Code,CodeRest),
  esetof((Rel/RelArity),(current_predicate(if,if(_,_)),
                 (Head if _Body),
functor(Head,Rel,RelArity),
clause(fun_exp(Rel,RelArity),true)),FunRedefines),
  ( member(Spec,FunRedefines),
    [Spec,already,implicitly,defined,by,'+++>',declaration] if_warning true,
    fail
  ; true
  ).
% KNOWN BUG - should register these predicates so that we can abolish them on
%  recompiles.  Unclear what's happening at present.

%     , \+ (CodeRest =[], member(C,Code), write(user_error,C), nl(user_error), fail)
%   ; CodeRest = Code.

fun_expand_act(A,A,_,[Result],Result) :- !.
fun_expand_act(I,A,FunDesc,[ArgDesc|ArgDescs],Result) :-
  NewI is I + 1,
  arg(NewI,FunDesc,ArgDesc),
  fun_expand_act(NewI,A,FunDesc,ArgDescs,Result).


compile_fun(File):-
  abolish(('+++>')/2), abolish((fun)/1),
  reconsult(File),
  compile_fun_act.

compile_fun :-
  compile_fun_act.

compile_fun_act :-
  alec_announce('Compiling functional descriptions...'),
  retractall(fun_spec(_,_,_)),
  compile_fun_assert.

:- dynamic fun_spec/3.
compile_fun_assert :-
  current_predicate(fun,fun(_)),
  (fun FunSpec),
  functor(FunSpec,Functor,RelArity),
  FunArity is RelArity - 1,
  [nullary,relation,FunSpec,specified,as,function] if_error (FunArity < 0),
  [nullary,function,FunSpec,identical,to,type] if_error ( FunArity == 0, non_a_type(Functor) ),
  [unary,function,FunSpec,identical,to,'a_',atom] if_error ( FunArity == 1,
                Functor == 'a_' ),
  ( compile_fun_act(0,RelArity,FunSpec,ResArg) -> assert(fun_spec(Functor,FunArity,ResArg)),
                                                  fail
  ; error_msg((nl,write('  **ERROR: no result argument specified in '),write(FunSpec),nl))
  ).
compile_fun_assert :-
  current_predicate('+++>',(_ +++> _)),
  (FunDesc +++> _Result),
  functor(FunDesc,Functor,FunArity),
  ResArg is FunArity + 1,
  [nullary,function,FunSpec,identical,to,type] if_error ( FunArity == 0, non_a_type(Functor) ),
  [unary,function,FunSpec,identical,to,'a_',atom] if_error ( FunArity == 1,
                             Functor == 'a_' ),
  assert(fun_spec(Functor,FunArity,ResArg)),
  fail.
compile_fun_assert :-
  [conflicting,argument,positions,ResArg1,and,ResArg2,for,function,Functor,'/',FunArity]
    if_warning (clause(fun_spec(Functor,FunArity,ResArg1),true),
                clause(fun_spec(Functor,FunArity,ResArg2),true),
                ResArg1 \== ResArg2).

compile_fun_act(I,N,FunSpec,ResArg) :-
  I < N,
  NewI is I + 1,
  arg(NewI,FunSpec,A),
  ( A == '-' -> ResArg = NewI, compile_fun_flush(NewI,N,FunSpec)
  ; compile_fun_act(NewI,N,FunSpec,ResArg)
  ).

compile_fun_flush(N,N,_) :- !.
compile_fun_flush(I,N,FunSpec) :-
%  I < N,
  NewI is I + 1,
  arg(NewI,FunSpec,A),
  [multiple,result,arguments,specified,in,FunSpec] if_error (A == '-'),
  compile_fun_flush(NewI,N,FunSpec).

%  touch('.alec_throw'),
%  absolute_file_name('.alec_throw',AbsFileName),
%  retractall(ale_compiling(_)),
%  assert(ale_compiling(AbsFileName)),
%  compile_fun_act,
%  retract(ale_compiling(_)).

%compile_fun_act :-
%  alec_announce('Compiling functional descriptions...'),
%  assert(alec(fun)),
%  \+ \+ compile('.alec_throw'),
%  assert(alec(fsolve)),
%  \+ \+ compile('.alec_throw').

%compile_fun(Code,CodeRest) :-
%  ([no,functional,descriptions,found] if_warning_else_fail
%      (\+ current_predicate(+++>,+++>(_,_)))
%  -> (Code = [(fun(_) :- !,fail)|CodeRest])
%  ;  (setof(Functor/Arity,F^((F +++> _),
%                             functor(F,Functor,Arity)),Functions),
%      compile_fun_act(Functions,Code,CodeRest))
%  ).

%compile_fun_act([],Code,Code).
%compile_fun_act([(Functor/Arity)|Functions],
%                [fun(Template)|CodeMid],CodeRest) :-
%  functor(Template,Functor,Arity),
%  compile_fun_act(Functions,CodeMid,CodeRest).

% ------------------------------------------------------------------------------
% cat_member(Dtrs)
% ------------------------------------------------------------------------------
% true if Dtrs has at least one category member
% ------------------------------------------------------------------------------
cat_member((cat> _)).
cat_member((cat> _, _)):-!.
cat_member((_,Body)):-
  cat_member(Body).

% ------------------------------------------------------------------------------
% sem_head_member(+Dtrs:descs)
% ------------------------------------------------------------------------------
% true if Dtrs has at least one sem_head> member
% ------------------------------------------------------------------------------
sem_head_member((sem_head> _)).
sem_head_member((sem_head> _,_)):-!.
sem_head_member((_,Body)):-
  sem_head_member(Body).

% ------------------------------------------------------------------------------
% sem_goal_member(+Dtrs:descs)
% ------------------------------------------------------------------------------
% true if Dtrs has at least one sem_goal> member
% ------------------------------------------------------------------------------
sem_goal_member((sem_goal> _)).
sem_goal_member((sem_goal> _,_)):-!.
sem_goal_member((_,Body)):-
  sem_goal_member(Body).

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

% ------------------------------------------------------------------------------
% multiple_heads(+Dtrs:descs)
% ------------------------------------------------------------------------------
% checks whether Dtrs has multiple sem_head> members
% ------------------------------------------------------------------------------
multiple_heads((sem_head> _,Dtrs)) :- !,
  sem_head_member(Dtrs).
multiple_heads((_,Dtrs)) :-
  multiple_heads(Dtrs).

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

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

% ------------------------------------------------------------------------------
% multi_hash(N:int, Fun/Arity:fun_sym/int,Code:goals,CodeRest:goals)
% ------------------------------------------------------------------------------
% for each solution T1,...,TK of ?- G(T1,...,TK) if_h SubGoals.
%   G(f1(X11,...,X1J1),V2,...,VK):-
%       G_f1(V2,...,VK,X11,...,X1J1).
%   ...
%   G_f1_f2_..._fN(TN+1,...,TK,X11,...,X1J1,X21,..,X2J2,...,XN1,..,XNJN):-
%     SubGoals.
% order matters for clauses listed with if_b, but not with if_h
% clauses with if_b must have subgoals listed, even if empty (for order)
% Will not behave properly with if_b on discontiguous user declarations for N>0
% ------------------------------------------------------------------------------

multi_hash(N,(Fun)/Arity,Code,CodeRest):-
  length(Args,Arity),
  Goal =.. [Fun|Args],
% DEBUG
%  statistics(walltime,B),write(user_error,'pre-setof: '),
%  write(user_error,B),nl(user_error),

  ( setof(sol(Args,SubGoals), if_h(Goal,SubGoals), Sols)
    -> true
     ; bagof(sol(Args,SubGoals), if_b(Goal,SubGoals), Sols)
  ),

%  statistics(walltime,E),write(user_error,'pre-hash: '),
%  write(user_error,E),nl(user_error),

  mh(N,Sols,Fun,Code,CodeRest).

%  statistics(walltime,H),write(user_error,'post-hash: '),
%  write(user_error,H),nl(user_error).


my_multi_hash(N,(Fun)/Arity,Code,CodeRest):-  % DEBUG
  length(Args,Arity),
  Goal =.. [Fun|Args],
  statistics(walltime,_),
  ( setof(sol(Args,SubGoals), if_h(Goal,SubGoals), Sols)
    -> true
     ; bagof(sol(Args,SubGoals), if_b(Goal,SubGoals), Sols)
  ),
  statistics(walltime,[_,SolS]),
  write(user_error,'DEBUG: solutions '),write(user_error,SolS),nl(user_error),flush_output(user_error),
  mh(N,Sols,Fun,Code,CodeRest),
  statistics(walltime,[_,HashS]),
  write(user_error,'DEBUG: hash '),write(user_error,HashS),nl(user_error),flush_output(user_error).

mh(0,Sols,Fun,Code,CodeRest):-
  !, mh_zero(Sols,Fun,Code,CodeRest).
mh(N,Sols,Fun,Code,CodeRest):-
  mh_nonzero(Sols,Fun,N,Code,CodeRest).

mh_zero([],_,Code,Code).
mh_zero([sol(Args,SubGoals)|Sols],Fun,[Clause|CodeMid],CodeRest) :-
  Goal =.. [Fun|Args],
  (SubGoals = []
    -> (Clause = Goal)
     ; (goal_list_to_seq(SubGoals,SubGoalSeq),
        Clause = (Goal :- SubGoalSeq))),
  mh_zero(Sols,Fun,CodeMid,CodeRest).

mh_nonzero([],_,_,Code,Code).
mh_nonzero([sol(Args,SubGoals)],Fun,_,[Clause|CodeRest],CodeRest):-
  !, Goal =.. [Fun|Args],
  (SubGoals = []
   -> (Clause = Goal)
    ; (goal_list_to_seq(SubGoals,SubGoalSeq),
       Clause = (Goal :- SubGoalSeq))).

mh_nonzero([sol([Arg|Args],SubGoals)|Sols],Fun,N,Code,CodeRest):-
  nonvar(Arg),
  functor(Arg,FunArg,Arity),
  Arg =.. [_|ArgsArg],
  ( (Sols = [sol([Arg2|_],_)|_],
     nonvar(Arg2), functor(Arg2,FunArg,Arity))
    -> (cat_atoms('_',FunArg,FunTail),
        cat_atoms(Fun,FunTail,FunNew),
        same_length(Args,OtherArgs),
        Goal =.. [Fun,Arg|OtherArgs],
        append(OtherArgs,ArgsArg,ArgsNew),
        SubGoal =.. [FunNew|ArgsNew],
        append(Args,ArgsArg,ArgsOld),
        (Code = [(Goal :-
                    SubGoal)|CodeMid]),
        SolsSub = [sol(ArgsOld,SubGoals)|SolsSubRest],
        mh_arg(FunArg,Arity,Sols,SolsSub,SolsSubRest,Fun,FunNew,N,
               CodeMid,CodeRest))
  ; Goal =.. [Fun,Arg|Args],
    (Code = [Clause|CodeMid]),
    (SubGoals = []
     -> (Clause = Goal)
      ; (goal_list_to_seq(SubGoals,SubGoalSeq),
         Clause = (Goal :- SubGoalSeq))),
    mh_nonzero(Sols,Fun,N,CodeMid,CodeRest)
  ).

mh_arg(FunMatch,Arity,[sol([Arg|Args],SubGoals)|Sols],SolsSub,SolsSubMid,
       Fun,FunNew,N,Code,CodeRest):-
  nonvar(Arg),
  Arg =.. [FunMatch|ArgsSub],  % formerly cut here - standard order ensures
  length(ArgsSub,Arity),       %  correctness for if_h in both cases
  !,append(Args,ArgsSub,ArgsNew),
  SolsSubMid = [sol(ArgsNew,SubGoals)|SolsSubRest],
  mh_arg(FunMatch,Arity,Sols,SolsSub,SolsSubRest,Fun,FunNew,N,
         Code,CodeRest).
mh_arg(_,_,Sols,SolsSub,[],Fun,FunNew,N,Code,CodeRest):-
  NMinusOne is N-1,
  mh(NMinusOne,SolsSub,FunNew,Code,CodeMid),
  mh_nonzero(Sols,Fun,N,CodeMid,CodeRest).



% ==============================================================================
% Debugger / Top Level I/O
% [User's Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% show_type(Type:type)
% [User's Manual]
% ------------------------------------------------------------------------------
% Displays information about Type, including appropriate features, immediate
% subtypes, supertypes, and constraints.  Continues by allowing to browse
% super or subtypes
% ------------------------------------------------------------------------------
show_type(Type):-
  type(Type),
  immed_subtypes(Type,SubTypes),
  ( setof(T,T2^(sub_type(T,Type),
                T \== Type,
                \+ (sub_type(T2,Type),
                    T2 \== Type, T2 \== T,
                    sub_type(T,T2))),SuperTypes)
    -> true
  ; SuperTypes = []
  ),
  (current_predicate(cons,(_ cons _))
   -> ((Type cons Cons goal Goal)
       -> true
        ; Type cons Cons
          -> Goal = none
           ; Cons = none, Goal = none)
    ; Cons = none, Goal = none
  ),
  ( join_reducible(Type) -> JoinReducible = 1  ; JoinReducible = 0),
  esetof(F,non_join_pres(Type,F),Fs),
  esetof(T,unary_branch(T,Type),Ts),
  ((current_predicate(portray_type_info,portray_type_info(_,_,_,_,_,_,_,_)),
    portray_type_info(Type,SubTypes,SuperTypes,JoinReducible,Fs,Ts,Cons,Goal)) -> true
  ; nl,  write('TYPE: '), write(Type),
    nl, write('SUBTYPES: '), write_list(SubTypes),
    nl, write('SUPERTYPES: '), write_list(SuperTypes),
    ( JoinReducible == 1 -> nl,write(Type),write(' is JOIN-REDUCIBLE') ; true),
    ( Fs == [] -> true ; nl,write('HOMOMORPHISM CONDITION fails at: '),
                         write_list(Fs)),
    ( Ts == [] -> true ; nl,write('UNARY BRANCHES from: '), write_list(Ts)),
    empty_assoc(EAssoc),
    nl, write('IMMEDIATE CONSTRAINT: '), pp_desc(Cons,EAssoc,_,EAssoc,_,22,EAssoc,_),
    (Goal == none -> true
    ; nl, write('           WITH GOAL: '), pp_goal(Goal,EAssoc,_,EAssoc,_,22,EAssoc,_)
    )
  ),
  call_residue((add_to(Type,Tag,bot),
                deref(Tag,bot,Ref,SVs),
extensionalise(Ref,SVs)),Residue),
  ((current_predicate(portray_mgsat,portray_mgsat(_,_,_,_)),
    portray_mgsat(Type,Ref,SVs,Residue)) -> true
  ; nl, write('MOST GENERAL SATISFIER: '),
    pp_fs_res_col(Ref,SVs,Residue,5),nl
  ),
  query_proceed.

% ------------------------------------------------------------------------------
% show_cons(Type:type)
% [User's Manual]
%-------------------------------------------------------------------------------
show_cons(Type):-
  immed_cons(Type,Cons,Goal),
  nl, write('Immediate Constraint for type: '),write(Type),
  nl, write(Cons),
  (Goal = true -> true
  ; nl, write('with goal: '), write(Goal)).

% ------------------------------------------------------------------------------
% mgsat(Desc:desc)
% [User's Manual]
% ------------------------------------------------------------------------------
% prints out most general satisfiers of Desc
% ------------------------------------------------------------------------------
mgsat(Desc):-
   \+ \+ (call_residue((add_to(Desc,Tag,bot),
                        deref(Tag,bot,Ref,SVs),
        extensionalise(Ref,SVs)),Residue),
  ((current_predicate(portray_mgsat,portray_mgsat(_,_,_,_)),
    portray_mgsat(Desc,Ref,SVs,Residue)) -> true
  ; nl, write('MOST GENERAL SATISFIER OF: '), write(Desc), nl,
            pp_fs_res(Ref,SVs,Residue), nl
  ),
          query_proceed).

% ------------------------------------------------------------------------------
% iso_desc(Desc1:desc, Desc2:desc)
% ------------------------------------------------------------------------------
% checks if Desc1 and Desc2 create extensionally identical structures
% ------------------------------------------------------------------------------
iso_desc(D1,D2):-
  add_to(D1,Tag1,bot),
  add_to(D2,Tag2,bot),
  deref(Tag1,bot,DTag1,DSVs1),
  deref(Tag2,bot,DTag2,DSVs2),
  iso_seq_act(DTag1,DSVs1,DTag2,DSVs2,done).

% ------------------------------------------------------------------------------
% rec(Words:words)
% [User's Manual]
% ------------------------------------------------------------------------------
% basic predicate to parse Words;  prints out recognized categories
% one at a time
% ------------------------------------------------------------------------------
rec(Words):-
  nl, write('STRING: '),
  nl, number_display(Words,0),
  ttynl,
  \+ \+ on_exception(ale(Exception),
     (rec(Words,Tag,SVs,Residue),
                      ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
                        portray_cat(Words,bot,Tag,SVs,Residue)) -> true
               % see also gen/1 - portray_cat/5 can be called with var 1st arg.
                      ; nl, write('CATEGORY: '),nl, ttyflush,
                        pp_fs_res(Tag,SVs,Residue), nl
                      ),
                      query_proceed),
     alex(Exception)).

% ------------------------------------------------------------------------------
% rec(Words:words,Desc:desc)
% [User's Manual]
% ------------------------------------------------------------------------------
% Like rec/1, but solution FSs must satisfy Desc
% ------------------------------------------------------------------------------
rec(Words,Desc):-  % must add code to print residues
  nl, write('STRING: '),
  nl, number_display(Words,0),
  ttynl,
  \+ \+ on_exception(ale(Exception),
     (rec(Words,Tag,SVs,Desc,Residue),
                      ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
                        portray_cat(Words,Desc,Tag,SVs,Residue)) -> true
                      ; nl, write('CATEGORY: '),nl, ttyflush,
                        pp_fs_res(Tag,SVs,Residue),nl
                      ),
                      query_proceed),
     alex(Exception)).

% ------------------------------------------------------------------------------
% rec_best(+WordsList:list(words),Desc)
% [User's Manual]
% ------------------------------------------------------------------------------
% Parses every list of words in WordsList until one succeeds, satisfying Desc,
%  or there are no more lists.  If one succeeds, then rec_best/2 will backtrack
%  through all of its solutions that satisfy Desc, but not through the
%  subsequent lists of words in WordsList.

rec_best([],_) :-
  fail.
rec_best([Ws|WordsList],Desc) :-
\+ \+ on_exception(ale(Exception),
    (if(rec(Ws,Tag,SVs,Desc,Residue),
                        (((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
                    portray_cat(Ws,Desc,Tag,SVs,Residue)) -> true
                         ; nl,write('STRING: '),
                          nl,number_display(Ws,0),
                          nl, write('CATEGORY: '),nl, ttyflush,
                          pp_fs_res(Tag,SVs,Residue),nl
                         ),
                        query_proceed),
                        rec_best(WordsList,Desc))),
    alex(Exception)).

% ------------------------------------------------------------------------------
% rec_list(+WordsList:list(words),Desc)
% [User's Manual]
% ------------------------------------------------------------------------------
% Parses every list of words in WordsList until one succeeds, satisfying Desc,
%  or there are no more lists.  Unlike rec_best/2, rec_list/2 will backtrack
%  through all of the solutions of a list that succeeds, and then continue
%  parsing the subsequent lists of words in WordsList.

rec_list([],_) :-
  fail.
rec_list([Ws|WordsList],Desc) :-
  \+ \+ on_exception(ale(Exception),
             ((rec(Ws,Tag,SVs,Desc,Residue),
                  ((current_predcicate(portray_cat,portray_cat(_,_,_,_,_)),
                    portray_cat(Ws,Desc,Tag,SVs,Residue)) -> true
               ; nl,write('STRING: '),
                         nl,number_display(Ws,0),
                      nl, write('CATEGORY: '),nl, ttyflush,
                         pp_fs_res(Tag,SVs,Residue),nl
               ),
                       query_proceed)
                     ; rec_list(WordsList,Desc)
     ),
     alex(Exception)).

% ------------------------------------------------------------------------------
% rec_list(+WordsList:list(words),Desc,SolnsList:list(s))
% ------------------------------------------------------------------------------
% Like rec_list/2, but collects the solutions in a list of lists, one for each
%  list of words in WordsList.
% ------------------------------------------------------------------------------
rec_list([],_,[]).
rec_list([Ws|WordsList],Desc,[Solns|SolnsList]) :-
  bagof(soln(Tag-SVs,Residue),
on_exception(ale(Exception),rec(Ws,Tag,SVs,Desc,Residue),alex(Exception)),
        Solns),
  rec_list(WordsList,Desc,SolnsList).

% ------------------------------------------------------------------------------
% lex(Word:word)
% [User's Manual]
% ------------------------------------------------------------------------------
% prints out all categories for Word, querying user in between
% ------------------------------------------------------------------------------
lex(Word):-
  on_exception(ale(Exception),
       (current_predicate(lex,lex(_,_))
               -> call_residue((if(lex(Word,FS),
                      extensionalise(FS),
                        raise_exception(ale(unk_word(Word)))),
                deref(FS,Tag,SVs)),Residue),
                  ((current_predicate(portray_lex,portray_lex(_,_,_,_)),
                    portray_lex(Word,Tag,SVs,Residue)) -> true
                  ; nl, write('WORD: '), write(Word),
                    nl, write('ENTRY: '), nl,
                    pp_fs_res(Tag,SVs,Residue), nl
                  ),
                  query_proceed
               ; raise_exception(ale(no_lex))),
       alex(Exception)).

% ------------------------------------------------------------------------------
% query(GoalDesc:goal_desc)
% [User's Manual]
% ------------------------------------------------------------------------------
% given a goal description GoalDesc, finds most general satisfier of it
% and then calls it as a goal
% ------------------------------------------------------------------------------
query(GoalDesc):-  % must add code to print residues
\+ \+
(nl, empty_assoc(AssocIn),
  call_residue((query_goal(GoalDesc,Args,[],Goal,Zip),
                    % call(Goal), --- query_goal/5 now calls its Goal
Zip = [], % Args isn't well-formed until we instantiate this.
extensionalise_list(Args)),Residue),
  \+ \+ (((current_predicate(portray_ale_goal,portray_ale_goal(_,_)),
   portray_ale_goal(Goal,Residue)) -> true
; build_iqs(Residue,Iqs,FSResidue),
   (show_res -> residue_args(FSResidue,ResArgs,Args) ; ResArgs = Args),
   duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid),
   duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_),
           pp_goal(Goal,DupsMid2,DupsMid3,AssocIn,VisMid2,0,AssocIn,HDMid),
   nl,nl,
   pp_iqs(Iqs,DupsMid3,DupsOut,VisMid2,VisOut,0,HDMid,HDOut),
   ((show_res,FSResidue \== [])
      -> nl,nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_)
    ; true), nl
),
         query_proceed)
).

query_goal(GD) :-
  query_goal(GD,_,_,_,[]).
  % instantiating Zip now guarantees no Arg suspensions.

query_goal(GD,DtrCats,DtrCatsRest,G,Zip) :-
  empty_assoc(NVs),
  on_exception(cut,query_goal0(GD,DtrCats,DtrCatsRest,G,NVs,Zip),fail).
% IS THIS EXCEPTION HANDLER PROPERLY PLACED?  WHAT TO DO ABOUT RULE
% ATTACHMENTS WITH EXPOSED CUTS?

query_goal0((GD1,GD2),DtrCats,DtrCatsRest,(G1,G2),NVs,Zip):-
  !, query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip),
  query_goal0(GD2,DtrCatsMid,DtrCatsRest,G2,NVs,Zip).
query_goal0((GD1 -> GD2 ; GD3),DtrCats,DtrCatsRest,(G1 -> G2 ; G3),NVs,Zip) :-
  !,( query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip)
    -> query_goal0(GD2,DtrCatsMid,DtrCatsMid2,G2,NVs,Zip),
       nv_replace_body(GD3,G3,DtrCatsMid2,DtrCatsRest,NVs)
    ; query_goal0(GD3,DtrCatsMid2,DtrCatsRest,G3,NVs,Zip),
      nv_replace_body(GD1,G1,DtrCats,DtrCatsMid,NVs),
      nv_replace_body(GD2,G2,DtrCatsMid,DtrCatsMid2,NVs)
    ).
query_goal0((GD1;GD2),DtrCats,DtrCatsRest,(G1;G2),NVs,Zip):-
  !,( query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip),
      nv_replace_body(GD2,G2,DtrCatsMid,DtrCatsRest,NVs)
    ; query_goal0(GD2,DtrCatsMid,DtrCatsRest,G2,NVs,Zip),
      nv_replace_body(GD1,G1,DtrCats,DtrCatsMid,NVs)
    ).
query_goal0((\+ GD1),DtrCats,DtrCatsRest,(\+ G1),NVs,_) :-
  !, \+ query_goal0(GD1,_,_,_,NVs,_),
  nv_replace_body(GD1,G1,DtrCats,DtrCatsRest,NVs).
query_goal0(prolog(Hook),DtrCats,DtrCats,prolog(Hook),_NVs,_) :-
  !,
  call(Hook).
query_goal0(prolog(NVs,Hook),DtrCats,DtrCats,prolog(NVs,Hook),NVs,_) :-
  !,
  call(Hook).
query_goal0(when(Cond,Body),DtrCats,DtrCatsRest,when(NCond,Goal),NVs,Zip) :-
  !, query_cond(Cond,NCond,Body,DtrCats,DtrCatsRest,Goal,NVs,Zip,_).
query_goal0(true,DtrCats,DtrCats,true,_,_) :-
  !.
query_goal0(fail,_,_,_,_,_) :-
  !, fail.
query_goal0(!,DtrCats,DtrCats,!,_,_) :-
  !, ( true
     ; raise_exception(cut)
     ).
query_goal0((GD1 -> GD2),DtrCats,DtrCatsRest,(G1 -> G2),NVs,Zip) :-
  !,(  query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip)
    -> query_goal0(GD2,DtrCatsMid,DtrCatsRest,G2,NVs,Zip)
    ).
query_goal0((Desc1 =@ Desc2),[Tag1Out-SVs1Out,Tag2Out-SVs2Out|DtrCatsMid],DtrCatsRest,
   ((Tag1Out-SVs1Out) =@ (Tag2Out-SVs2Out)),NVs,_) :-
  !, nv_replace_desc(Desc1,NDesc1,DtrCatsMid,DtrCatsMid2,NVs),
  add_to(NDesc1,Tag1,bot),
  nv_replace_desc(Desc2,NDesc2,DtrCatsMid2,DtrCatsRest,NVs),
  add_to(NDesc2,Tag2,bot),
  deref(Tag1,bot,DTag1,DSVs1),
  deref(Tag2,bot,DTag2,DSVs2),
  ext_act(fs(DTag1,DSVs1,fs(DTag2,DSVs2,fsdone)),edone),
  deref(DTag1,DSVs1,Tag1Out,SVs1Out),
  deref(DTag2,DSVs2,Tag2Out,SVs2Out),
  (Tag1Out == Tag2Out).
query_goal0((Desc1 = Desc2),[TagOut-SVsOut,TagOut-SVsOut|DtrCatsMid],DtrCatsRest,
    ((TagOut-SVsOut) = (TagOut-SVsOut)),NVs,_) :-
  !, nv_replace_desc(Desc1,NDesc1,DtrCatsMid,DtrCatsMid2,NVs),
  add_to(NDesc1,Tag,bot),
  nv_replace_desc(Desc2,NDesc2,DtrCatsMid2,DtrCatsRest,NVs),
  deref(Tag,bot,TagMid,SVsMid),
  add_to(NDesc2,TagMid,SVsMid),
  deref(Tag,bot,TagOut,SVsOut).
query_goal0(AtGD,DtrCats,DtrCatsRest,Goal,NVs,_):-
  AtGD =.. [Rel|ArgDescs],
  query_goal_args(ArgDescs,DtrCats,DtrCatsRest,GoalArgs,NVs),
  cat_atoms('fs_',Rel,CompiledRel),
  AtG =.. [CompiledRel|GoalArgs],
  Goal =.. [Rel|GoalArgs],
  call(AtG).

query_goal_args([],DtrCats,DtrCats,[],_).
query_goal_args([D|Ds],[FS|DtrCats],DtrCatsRest,[FS|GArgs],NVs):-
  nv_replace_desc(D,ND,DtrCats,DtrCatsMid,NVs),
  FS = Tag-bot,
  add_to(ND,Tag,bot),
  query_goal_args(Ds,DtrCatsMid,DtrCatsRest,GArgs,NVs).

query_cond(X^(Cond),Fresh^(NCond),Body,DtrCats,DtrCatsRest,NBody,NVs,Zip,FreshNVs) :-
  !, % ['non-variable',X,used,in,quantifier] if_error nonvar(X), - do we need this?
  % References might make it difficult to index instantiated narrow vars,
  % and we can't tell one from another Tag-SVs in prolog hooks.
  (var(Zip) -> when(nonvar(FreshNVs),get_assoc(X,FreshNVs,seen(Fresh))) ; true), % nonvar(Zip) means don't care about Fresh
  put_assoc(X,NVs,unseen,NVsMid),
  query_cond(Cond,NCond,Body,DtrCats,DtrCatsRest,NBody,NVsMid,Zip,FreshNVs).
query_cond(Cond,NCond,Body,DtrCats,DtrCatsRest,NBody,NVs,Zip,FreshNVs) :-
  var(Zip),
  !, when(nonvar(FreshNVs),nv_replace_cond0(Cond,NCond,DtrCats,DtrCatsMid,FreshNVs)),
  when(nonvar(Zip),(var(FreshNVs) -> map_assoc(nv_fresh,NVs,NVsSeen),
                                     nv_replace_body(Body,NBody,DtrCatsMid,DtrCatsRest,
     NVsSeen),
                     FreshNVs = NVsSeen
                               % FreshNVs must be well-formed when bound
                   ; true)),
  transform_cond(Cond,CUFCond),
  query_cond0(CUFCond,(map_assoc(nv_fresh,NVsOut,NVsSeen),
       FreshNVs = NVsSeen,  % FreshNVs must be well-formed when bound
                       query_goal0(Body,DtrCatsMid,DtrCatsRest,NBody,FreshNVs,Zip)),
      NVs,NVsOut).
query_cond(Cond,_,Body,_,_,_,NVs,Zip,_) :-
  % nonvar(Zip) - so forget about NCond, NBody, FreshNVs, and DtrCats-Rest
  transform_cond(Cond,CUFCond),
  query_cond0(CUFCond,(map_assoc(nv_fresh,NVsOut,NVsSeen),
                       query_goal0(Body,_,_,_,NVsSeen,Zip)),
      NVs,NVsOut).

query_cond0([Cond1|Cond2],WBody,NVs,FreshNVs) :-
  query_cond0_act(Cond2,Cond1,WBody,NVs,FreshNVs).

query_cond0_act([],(C1;C2),WBody,NVs,NVsOut) :-
  !, when(nonvar(Trigger),(Trigger == 0 -> NVsOut = NVsOut0 ; NVsOut = NVsOut1)),
  query_cond0(C1,(Trigger = 0 -> WBody ; true),NVs,NVsOut0),
  query_cond0(C2,(Trigger = 1 -> WBody ; true),NVs,NVsOut1).
query_cond0_act([],FS=Desc,WBody,NVs,NVsOut) :-
  [narrowly,quantified,variable,used,on,'LHS',of,delay,FS=Desc]
    if_error get_assoc(FS,NVs,unseen),
  query_cond_desc(Desc,FS,WBody,NVs,NVsOut).
query_cond0_act([Cond|CondRest],FS=Desc,WBody,NVs,NVsOut) :-
  [narrowly,quantified,variable,used,on,'LHS',of,delay,FS=Desc]
    if_error get_assoc(FS,NVs,unseen),
  query_cond_desc(Desc,FS,query_cond0_act(CondRest,Cond,WBody,NVsMid,NVsOut),NVs,NVsMid).

query_cond_desc(Var,FS,Body,NVs,NVsOut) :-
  var(Var),
  !, ( get_assoc(Var,NVs,unseen,NVsOut,seen(FS))
     -> call(Body)
     ; NVsOut = NVs, when_eq(FS,Var,Body)
     ).
query_cond_desc(F:Desc,FS,Body,NVs,NVsOut) :-
introduce(F,FIntro),
  !, name(F,FName),
  append("featval_",FName,RelName),
  name(Rel,RelName),
  FGoal =.. [Rel,SVs,Tag,FSatF],
  when_type(FIntro,FS,(deref(FS,Tag,SVs), FGoal,
       query_cond_desc(Desc,FSatF,Body,NVs,NVsOut))).
query_cond_desc((Path1 == Path2),FS,Body,NVs,NVsOut) :-
  !, expand_path(Path1,PathVar,ExpPath1),
  expand_path(Path2,PathVar,ExpPath2),
  put_assoc(PathVar,NVs,unseen,PathNVs),
  query_cond_desc((ExpPath1,ExpPath2),FS,Body,PathNVs,NVsOut).
query_cond_desc((Desc1,Desc2),FS,Body,NVs,NVsOut) :-
  !, query_cond_desc(Desc1,FS,query_cond_desc(Desc2,FS,Body,NVsMid,NVsOut),NVs,NVsMid).
query_cond_desc((a_ X),FS,Body,NVs,NVs) :-
  !, when_a_(X,FS,Body).
query_cond_desc(Type,FS,Body,NVs,NVs) :-
  type(Type),
  !, (Type == bot -> call(Body)
     ; when_type(Type,FS,Body)
     ).
query_cond_desc(FS2,FS,Body,NVs,NVsOut) :-
  functor(FS2,-,2),
  !, ( get_assoc(FS2,NVs,SeenFlag)
     -> ( SeenFlag = seen(FVar) -> NVsOut = NVs, when_eq(FS,FVar,Body)
; % SeenFlag = unseen,
  put_assoc(FS2,NVs,seen(FS),NVsOut),
          call(Body)
)
     ; NVsOut = NVs, when_eq(FS,FS2,Body)
     ).
query_cond_desc(X,_,_,_,_) :-
  error_msg((nl,write('unrecognised conditional: '),write(X))).

pp_goal(\+ Goal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  !, write('\\+ '), write('( '),
  NewCol is Col+5, pp_goal(Goal,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut),
  nl, tab(Col), tab(3), write(')').
pp_goal((G1 -> G2 ; G3),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('(  '), NewCol is Col + 3,
  pp_goal(G1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid),
  nl, tab(Col), write('-> '),
  pp_goal(G2,DupsMid,DupsMid2,VisMid,VisMid2,NewCol,HDMid,HDMid2),
  nl, tab(Col), write(';  '),
  pp_goal(G3,DupsMid2,DupsOut,VisMid2,VisOut,NewCol,HDMid2,HDOut),
  nl, tab(Col), write(')').
pp_goal((Goal1;Goal2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  !, write('( '), NewCol is Col + 2,
  pp_goal(Goal1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid),
  nl, tab(Col), write('; '),
  pp_goal(Goal2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  nl, tab(Col), write(')').
pp_goal((Goal1,Goal2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  !, pp_goal(Goal1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','),
  nl, tab(Col), pp_goal(Goal2,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).
pp_goal(prolog(Hook),Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write(prolog(Hook)).
pp_goal(prolog(NVs,Hook),Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write(prolog(NVs,Hook)).
pp_goal(when(Cond,Goal),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('when('), NewCol is Col + 5,
  pp_cond(Cond,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid),
  write(','), nl, tab(NewCol),
  pp_goal(Goal,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  write(')').
pp_goal(Desc1 =@ Desc2,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('('),
  NewCol is Col+3,
  pp_desc(Desc1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col),
  write('=@'), nl, tab(NewCol),
  pp_desc(Desc2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col),
  write(')').
pp_goal(true,Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write(true).
pp_goal(!,Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write(!).
pp_goal((G1 -> G2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('(  '), NewCol is Col + 3,
  pp_goal(G1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid),
  nl, tab(Col), write('-> '),
  pp_goal(G2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  nl, tab(Col), write(')').
pp_goal(fail,Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write(fail).
pp_goal((Desc1 = Desc2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('('),
  NewCol is Col+3,
  pp_desc(Desc1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col),
  write('='), nl, tab(NewCol),
  pp_desc(Desc2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col),
  write(')').
pp_goal(Goal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  Goal =.. [Rel|Args],
  write(Rel),
  ( Args = []  % inequation threading occupies the last two positions
    -> VisOut = VisIn, DupsOut = DupsIn, HDOut = HDIn
  ; write('('),
    name(Rel,Name),
    length(Name,N),
    NewCol is Col+N+1,
    pp_goal_args(Args,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut)
  ).

pp_goal_args([Arg],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-  % one left
  !, pp_desc(Arg,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut), write(')').
pp_goal_args([Arg|Args],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  pp_desc(Arg,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, tab(Col),
  pp_goal_args(Args,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).

pp_cond(X^(Cond),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  pp_desc(X,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  nl, tab(Col), write('^ '), NewCol is Col + 2,
  pp_cond(Cond,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut).
pp_cond((C1,C2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  write('('), NewCol is Col + 1,
  pp_cond(C1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), write(','),
  nl, tab(NewCol), pp_cond(C2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  write(')').
pp_cond((C1;C2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  write('( '), NewCol is Col + 2,
  pp_cond(C1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid),
  nl, tab(Col), write('; '),
  pp_cond(C2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  nl, tab(Col), write(')').
pp_cond(FS=Desc,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  pp_desc(FS,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  nl, tab(Col), write('='),
  nl, tab(Col), pp_desc(Desc,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).

pp_desc(X,Dups,Dups,Vis,Vis,_,HD,HD) :-
  var(X),  % should name these
  !, write(X).
pp_desc(Tag-SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, pp_fs(Tag,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut).
pp_desc([],Dups,Dups,Vis,Vis,_,HD,HD) :-
  !,write([]).
pp_desc([H|T],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,write('['),
  pp_desc(H,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  pp_tail(T,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).
pp_desc(F:Desc,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write_feature(F,LengthF),
  NewCol is Col + LengthF +1,
  pp_desc(Desc,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut).
pp_desc(@ Macro,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  write('@ '), NewCol is Col + 2,
  pp_desc(Macro,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut).
% will fall through to function clause
pp_desc((D1,D2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('('), NewCol is Col + 1,
  pp_desc(D1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), write(','),
  nl, tab(NewCol), pp_desc(D2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  write(')').
pp_desc((D1;D2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  !, write('( '), NewCol is Col + 2,
  pp_desc(D1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid),
  nl, tab(Col), write('; '),
  pp_desc(D2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut),
  nl, tab(Col), write(')').
pp_desc((=\= Desc),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('=\\= '), NewCol is Col+4,
  pp_desc(Desc,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut).
pp_desc(Path1 == Path2,Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write(Path1),write(' == '),write(Path2).
pp_desc(a_ X,Dups,Dups,Vis,Vis,_,HD,HD) :-
  !, write('a_ '),write(X).
pp_desc(Other,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
% handles types, functions and macros
  Other =.. [Head|Args],
  write(Head),
  ( Args = [] -> VisOut = VisIn, DupsOut = DupsIn, HDOut = HDIn
  ; write('('),
    name(Head,Name), length(Name,N), NewCol is Col + N + 1,
    pp_descs(Args,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut)
  ).

pp_descs([Desc],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, pp_desc(Desc,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut), write(')').
pp_descs([D|Ds],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  pp_desc(D,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, tab(Col),
  pp_descs(Ds,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).

pp_tail([],Dups,Dups,Vis,Vis,_,HD,HD) :-
  !,write(']').
pp_tail([H|T],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,write(','),pp_desc(H,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  pp_tail(T,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).
pp_tail(NonList,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  write('|'),pp_desc(NonList,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut),
  write(']').

% ------------------------------------------------------------------------------
% mg_sat_fun(FunDesc,Fun,IqsIn,IqsOut)                                   eval
% ------------------------------------------------------------------------------
% Fun is most general satisfier of FunDesc
% (also used for functional descriptions)
% ------------------------------------------------------------------------------
%mg_sat_fun(GoalDesc,Goal,IqsIn,IqsOut):-
%  GoalDesc =.. [Rel|ArgDescs],
%  mg_sat_list(ArgDescs,Args,IqsIn,IqsOut),
%  Goal =.. [Rel|Args].

% ------------------------------------------------------------------------------
% mg_sat_list(GoalDescs,Goals,IqsIn,IqsOut)
% ------------------------------------------------------------------------------
% maps mg_sat_fun on GoalDescs
% ------------------------------------------------------------------------------
mg_sat_list([],[]).
mg_sat_list([ArgDesc|ArgDescs],[Ref-bot|Args]) :-
  add_to(ArgDesc,Ref,bot),
  mg_sat_list(ArgDescs,Args).

% ------------------------------------------------------------------------------
% macro(MacroName:name)
% [User's Manual]
% ------------------------------------------------------------------------------
% prints out possible instantiations of macro named MacroName
% ------------------------------------------------------------------------------
macro(MacroName) :-
%  MacroName = VarName,
%  \+ \+
  empty_assoc(AssocIn),
  (MacroName macro Desc),
  call_residue((add_to(Desc,Tag,bot),
                MacroName =.. [Name|MacroArgDescs],
                mg_sat_list(MacroArgDescs,MacroArgs),
                MacroSat =.. [Name|MacroArgs],
                ArgsOut = [Tag-bot|MacroArgs],
extensionalise_list(ArgsOut)),Residue),
  \+ \+ (((current_predicate(portray_ale_macro,portray_ale_macro(_,_,_,_,_)),
   portray_ale_macro(MacroName,Desc,Tag,bot,Residue)) -> true
; build_iqs(Residue,Iqs,FSResidue),
   (show_res -> residue_args(FSResidue,ResArgs,ArgsOut) ; ResArgs = ArgsOut),
           duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid),
           duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_),
           nl, write('MACRO: '),
           nl, tab(4), pp_goal(MacroSat,DupsMid2,DupsMid3,AssocIn,VisMid2,4,AssocIn,HDMid),
           nl, write('ABBREVIATES:'),
           nl, tab(4), pp_fs(Tag-bot,DupsMid3,DupsMid4,VisMid2,VisMid3,4,HDMid,HDMid2),
           nl, nl, tab(4), pp_iqs(Iqs,DupsMid4,DupsOut,VisMid3,VisOut,4,HDMid2,HDOut),
           ((show_res,FSResidue \== [])
           -> nl, nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_)
           ; true),nl
),
         query_proceed).

%insert_vars(MacroName,VarName):-
%  MacroName =.. [Rel|Args],
%  insert_vars_list(Args,ArgsVars),
%  VarName =.. [Rel|ArgsVars].

%insert_vars_list([],[]).
%insert_vars_list([X|Xs],[(_,X)|XsVar]):-
%  insert_vars_list(Xs,XsVar).

% ------------------------------------------------------------------------------
% empty
% [User's Manual]
% ------------------------------------------------------------------------------
% displays empty categories
% ------------------------------------------------------------------------------
empty:-
  call_residue((empty_cat(I,-1,Tag,SVs,Dtrs,RuleName),
extensionalise(Tag,SVs)),Residue),
  length(Dtrs,ND),
  print_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue).

print_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue) :-
  ((current_predicate(portray_empty,portray_empty(_,_,_,_,_,_,_)),
    portray_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue)) -> true
  ; nl, write('EMPTY CATEGORY: '),
    pp_fs_res_col(Tag,SVs,Residue,4),
    (no_interpreter
    -> true
     ; nl, write('     index: '),(functor(I,empty,2)
                                 -> arg(1,I,E),
                                    write(E)
                                  ; write(I)),
       nl, write('      rule: '),write(RuleName),
       nl, write(' # of dtrs: '),write(ND)
    ),
    nl
  ),
  (no_interpreter -> query_proceed
  ; query_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue)
  ).

query_empty(I,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  write('Action(dtr-#,continue,abort)? '),
  nl,read(Response),
  query_empty_act(Response,I,Tag,SVs,Dtrs,RuleName,ND,Res).

query_empty_act(continue,_,_,_,_,_,_,_) :-
  !,fail.
query_empty_act(abort,_,_,_,_,_,_,_) :-
  !,abort.
query_empty_act(dtr-D,I,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  nth_index(Dtrs,D,empty(DI,-1),-1,-1,DTag,DSVs,DDtrs,DRule,DResidue),
  !,length(DDtrs,DND),
  ( print_empty(DI,DTag,DSVs,DDtrs,DRule,DND,DResidue)
  ; print_empty(I,Tag,SVs,Dtrs,RuleName,ND,Res)
  ).
query_empty_act(_,I,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  !,query_empty(I,Tag,SVs,Dtrs,RuleName,ND,Res).


% ------------------------------------------------------------------------------
% edge(N:int, M:int)
% [User's Manual]
% ------------------------------------------------------------------------------
% prints out edges from N to M, querying user in between
% ------------------------------------------------------------------------------
edge(I) :-
  (I < 0
  -> call_residue(empty_cat(I,N,Tag,SVs,Dtrs,RuleName),Residue),
     M = N
   ; call_residue(clause(edge(I,M,N,Tag,SVs,Dtrs,RuleName),true),Residue)
  ) -> (nl, write('COMPLETED CATEGORY SPANNING: '),
        write_out(M,N),
        nl, edge_act(I,M,N,Tag,SVs,Dtrs,RuleName,Residue))
     ; error_msg((nl,write('edge/1: edge has been retracted'),nl)).

edge(M,N):-
  (M < N
  -> (M >=0
     -> nl, write('COMPLETED CATEGORIES SPANNING: '),
        write_out(M,N), nl,
call_residue(clause(edge(I,M,N,Tag,SVs,Dtrs,RuleName),true),Residue),
% not indexed
        nl, edge_act(I,M,N,Tag,SVs,Dtrs,RuleName,Residue),
        fail
      ; error_msg((nl,write('edge/2: arguments must be non-negative'))))
   ; error_msg((nl,write('edge/2: first argument must be < second argument')))
  ).

edge_act(I,M,N,Tag,SVs,Dtrs,RuleName,Residue) :-
  length(Dtrs,ND),
  print_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Residue).

print_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Residue) :-
  ((current_predicate(portray_edge,portray_edge(_,_,_,_,_,_,_,_)),
    portray_edge(I,M,N,Tag,SVs,RuleName,ND,Residue)) -> true
  ; nl,pp_fs_res(Tag,SVs,Residue),
    (no_interpreter
    -> true
     ; nl,write('Edge created for category above: '),
       nl,write('     index: '),(functor(I,empty,2)
                                -> arg(1,I,E),
                                   write(E)
                                 ; write(I)),
       nl,write('      from: '),write(M),write(' to: '),write(N),
       nl,write('    string: '),write_out(M,N),
       nl,write('      rule:  '),write(RuleName),
       nl,write(' # of dtrs: '),write(ND)
    ),
    nl
  ),
  (no_interpreter -> query_proceed
  ; query_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Residue)
  ).

query_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  nl,write('Action(retract,dtr-#,continue,abort)? '),
  nl,read(Response),
  query_edgeout_act(Response,I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res).

query_edgeout_act(retract,I,M,_,_,_,_,_,_,_) :-
  retract(edge(I,M,_,_,_,_,_)), % will fail on empty cats
  !.
query_edgeout_act(dtr-D,I,M,N,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_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res).
query_edgeout_act(continue,_,_,_,_,_,_,_,_,_) :-
  !.
query_edgeout_act(abort,_,_,_,_,_,_,_,_,_) :-
  !,abort.
query_edgeout_act(_,I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res) :-
  query_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res).

write_out(M,N):-
  parsing(Ws),
  all_but_first(M,Ws,WsRest),
  K is N-M,
  write_first(K,WsRest).

all_but_first(0,Ws,Ws):-!.
all_but_first(M,[_|Ws],WsOut):-
  K is M-1,
  all_but_first(K,Ws,WsOut).

write_first(0,_):-!.
write_first(N,[W|Ws]):-
  write(W), write(' '),
  K is N-1,
  write_first(K,Ws).

% ------------------------------------------------------------------------------
% lex_rule(RuleName:name)
% [User's Manual]
% ------------------------------------------------------------------------------
% Displays lexical rule with name RuleName
% ------------------------------------------------------------------------------
lex_rule(RuleName):-
%  \+ \+
%  lexrule2(RuleName).
%lexrule2(RuleName):-
   ( (RuleName lex_rule Desc1 **> Desc2 if Cond morphs Morphs)
   ; (RuleName lex_rule Desc1 **> Desc2 morphs Morphs),
     Cond = true
   ),
   empty_assoc(AssocIn),
   call_residue((add_to(Desc1,Tag1,bot),
                 add_to(Desc2,Tag2,bot),
                 nv_replace_body(Cond,Goal,Args,[],AssocIn),
                 ArgsOut = [Tag1-bot,Tag2-bot|Args],
extensionalise_list(ArgsOut)),Residue),
   \+ \+ (((current_predicate(portray_lex_rule,portray_lex_rule(_,_,_,_,_,_,_,_,_,_)),
    portray_lex_rule(RuleName,Desc1,Desc2,Tag1,bot,Tag2,bot,Residue,Goal,Morphs)) -> true
  ; build_iqs(Residue,Iqs,FSResidue),
    nl, write('LEX RULE: '), write(RuleName),
            (show_res -> residue_args(FSResidue,ResArgs,ArgsOut) ; ResArgs = ArgsOut),
            duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid),
    duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_),
            nl, write('INPUT CATEGORY: '),
            nl, tab(4), pp_fs(Tag1,bot,DupsMid2,DupsMid3,AssocIn,VisMid2,4,AssocIn,HDMid),
            nl, write('OUTPUT CATEGORY: '),
            nl, tab(4), pp_fs(Tag2,bot,DupsMid3,DupsMid4,VisMid2,VisMid3,4,HDMid,HDMid2),
            ( Cond = true
            -> VisMid4 = VisMid3, DupsMid5 = DupsMid4, HDMid3 = HDMid2
            ; nl, write('CONDITION: '),
              nl, tab(4), pp_goal(Goal,DupsMid4,DupsMid5,VisMid3,VisMid4,4,HDMid2,HDMid3)
       ),
            nl, write('MORPHS: '),
            numbervars(Morphs,0,_),
            pp_morphs(Morphs),
    nl, nl, tab(4), pp_iqs(Iqs,DupsMid5,DupsOut,VisMid4,VisOut,4,HDMid3,HDOut),
            ((show_res,FSResidue \== [])
    -> nl,nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_)
    ; true
       ),nl
  ),
          query_proceed).

pp_morphs((Morph,Morphs)):-
  !, nl, tab(4), pp_morph(Morph),
  pp_morphs(Morphs).
pp_morphs(Morph):-
  nl, tab(4), pp_morph(Morph).

pp_morph((P1 becomes P2)):-
  pp_patt(P1), write(' becomes '), pp_patt(P2).
pp_morph((P1 becomes P2 when Cond)):-
  pp_patt(P1), write(' becomes '), pp_patt(P2),
  nl, tab(8), write('when '), write(Cond).

pp_patt((X,Xs)):-
  !, pp_at_patt(X), write(','),
  pp_patt(Xs).
pp_patt(X):-
  pp_at_patt(X).

pp_at_patt(Atom):-
atom(Atom),
  !, name(Atom,Codes),
  make_char_list(Codes,Chars),
  write(Chars).
pp_at_patt(List):-
  write(List).

% ------------------------------------------------------------------------------
% show_clause(PredSpec:predspec)
% [User's Manual]
% ------------------------------------------------------------------------------
% Displays ALE definite clause source code
% ------------------------------------------------------------------------------
show_clause(Spec):-
  ( (nonvar(Spec),Spec = Name/Arity) -> true
  ; Spec = Name
  ),
  empty_assoc(EAssoc),
  (Head if Body),
  functor(Head,Name,Arity),
  ((current_predicate(portray_ale_clause,portray_ale_clause(_,_)),
    portray_ale_clause(Head,Body)) -> true
  ; nl, write('HEAD: '), pp_goal(Head,EAssoc,_,EAssoc,_,6,EAssoc,_),
    nl, write('BODY: '), pp_goal(Body,EAssoc,_,EAssoc,_,6,EAssoc,_),nl
  ),
  query_proceed.

% ------------------------------------------------------------------------------
% rule(RuleName:name)
% [User's Manual]
% ------------------------------------------------------------------------------
% Displays rule with name RuleName
% ------------------------------------------------------------------------------
rule(RuleName):-
  clause(alec_rule(RuleName,DtrsDesc,_,Moth,_,_),true),
%  (RuleName rule Moth ===> DtrsDesc),
  nl, write('RULE: '), write(RuleName),
  empty_assoc(AssocIn),
  call_residue((satisfy_dtrs(DtrsDesc,DtrCats,[],Dtrs,gdone),
add_to(Moth,TagMoth,bot),
                CatsOut = [TagMoth-bot|DtrCats],
extensionalise_list(CatsOut)),Residue),
  \+ \+ (((current_predicate(portray_rule,portray_rule(_,_,_,_)),
   portray_rule(TagMoth,bot,Dtrs,Residue)) -> true
; build_iqs(Residue,Iqs,FSResidue),
   (show_res -> residue_args(FSResidue,ResArgs,CatsOut) ; ResArgs = CatsOut),
           duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid),
      duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_),
           nl, nl, write('MOTHER: '), nl,
           nl, tab(2), pp_fs(TagMoth,bot,DupsMid2,DupsMid3,AssocIn,VisMid2,2,AssocIn,HDMid),
           nl, nl, write('DAUGHTERS/GOALS: '),
           show_rule_dtrs(Dtrs,DupsMid3,DupsMid4,VisMid2,VisMid3,HDMid,HDMid2),
   nl,nl, tab(2), pp_iqs(Iqs,DupsMid4,DupsOut,VisMid3,VisOut,2,HDMid2,HDOut),
      ((show_res,FSResidue \== [])
      -> nl, nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_)
           ; true), nl
),
         query_proceed).

show_rule_dtrs([],Dups,Dups,Vis,Vis,HD,HD).
show_rule_dtrs([(cat> C)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):-
  !,nl, nl, write('CAT  '), pp_fs(C,DupsIn,DupsMid,VisIn,VisMid,5,HDIn,HDMid),
  show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut).
% 5/1/96 - Octav -- added clause for sem_head> label
show_rule_dtrs([(sem_head> C)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):-
  !,nl, nl, write('SEM_HEAD  '), pp_fs(C,DupsIn,DupsMid,VisIn,VisMid,10,HDIn,HDMid),
  show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut).
show_rule_dtrs([(cats> Cs)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):-
  !,nl, nl, write('CATs '), pp_fs(Cs,DupsIn,DupsMid,VisIn,VisMid,5,HDIn,HDMid),
  show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut).
show_rule_dtrs([(goal> G)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):-
  !,nl, nl, write('GOAL  '), pp_goal(G,DupsIn,DupsMid,VisIn,VisMid,6,HDIn,HDMid),
  show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut).
% 6/1/97 - Octav -- added clause for sem_goal> label
show_rule_dtrs([(sem_goal> G)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):-
  nl, nl, write('SEM_GOAL  '), pp_goal(G,DupsIn,DupsMid,VisIn,VisMid,10,HDIn,HDMid),
  show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut).

satisfy_dtrs((cat> Desc),[Tag-bot|DtrCatsRest],DtrCatsRest,
             [(cat> Tag-bot)],Goals):-
  !, add_to(Desc,Tag,bot),
  nv_replace_goals(Goals).  % must postpone to make sure all variables that
                            %  will be instantiated are instantiated.
% 5/1/96 - Octav -- added clause for sem_head> label
satisfy_dtrs((sem_head> Desc),[Tag-bot|DtrCatsRest],DtrCatsRest,
             [(sem_head> Tag-bot)],Goals):-
  !, add_to(Desc,Tag,bot),
  nv_replace_goals(Goals).
satisfy_dtrs((cats> Descs),[Tag-bot|DtrCatsRest],DtrCatsRest,
             [(cats> Tag-bot)],Goals) :-
  !, add_to(Descs,Tag,bot),
  nv_replace_goals(Goals).
satisfy_dtrs(remainder(RTag,RSVs),[RTag-RSVs|DtrCatsRest],DtrCatsRest,
     [(cats> RTag-RSVs)],Goals) :-
  !, nv_replace_goals(Goals).
satisfy_dtrs((goal> GoalDesc),DtrCats,DtrCatsRest,
             [(goal> Goal)],Goals):-
  !, nv_replace_goals(goal(GoalDesc,Goal,DtrCats,DtrCatsRest,Goals)).
  % satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut).
% 6/1/97 - Octav -- added clause for sem_goal> label
satisfy_dtrs((sem_goal> GoalDesc),DtrCats,DtrCatsRest,
             [(sem_goal> Goal)],Goals):-
  !, nv_replace_goals(goal(GoalDesc,Goal,DtrCats,DtrCatsRest,Goals)).
  % satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut).
satisfy_dtrs(((cat> Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest,
             [(cat> Tag-bot)|DtrsSats],Goals):-
  !, add_to(Desc,Tag,bot),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals).
% 5/1/96 - Octav -- added clause for sem_head> label
satisfy_dtrs(((sem_head> Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest,
             [(sem_head> Tag-bot)|DtrsSats],Goals):-
  !, add_to(Desc,Tag,bot),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals).
satisfy_dtrs(((cats> Descs),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest,
             [(cats> Tag-bot)|DtrsSats],Goals):-
  !, add_to(Descs,Tag,bot),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals).
satisfy_dtrs((remainder(RTag,RSVs),Dtrs),[RTag-RSVs|DtrCatsMid],DtrCatsRest,
     [(cats> RTag-RSVs)|DtrsSats],Goals) :-
  !, satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals).
satisfy_dtrs(((goal> GoalDesc),Dtrs),DtrCats,DtrCatsRest,
              [goal> Goal|DtrsSats],Goals):-
%  satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsMid,Goal,IqsIn,IqsMid),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,
               goal(GoalDesc,Goal,DtrCats,DtrCatsMid,Goals)).
% 6/1/97 - Octav -- added clause for sem_goal> label
satisfy_dtrs(((sem_goal> GoalDesc),Dtrs),DtrCats,DtrCatsRest,
              [sem_goal> Goal|DtrsSats],Goals):-
%  satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsMid,Goal,IqsIn,IqsMid),
  satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,
       goal(GoalDesc,Goal,DtrCats,DtrCatsMid,Goals)).

%satisfy_dtrs_goal((GD1,GD2),DtrCats,DtrCatsRest,
%                  (G1,G2),IqsIn,IqsOut,NVs):-
%  !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs),
%  satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut,NVs).
%satisfy_dtrs_goal((GD1 -> GD2 ; GD3),DtrCats,DtrCatsRest,
%                  (G1 -> G2 ; G3),IqsIn,IqsOut,NVs) :-
%  !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs),
%  satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsMid2,G2,IqsMid,IqsMid2,NVs),
%  satisfy_dtrs_goal(GD3,DtrCatsMid2,DtrCatsRest,G3,IqsMid2,IqsOut,NVs).
%satisfy_dtrs_goal((GD1;GD2),DtrCats,DtrCatsRest,(G1;G2),IqsIn,IqsOut,NVs):-
%  !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs),
%  satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut,NVs).
%satisfy_dtrs_goal((\+ GD1),DtrCats,DtrCatsRest,(\+ G1),IqsIn,IqsOut,NVs):-
%  !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsRest,G1,IqsIn,IqsOut,NVs).
%satisfy_dtrs_goal(prolog(Hook),DtrCats,DtrCats,prolog(Hook),Iqs,Iqs,_) :-
%  !.
%satisfy_dtrs_goal(when(Cond,Body),DtrCats,DtrCatsRest,when(NCond,NBody),Iqs,Iqs,NVs) :-
%  !, satisfy_dtrs_cond(Cond,NCond,Body,NBody,DtrCats,DtrCatsRest,NVs).
%satisfy_dtrs_goal((GD1 -> GD2),DtrCats,DtrCatsRest,(G1 -> G2),IqsIn,IqsOut,NVs) :-
%  !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs),
%  satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut,NVs).
%satisfy_dtrs_goal(AtGD,DtrCats,DtrCatsRest,AtG,IqsIn,IqsOut,NVs):-
%  AtGD =.. [Rel|ArgDescs],
%  same_length(ArgDescs,Args),
%  AtG =.. [Rel|Args],
%  satisfy_dtrs_goal_args(ArgDescs,DtrCats,DtrCatsRest,Args,IqsIn,IqsOut,NVs).

%satisfy_dtrs_goal_args([],DtrCats,DtrCats,[],Iqs,Iqs,_).
%satisfy_dtrs_goal_args([D|Ds],[Tag-bot|DtrCats],DtrCatsRest,[Tag-bot|Args],
%                       IqsIn,IqsOut):-
%  add_to(D,Tag,bot,IqsIn,IqsMid),
%  satisfy_dtrs_goal_args(Ds,DtrCats,DtrCatsRest,Args,IqsMid,IqsOut).


% ==============================================================================
% Pretty Printing
% [User's Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% pp_fs(FS:fs,Iqs:ineqs)
% ------------------------------------------------------------------------------
% pretty prints FS with inequations Iqs
% ------------------------------------------------------------------------------
pp_fs(FS):-
  pp_fs_col(FS,0).
pp_fs(Ref,SVs) :-
  pp_fs_col(Ref,SVs,0).

pp_fs_col(FS,N):-
  \+ \+ ( empty_assoc(AssocIn),
          duplicates(FS,AssocIn,DupsMid,AssocIn,_,0,_),
          nl,
          tab(N), pp_fs(FS,DupsMid,_,AssocIn,_,N,AssocIn,_)).
pp_fs_col(Ref,SVs,N):-
  \+ \+ ( empty_assoc(AssocIn),
          duplicates(Ref,SVs,AssocIn,DupsMid,AssocIn,_,0,_),
          nl,
          tab(N), pp_fs(Ref,SVs,DupsMid,_,AssocIn,_,N,AssocIn,_)).

pp_fs_res(Ref,SVs,Residue) :-
  pp_fs_res_col(Ref,SVs,Residue,0).

pp_fs_res_col(Ref,SVs,Residue,Col) :-
  empty_assoc(AssocIn),
  build_iqs(Residue,Iqs,FSResidue),
  (show_res -> residue_args(FSResidue,ResArgs,[Ref-SVs]) ; ResArgs = [Ref-SVs]),
  duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid),
  duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_),
  pp_fs(Ref,SVs,DupsMid2,DupsMid3,AssocIn,VisMid2,Col,AssocIn,HDMid),
  nl,nl,
  tab(Col), pp_iqs(Iqs,DupsMid3,DupsOut,VisMid2,VisOut,0,HDMid,HDOut),
  ((show_res,FSResidue\==[])
  -> nl,nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_)
  ; true
  ).

% ------------------------------------------------------------------------------
% duplicates(FS:fs, Iqs:ineqs,
%            VisIn:refs, VisOut:refs, NumIn:int, NumOut:int)
% ------------------------------------------------------------------------------
% DupsOut is the result of adding the duplicate references
% in FS and Iqs to those in DupsIn.  VisIn are those nodes already
% visited and VisOut are those visited in FS.  NumIn is
% the current number for variables and NumOut is the
% next available after numbering only the shared refs in FS.
% ------------------------------------------------------------------------------
%duplicates(FS,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :-
%  duplicates_fs(FS,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid).
%  duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut).
%duplicates(Ref,SVs,Iqs,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :-
%  duplicates_fs(Ref,SVs,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid),
%  duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut).

duplicates(FS,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):-
deref(FS,Ref,SVs),
  ( get_assoc(Ref,DupsIn,_)
    -> VisOut = VisIn, NumOut = NumIn, DupsOut = DupsIn
     ; (get_assoc(Ref,VisIn,_)
        -> put_assoc(Ref,DupsIn,NumIn,DupsOut), NumOut is NumIn + 1, VisOut = VisIn
         ; ((SVs = a_ _)
            -> put_assoc(Ref,VisIn,_,VisOut), NumOut = NumIn, DupsOut = DupsIn
             ; (SVs =.. [_|Vs],
                put_assoc(Ref,VisIn,_,VisMid),
                duplicates_list(Vs,DupsIn,DupsOut,VisMid,VisOut,NumIn,NumOut))))).
duplicates(RefIn,SVsIn,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):-
  deref(RefIn,SVsIn,Ref,SVs),
  ( get_assoc(Ref,DupsIn,_)
    -> VisOut = VisIn, NumOut = NumIn, DupsOut = DupsIn
     ; (get_assoc(Ref,VisIn,_)
        -> put_assoc(Ref,DupsIn,NumIn,DupsOut), NumOut is NumIn + 1, VisOut = VisIn
         ; ((SVs = a_ _)
            -> put_assoc(Ref,VisIn,_,VisOut), NumOut = NumIn, DupsOut = DupsIn
             ; (SVs =.. [_|Vs],
                put_assoc(Ref,VisIn,_,VisMid),
                duplicates_list(Vs,DupsIn,DupsOut,VisMid,VisOut,NumIn,NumOut))))).

duplicates_iqs([],Dups,Dups,Vis,Vis,Num,Num).
duplicates_iqs([Iq|Iqs],DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :-
  duplicates_ineq(Iq,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid),
  duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut).

duplicates_ineq(done,Dups,Dups,Vis,Vis,Num,Num).
duplicates_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):-
  duplicates(Tag1,SVs1,DupsIn,DupsMid1,VisIn,VisMid1,NumIn,NumMid1),
  duplicates(Tag2,SVs2,DupsMid1,DupsMid2,VisMid1,VisMid2,NumMid1,NumMid2),
  duplicates_ineq(Ineqs,DupsMid2,DupsOut,VisMid2,VisOut,NumMid2,NumOut).

duplicates_list([],Dups,Dups,Vis,Vis,Num,Num).
duplicates_list([V|Vs],DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):-
  duplicates(V,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid),
  duplicates_list(Vs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut).

% ------------------------------------------------------------------------------
% pp_iqs(Iqs:ineqs, VisIn:vars, VisOut:vars,Col:int)
% ------------------------------------------------------------------------------
% pretty-prints a list of inequations, indented Col columns
%-------------------------------------------------------------------------------
pp_iqs([],Dups,Dups,Vis,Vis,_,HD,HD).
pp_iqs([Iq|Iqs],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  arg(5,Iq,Ineqs),
  (Ineqs = done -> true
   ;write('(')),
  pp_ineq(Iq,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  (Ineqs = done -> true
   ;write(')')),
  (Iqs = []
   -> nl
   ; write(','),
     nl,
     pp_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut)).

% ineq(Tag1,SVs1,Tag2,SVs2,Ineqs)
pp_ineq(done,Dups,Dups,Vis,Vis,_,HD,HD).
pp_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  tab(Col),pp_fs(Tag1,SVs1,DupsIn,DupsMid1,VisIn,VisMid1,Col,HDIn,HDMid1),
  write('  =\\=  '),
  NewCol is Col+7,
  pp_fs(Tag2,SVs2,DupsMid1,DupsMid2,VisMid1,VisMid2,NewCol,HDMid1,HDMid2),
  nl,
  (Ineqs = done -> true
   ;write(';')),
  pp_ineq(Ineqs,DupsMid2,DupsOut,VisMid2,VisOut,Col,HDMid2,HDOut).

frozen_term(Term,Frozen) :-
  term_variables(Term,Vars),
  frozen_term_act(Vars,UnsortedRes),
  sort(UnsortedRes,Frozen).

frozen_term_act([],[]).
frozen_term_act([Var|Vars],Frozen) :-
  frozen(Var,Goal),
  filter_goals(Goal,Frozen,Rest,Var),
  frozen_term_act(Vars,Rest).

filter_goals(true,Rest,Rest,_) :- !.
filter_goals((G1,G2),Frozen,Rest,Var) :-
  !,filter_goals(G1,Frozen,Mid,Var),
  filter_goals(G2,Mid,Rest,Var).
filter_goals(prolog:trig_nondif(_,_,_,Trig),Frozen,Rest,_) :-
  !,frozen(Trig,Goal),
  filter_goals(Goal,Frozen,Rest,Trig).
filter_goals(prolog:trig_and(_,_,_,_,Trig),Frozen,Rest,_) :-
  !,frozen(Trig,Goal),
  filter_goals(Goal,Frozen,Rest,Trig).
filter_goals(prolog:trig_or(_,_,Trig),Frozen,Rest,_) :-
  !,frozen(Trig,Goal),
  filter_goals(Goal,Frozen,Rest,Trig).
filter_goals(G,[[Var]-G|Rest],Rest,Var).

residue_args([],Args,Args).
residue_args([_-Goal|Residue],Args,ArgsRest) :-
  resgoal_args(Goal,Args,ArgsMid),
  residue_args(Residue,ArgsMid,ArgsRest).

resgoal_args(prolog:when(_,_,user:when_eq0(FS1,Tag2,SVs2,WGoal)),
     [FS1,Tag2-SVs2|Args],ArgsRest) :-
  !,resgoal_args_wgoal(WGoal,Args,ArgsRest).
resgoal_args(prolog:when(_,_,user:when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal)),
     [Tag1-SVs1,Tag2-SVs2|Args],ArgsRest) :-
  !,resgoal_args_wgoal(WGoal,Args,ArgsRest).
resgoal_args(prolog:when(_,_,user:when_eq_a2(X1,X2,Tag1,Tag2,WGoal)),
     [Tag1-(a_ X1),Tag2-(a_ X2)|Args],ArgsRest) :-
  !,resgoal_args_wgoal(WGoal,Args,ArgsRest).
resgoal_args(prolog:when(_,_,user:when_type0(_,FS,WGoal)),Args,Rest) :-
  !,(var(FS) -> ArgsMid = Args ; Args = [FS|ArgsMid]),
  resgoal_args_wgoal(WGoal,ArgsMid,Rest).
resgoal_args(prolog:when(_,_,user:when_type_delayed0(_,Tag,SVs,WGoal)),[Tag-SVs|Args],ArgsRest) :-
  !,resgoal_args_wgoal(WGoal,Args,ArgsRest).
% Should look in WGoal too
resgoal_args(_,Args,Args).

resgoal_args_wgoal(Var,Args,ArgsRest) :-
  var(Var),
  !,ArgsRest = Args.
resgoal_args_wgoal((G1 -> G2 ; G3),Args,ArgsRest) :-
  !,resgoal_args_wgoal(G1,Args,ArgsMid),
  resgoal_args_wgoal(G2,ArgsMid,ArgsMid2),
  resgoal_args_wgoal(G3,ArgsMid2,ArgsRest).
resgoal_args_wgoal((G1 -> G2),Args,ArgsRest) :-
  !,resgoal_args_wgoal(G1,Args,ArgsMid),
  resgoal_args_wgoal(G2,ArgsMid,ArgsRest).
resgoal_args_wgoal((G1,G2),Args,ArgsRest) :-
  !,resgoal_args_wgoal(G1,Args,ArgsMid),
  resgoal_args_wgoal(G2,ArgsMid,ArgsRest).
resgoal_args_wgoal((G1;G2),Args,ArgsRest) :-
  !,resgoal_args_wgoal(G1,Args,ArgsMid),
  resgoal_args_wgoal(G2,ArgsMid,ArgsRest).
resgoal_args_wgoal(\+ G1,Args,ArgsRest) :-
  !,resgoal_args_wgoal(G1,Args,ArgsRest).
resgoal_args_wgoal(when_type(_,FS,WGoal),Args,ArgsRest) :-
  !,
  ( var(FS) -> Args = ArgsMid
  ; Args = [FS|ArgsMid]
  ),
  resgoal_args_wgoal(WGoal,ArgsMid,ArgsRest).
resgoal_args_wgoal(when_a_(_,FS,WGoal),Args,ArgsRest) :-
  !,
  ( var(FS) -> Args = ArgsMid
  ; Args = [FS|ArgsMid]
  ),
  resgoal_args_wgoal(WGoal,ArgsMid,ArgsRest).
resgoal_args_wgoal(when_eq(FS,Var,WGoal),Args,ArgsRest) :-
  !,
  ( var(FS) -> Args = ArgsMid
  ; Args = [FS|ArgsMid]
  ),
  ( var(Var) -> ArgsMid = ArgsMid2
  ; ArgsMid = [Var|ArgsMid2]
  ),
  resgoal_args_wgoal(WGoal,ArgsMid2,ArgsRest).
resgoal_args_wgoal(ud(FS1,FS2),Args,ArgsRest) :-
  !, ( var(FS1) -> Args = ArgsMid ; Args = [FS1|ArgsMid]),
  ( var(FS2) -> ArgsMid = ArgsRest ; ArgsMid = [FS2|ArgsRest]).
resgoal_args_wgoal(ud(FS1,Tag2,SVs2),Args,ArgsRest) :-
  !, ( var(FS1) -> Args = ArgsMid ; Args = [FS1|ArgsMid]),
  ( var(SVs2) -> ArgsMid = ArgsRest ; ArgsMid = [Tag2-SVs2|ArgsRest]).
resgoal_args_wgoal(ud(Tag1,SVs1,Tag2,SVs2),Args,ArgsRest) :-
  !, ( var(SVs1) -> Args = ArgsMid ; Args = [Tag1-SVs1|ArgsMid]),
  ( var(SVs2) -> ArgsMid = ArgsRest ; ArgsMid = [Tag2-SVs2|ArgsRest]).
resgoal_args_wgoal(deref(FS,_,_),Args,ArgsRest) :-
  !, (var(FS) -> Args = ArgsRest ; Args = [FS|ArgsRest]).
resgoal_args_wgoal(deref(Tag,SVs,_,_),Args,ArgsRest) :-
  !, (var(SVs) -> Args = ArgsRest ; Args = [Tag-SVs|ArgsRest]).
resgoal_args_wgoal(when_type(_,FS,WGoal),Args,ArgsRest) :-
  !, (var(FS) -> Args = ArgsMid ; Args = [FS|ArgsMid]),
  resgoal_args_wgoal(WGoal,ArgsMid,ArgsRest).
resgoal_args_wgoal(FGoal,Args,ArgsRest) :-
  FGoal =.. [FRel|FGoalArgs],
  name(FRel,FRelName),
  append("featval_",_,FRelName),
  !, FGoalArgs = [SVs,Tag,ValatF],
  ( var(SVs) -> Args = ArgsMid ; Args = [Tag-SVs|ArgsMid]),
  ( var(ValatF) -> ArgsMid = ArgsRest ; ArgsMid = [ValatF|ArgsRest]).
resgoal_args_wgoal(Goal,Args,ArgsRest) :-
  Goal =.. [_|GoalArgs],
  resgoal_args_wargs(GoalArgs,Args,ArgsRest).

resgoal_args_wargs([],Args,Args).
resgoal_args_wargs([GA|GArgs],Args,ArgsRest) :-
  ( var(GA) -> Args = ArgsMid
  ; functor(GA,-,2) -> Args = [GA|ArgsMid]
  ; Args = ArgsMid
  ),
  resgoal_args_wargs(GArgs,ArgsMid,ArgsRest).


pp_residue([],Dups,Dups,Vis,Vis,HD,HD).
pp_residue([_-Goal|Residue],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut) :-
  pp_resgoal(Goal,DupsIn,DupsMid,VisIn,VisMid,HDIn,HDMid),
  pp_residue(Residue,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut).

% pp_resgoal(prolog:trig_nondif(_,_,_,_),Dups,Dups,Vis,Vis,HD,HD) :- !.
% pp_resgoal(prolog:trig_or(_,_,_),Dups,Dups,Vis,Vis,HD,HD) :- !.
pp_resgoal(prolog:when(_,_,user:when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal)),DupsIn,DupsOut,
         VisIn,VisOut,HDIn,HDOut) :-
  !,nl, write('when_eq('),pp_fs(Tag1,SVs1,DupsIn,DupsMid,VisIn,VisMid,8,HDIn,HDMid),
  write(','), nl, write('        '),
  pp_fs(Tag2,SVs2,DupsMid,DupsMid2,VisMid,VisMid2,8,HDMid,HDMid2),
  write(','), nl, write('        '),
  pp_res_wgoal(WGoal,DupsMid2,DupsOut,VisMid2,VisOut,8,HDMid2,HDOut),
%    DupsOut = DupsMid2, VisOut = VisMid2, HDOut = HDMid2,
%    write(WGoal),
  write(')').
pp_resgoal(prolog:when(_,_,user:when_eq_a2(X1,X2,Tag1,Tag2,WGoal)),DupsIn,DupsOut,
         VisIn,VisOut,HDIn,HDOut) :-
  !,nl, write('when_eq('),pp_fs(Tag1,(a_ X1),DupsIn,DupsMid,VisIn,VisMid,8,HDIn,HDMid),
  write(','), nl, write('        '),
  pp_fs(Tag2,(a_ X2),DupsMid,DupsMid2,VisMid,VisMid2,8,HDMid,HDMid2),
  write(','), nl, write('        '),
  pp_res_wgoal(WGoal,DupsMid2,DupsOut,VisMid2,VisOut,8,HDMid2,HDOut),
%    DupsOut = DupsMid2, VisOut = VisMid2, HDOut = HDMid2,
%    write(WGoal),
  write(')').
pp_resgoal(prolog:when(_,_,user:when_type0(Type,FS,WGoal)),DupsIn,DupsOut,
         VisIn,VisOut,HDIn,HDOut) :-
  !,nl,write('when_type('),write(Type),write(','),
  name(Type,TName), length(TName,TLen),
  Col is 10+TLen,
  (var(FS) -> write(FS)
  ; pp_fs(FS,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid)
  ),
  write(','),
  nl, write('          '),
  pp_res_wgoal(WGoal,DupsMid,DupsOut,VisMid,VisOut,10,HDMid,HDOut),
%    DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid,
%    write(WGoal),
  write(')').
pp_resgoal(prolog:when(_,_,user:when_type_delayed0(Type,Tag,SVs,WGoal)),DupsIn,DupsOut,
         VisIn,VisOut,HDIn,HDOut) :-
  !,nl,write('when_type('),write(Type),write(','),
  name(Type,TName), length(TName,TLen),
  Col is 10+TLen,
  pp_fs(Tag,SVs,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','),
  nl, write('          '),
  pp_res_wgoal(WGoal,DupsMid,DupsOut,VisMid,VisOut,10,HDMid,HDOut),
%    DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid,
%    write(WGoal),
  write(')').
pp_resgoal(Goal,Dups,Dups,Vis,Vis,HD,HD) :-
  nl,write(Goal).

% query_cond/9 prefixes
pp_res_wgoal((map_assoc(nv_fresh,_,_),(_=_),query_goal0(_,_,_,NBody,_,_)),DupsIn,DupsOut,
     VisIn,VisOut,Col,HDIn,HDOut) :-
  !,pp_goal(NBody,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut).
pp_res_wgoal((map_assoc(nv_fresh,_,_),query_goal0(_,_,_,NBody,_,_)),DupsIn,DupsOut,
     VisIn,VisOut,Col,HDIn,HDOut) :-
  !,pp_goal(NBody,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut).

pp_res_wgoal((G1 -> G2 ; G3),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,pp_res_wgoal(G1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  nl, tab(Col), write(' -> '), NewCol is Col + 4,
  pp_res_wgoal(G2,DupsMid,DupsMid2,VisMid,VisMid2,NewCol,HDMid,HDMid2),
  nl, tab(Col), write(' ; '), NewCol2 is Col + 3,
  pp_res_wgoal(G3,DupsMid2,DupsOut,VisMid2,VisOut,NewCol2,HDMid2,HDOut).
pp_res_wgoal((G1,G2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,pp_res_wgoal(G1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid),
  write(','), nl, tab(Col),
  pp_res_wgoal(G2,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).
pp_res_wgoal(\+ G,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,write('\\+ ( '), NewCol is Col + 5,
  pp_res_wgoal(G,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut),
  nl, tab(Col), tab(3), write(')').

pp_res_wgoal(ud(FS1,FS2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,  NewCol is Col + 4,
  ( var(FS1) -> write(FS1), DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn
  ; pp_fs(FS1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid)
  ),
  nl, tab(Col), write('  = '),
  ( var(FS2) -> write(FS2), DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid
  ; pp_fs(FS2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut)
  ).
pp_res_wgoal(ud(FS1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,  NewCol is Col + 4,
  ( var(FS1) -> write(FS1),  DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn
  ; pp_fs(FS1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid)
  ),
  nl, tab(Col), write('  = '),
  ( var(SVs2) -> write(Tag2-SVs2), DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid
  ; pp_fs(Tag2,SVs2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut)
  ).
pp_res_wgoal(ud(Tag1,SVs1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,  NewCol is Col + 4,
  ( var(SVs1) -> write(Tag1-SVs1),  DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn
  ; pp_fs(Tag1,SVs1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid)
  ),
  nl, tab(Col), write('  = '),
  ( var(SVs2) -> write(Tag2-SVs2),  DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid
  ; pp_fs(Tag2,SVs2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut)
  ).

pp_res_wgoal(deref(FS1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('deref('), NewCol is Col + 6,
  ( var(FS1) -> write(FS1), DupsOut = DupsIn, VisOut = VisIn, HDOut = HDIn
  ; pp_fs(FS1,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut)
  ),
  write(','),nl,tab(NewCol),write(Tag2),
  write(','),nl,tab(NewCol),write(SVs2),
  write(')').
pp_res_wgoal(deref(Tag1,SVs1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !, write('deref('), NewCol is Col + 6,
  ( var(SVs1) -> write(Tag1), write(','), write(SVs1), DupsOut = DupsIn, VisOut = VisIn,
                 HDOut = HDIn
  ; pp_fs(Tag1,SVs1,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut)
  ),
  write(','),nl,tab(NewCol),write(Tag2),
  write(','),nl,tab(NewCol),write(SVs2),
  write(')').

pp_res_wgoal(when_type(Type,FS,WGoal),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  !,write('when_type('),write(Type),write(','),
  name(Type,TName), length(TName,TLen),
  NewCol is Col+10+TLen,
  (var(FS) -> write(FS), DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn
  ; pp_fs(FS,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid)
  ),
  write(','), nl, tab(Col), write('          '),
  NewCol2 is Col+10,
  pp_res_wgoal(WGoal,DupsMid,DupsOut,VisMid,VisOut,NewCol2,HDMid,HDOut), write(')').

pp_res_wgoal(CompGoal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  nonvar(CompGoal), CompGoal =.. [CompRel|Args],
  name(CompRel,CompRelName),
  append("fs_",RelName,CompRelName),
  !,name(Rel,RelName), Goal =.. [Rel|Args],
  pp_goal(Goal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut).

% everything else
pp_res_wgoal(WGoal,Dups,Dups,Vis,Vis,_,HD,HD) :-
  write(WGoal).

build_iqs(Residue,Iqs,FSResidue) :-
  empty_assoc(AssocIn),
  filter_iqs(Residue,[],IqsOut,AssocIn,IqFragsOut,AssocIn,TrigsOut,NonIqResidue),
  filter_triggers(NonIqResidue,TrigsOut,FSResidue),
  build_complex_iqs(IqsOut,IqFragsOut,Iqs).

filter_iqs([],Iqs,Iqs,IqFrags,IqFrags,Trigs,Trigs,[]).
filter_iqs([K-Goal|Residue],IqsIn,IqsOut,IqFragsIn,IqFragsOut,TrigsIn,TrigsOut,NonIqResidue) :-
  filter_iqs_resgoal(Goal,K,Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,TrigsIn,TrigsOut,NonIqResidue).

filter_iqs_resgoal(prolog:when(Trigger,(_;ground(G)),user:ineq_resolve_decomp(_,F)),_,
   Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,NonIqResidue) :-
  !,put_assoc(Trigger,Triggers,_,TrigsMid),
  G =.. [_|Keys],
  ( var(F) -> put_assoc(F,IqFragsIn,Keys,IqFragsMid), IqsMid = IqsIn
  ; IqsMid = [Keys|IqsIn], IqFragsMid = IqFragsIn  % if nonvar(F), then this is a root inequation
  ),
  filter_iqs(Residue,IqsMid,IqsOut,IqFragsMid,IqFragsOut,TrigsMid,TrigsOut,NonIqResidue).
filter_iqs_resgoal(prolog:when(Trigger,_,user:ineq_resolve_suspend(Tag1,SVs1,Tag2,SVs2,_,F)),_,
   Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,NonIqResidue) :-
  !,put_assoc(Trigger,Triggers,_,TrigsMid),
  ( var(F) -> put_assoc(F,IqFragsIn,ineq(Tag1,SVs1,Tag2,SVs2,_),IqFragsMid), IqsMid = IqsIn
  ; IqsMid = [ineq(Tag1,SVs1,Tag2,SVs2,done)|IqsIn], IqFragsMid = IqFragsIn
  ),
  filter_iqs(Residue,IqsMid,IqsOut,IqFragsMid,IqFragsOut,TrigsMid,TrigsOut,NonIqResidue).
filter_iqs_resgoal(Goal,K,Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,
   [K-Goal|NonIqResRest]) :-
  filter_iqs(Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,NonIqResRest).
     % should strip off keys here, but this is input to pp_residue/7.

filter_triggers([],_,[]).
filter_triggers([ResGoal|Residue],Triggers,FSResidue) :-
  ResGoal = _-Goal,
  filter_trigs_resgoal(Goal,ResGoal,Residue,Triggers,FSResidue).

filter_trigs_resgoal(prolog:trig_or(_,Trigger,_),ResGoal,Residue,Triggers,FSResidue) :-
  !,
  (get_assoc(Trigger,Triggers,_) -> filter_triggers(Residue,Triggers,FSResidue)
  ; FSResidue = [ResGoal|FSResRest],
    filter_triggers(Residue,Triggers,FSResRest)
  ).
filter_trigs_resgoal(prolog:trig_ground(_,_,_,Trigger,_),ResGoal,Residue,Triggers,FSResidue) :-
  !,
  (get_assoc(Trigger,Triggers,_) -> filter_triggers(Residue,Triggers,FSResidue)
  ; FSResidue = [ResGoal|FSResRest],
    filter_triggers(Residue,Triggers,FSResRest)
  ).
filter_trigs_resgoal(prolog:trig_nondif(_,_,Trigger,_),ResGoal,Residue,Triggers,FSResidue) :-
  !,
  (get_assoc(Trigger,Triggers,_) -> filter_triggers(Residue,Triggers,FSResidue)
  ; FSResidue = [ResGoal|FSResRest],
    filter_triggers(Residue,Triggers,FSResRest)
  ).
filter_trigs_resgoal(_,ResGoal,Residue,Triggers,[ResGoal|FSResRest]) :-
  filter_triggers(Residue,Triggers,FSResRest).

build_complex_iqs([],_,[]).
build_complex_iqs([IqOrList|IqOrLists],IqFrags,[Iq|Iqs]) :-
  ( functor(IqOrList,ineq,5) -> Iq = IqOrList
  ; build_complex_iqs_act(IqOrList,IqFrags,Iq,done)
  ),
  build_complex_iqs(IqOrLists,IqFrags,Iqs).

build_complex_iqs_act([],_,Rest,Rest).
build_complex_iqs_act([Key|Keys],IqFrags,Ineq,IneqRest) :-
  ( nonvar(Key) -> IneqMid = Ineq % some (but not all) disjuncts may have already failed
  ; get_assoc(Key,IqFrags,IqOrList) -> ( functor(IqOrList,ineq,5) -> Ineq = IqOrList,
                                                                     arg(5,Ineq,IneqMid)
       ; build_complex_iqs_act(IqOrList,IqFrags,Ineq,IneqMid)
       )
  ; error_msg((nl,write('inequation lost in residue')))
  ),
  build_complex_iqs_act(Keys,IqFrags,IneqMid,IneqRest).

% ------------------------------------------------------------------------------
% pp_fs(FS:fs,VisIn:vars, VisOut:vars, Col:int)
% ------------------------------------------------------------------------------
% prints FS where VisOut is the result of adding all of the
% referents of substructures in FS to VisIn
% Col is where printing begins for FS
% ------------------------------------------------------------------------------
pp_fs(FS,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  deref(FS,Ref,SVs),
  pp_fs_act(Ref,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut).

pp_fs(RefIn,SVsIn,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  deref(RefIn,SVsIn,Ref,SVs),
  pp_fs_act(Ref,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut).

pp_fs_act(Ref,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  ( SVs = (a_ _) -> Type = SVs, FRs = [], Vs = []
  ; SVs =.. [Type|Vs], approps(Type,FRs,_)
  ),
  build_keyed_feats(FRs,Vs,KeyedFeats),
  ( (current_predicate(portray_fs,portray_fs(_,_,_,_,_,_,_,_,_,_)),
     portray_fs(Type,Ref-SVs,KeyedFeats,VisIn,VisOut,DupsIn,DupsOut,Col,HDIn,HDOut))
  -> true
   ; pp_fs_default(Type,Ref,KeyedFeats,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut)
  ).

build_keyed_feats([],[],[]).
build_keyed_feats([F:Restr|FRs],[V|Vs],[fval(F,V,Restr)|KFs]) :-
  build_keyed_feats(FRs,Vs,KFs).

pp_fs_default(Type,Ref,KeyedFeats,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  ( get_assoc(Ref,DupsIn,TagNum)            % print ref if shared (nonvar)
  -> write('['), write(TagNum), write('] ')
   ; true
  ),
  ( get_assoc(Ref,VisIn,_) -> VisOut = VisIn, DupsOut = DupsIn, HDOut = HDIn
  ; (Type = a_ X) -> (no_write_type_flag(a_ X)
                     -> true
                      ; write(a_ X)
                     ),
                     put_assoc(Ref,VisIn,_,VisOut),
                     DupsOut = DupsIn, HDOut = HDIn
  ; put_assoc(Ref,VisIn,_,VisMid),     % print FS if not already visited
    ( no_write_type_flag(Type)
    -> pp_vs_unwritten(KeyedFeats,DupsIn,DupsOut,VisMid,VisOut,Col,HDIn,HDOut)
     ; write(Type),
       pp_vs(KeyedFeats,DupsIn,DupsOut,VisMid,VisOut,Col,HDIn,HDOut)
     )
  ).

% recursive callback for portray_fs
print_fs(_VarType,FS,VisIn,VisOut,TagsIn,TagsOut,Col,HDIn,HDOut) :-
  pp_fs(FS,TagsIn,TagsOut,VisIn,VisOut,Col,HDIn,HDOut).

%-------------------------------------------------------------------------------
% Write Flags
% [User's Manual]
%-------------------------------------------------------------------------------

:- dynamic no_write_type_flag/1.
:- dynamic no_write_feat_flag/1.

write_types:-
  write_type(_).

write_feats:-
  write_feat(_).

write_type(Type):-
  retractall(no_write_type_flag(Type)).

write_feat(Feat):-
  retractall(no_write_feat_flag(Feat)).

no_write_type(Type):-
  retractall(no_write_type_flag(Type)),
  assert(no_write_type_flag(Type)).

no_write_feat(Feat):-
  retractall(no_write_feat_flag(Feat)),
  assert(no_write_feat_flag(Feat)).

% ------------------------------------------------------------------------------
% pp_vs(FRs:fs, Vs:vs, Dups:vars,
%        VisIn:vars, VisOut:vars, Col:int)
% ------------------------------------------------------------------------------
% prints Vs at Col
% ------------------------------------------------------------------------------
pp_vs([],Dups,Dups,Vis,Vis,_,HD,HD).
pp_vs([fval(F,V,_)|KFs],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :-
  ( no_write_feat_flag(F) -> VisMid = VisIn, DupsMid = DupsIn, HDMid = HDIn
  ; nl, tab(Col),
    write_feature(F,LengthF),
    NewCol is Col + LengthF +1,
    pp_fs(V,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid)
  ),
  pp_vs(KFs,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).

pp_vs_unwritten([],Dups,Dups,Vis,Vis,_,HD,HD).
pp_vs_unwritten([fval(F,V,_)|KFs],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):-
  ( no_write_feat_flag(F) -> VisMid = VisIn, DupsMid = DupsIn, HDMid = HDIn
  ; write_feature(F,LengthF),
    NewCol is Col + LengthF +1,
    pp_fs(V,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid)
  ),
  pp_vs(KFs,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut).

write_feature(F,LengthF):-
  name(F,NameF),
  count_and_capitalize(NameF,0,LengthF),
  write(' ').

write_desc_feature(F,LengthF) :-
  name(F,NameF), length(NameF,LengthF),
  write(F),
  write(':').

count_and_capitalize([],Length,Length).
count_and_capitalize([L|Ls],LengthIn,Length):-
  capitalize(L,LCap),
  write(LCap),
  LengthInPlus1 is LengthIn + 1,
  count_and_capitalize(Ls,LengthInPlus1,Length).

capitalize(X,XCap):-
  ( (name(a,[Name_a]), name(z,[Name_z]),
     Name_a =< X, X =< Name_z)
    -> name('A',[Name_A]),
       Gap is Name_A - Name_a,
       NameXCap is X + Gap,
       name(XCap,[NameXCap])
     ; name(XCap,[X])
  ).


% ==============================================================================
% Utilities
% ==============================================================================

% ------------------------------------------------------------------------------
% cat_atoms/3
% ------------------------------------------------------------------------------
cat_atoms(A1,A2,A3):-
  name(A1,L1),
  name(A2,L2),
  append(L1,L2,L3),
  name(A3,L3).

% ------------------------------------------------------------------------------
% esetof(X:Alpha, Goal:goal, Xs:)
% ------------------------------------------------------------------------------
% setof returning empty list if no solutions
% ------------------------------------------------------------------------------
esetof(X,Goal,Xs) :-
  if(setof(X,Goal,Xs),
     true,
     (Xs = [])).

% ------------------------------------------------------------------------------
% member_eq(X:term, Xs:terms)
% ------------------------------------------------------------------------------
% X is strictly == equal to a member of list Xs
% ------------------------------------------------------------------------------
member_eq(X,[Y|Ys]):-
    X==Y
  ; member_eq(X,Ys).

% ------------------------------------------------------------------------------
% member_rest(Elt,List,Rest)
% ------------------------------------------------------------------------------
% like member/2 but also returns remainder of list after Elt
% ------------------------------------------------------------------------------
member_rest(Element, [Head|Tail], Rest) :-
        member_rest_act(Tail, Head, Element, Rest).
        % auxiliary to avoid choicepoint for last element
member_rest_act(Rest, Element, Element, Rest).
member_rest_act([Head|Tail], _, Element, Rest) :-
        member_rest_act(Tail, Head, Element, Rest).

% ------------------------------------------------------------------------------
% select_eq(X:term, Xs:terms, XsLeft:terms)
% ------------------------------------------------------------------------------
% X is strictly == equal to a member of list Xs with XsLeft left over
% ------------------------------------------------------------------------------
select_eq(X,[Y|Ys],Zs):-
    X==Y,
    Zs = Ys
  ; Zs = [Y|Zs2],
    select_eq(X,Ys,Zs2).

% ------------------------------------------------------------------------------
% transitive_closure(Graph:graph, Closure:graph)
% ------------------------------------------------------------------------------
% Warshall's Algorithm (O'Keefe, Craft of Prolog, p. 172)
% Input: Graph = [V1-Vs1,...,VN-VsN]
%   describes the graph G = where
%      * Vertices = {V1,..,VN} and
%      * VsI = {VJ | VI -> VJ in Edges}
% Output: Closure is transitive closure of Graph in same form
% SICStus Prolog's transitive_closure/2 will not add loops in case of
%  subsumption cycles, so we cannot use it.
% ------------------------------------------------------------------------------
transitive_closure(Graph,Closure):-
  warshall(Graph,Graph,Closure).

warshall([],Closure,Closure).
warshall([V-_|G],E,Closure):-
  memberchk(V-Y,E),
  warshall(E,V,Y,NewE),
  warshall(G,NewE,Closure).

warshall([],_,_,[]).
warshall([X-Neibs|G],V,Y,[X-NewNeibs|NewG]):-
  memberchk(V,Neibs),
  !, ord_union(Neibs,Y,NewNeibs),
  warshall(G,V,Y,NewG).
warshall([X-Neibs|G],V,Y,[X-Neibs|NewG]):-
  warshall(G,V,Y,NewG).

% ------------------------------------------------------------------------------
% reverse_count_lex_check(ListIn:list,Acc:list,ListOut:list,
%                         CountIn:int,CountOut:int)
% ------------------------------------------------------------------------------
% using accumulators, reverses ListIn into ListOut, with initial segment
% Acc;  CountIn is current count (of Acc) and CountOut is result;  call
% by: reverse_count_lex_check(ListIn,[],ListOut,0,Count).  Also verify that each
% word/member of the list has an entry in the lexicon.
% ------------------------------------------------------------------------------
reverse_count_lex_check([],Xs,Xs,Count,Count).
reverse_count_lex_check([X|Xs],Ys,Zs,CountIn,Count):-
  CountInPlus1 is CountIn+1,
  ( \+ lex(X,_) -> raise_exception(ale(unk_word(X)))
  ; reverse_count_lex_check(Xs,[X|Ys],Zs,CountInPlus1,Count)
  ).

% ------------------------------------------------------------------------------
% query_proceed
% ------------------------------------------------------------------------------
% prompts user for n. response, otherwise proceeds
% ------------------------------------------------------------------------------
query_proceed:-
  ttynl, write('ANOTHER?  '), ttyflush, read(n).

% ------------------------------------------------------------------------------
% number_display/2
% ------------------------------------------------------------------------------
number_display([],M):-
  !,write(M).  % need cut for variable 1st arguments
number_display([W|Ws],N):-
  write(N), write(' '), write(W), write(' '),
  SN is N + 1,
  number_display(Ws,SN).

% ------------------------------------------------------------------------------
% error_msg(Goal:goal)
% ------------------------------------------------------------------------------
% tells user, solves Goal, then goes back to old file being told
% ------------------------------------------------------------------------------
error_msg(Goal):-
  telling(FileName),
  tell(user),
  write('  **ERROR: '),
  Goal,
  told,
  tell(FileName),
  fail.

% ------------------------------------------------------------------------------
% if_error(Msg,Cond)
% ------------------------------------------------------------------------------
% if condition Cond holds, provides Msg as error message;  always succeeds
% ------------------------------------------------------------------------------
if_error(Msg,Cond):-
  ( call(Cond) -> raise_exception(Msg)
  ; true
  ).

% ------------------------------------------------------------------------------
% if_warning_else_fail(Msg,Cond)
% ------------------------------------------------------------------------------
% if Cond holds, provides warning message Msg, otherwise fails
% ------------------------------------------------------------------------------
if_warning_else_fail(Msg,Cond):-
  if_warning(Msg,Cond),
  Cond.

new_if_warning_else_fail(Msg,Cond):-
  if(call(Cond),
     (print_message(warning,Msg),
      fail),
     (!,fail))
  ; true.

% ------------------------------------------------------------------------------
% if_warning(Msg,Cond)
% ------------------------------------------------------------------------------
% if condition Cond holds, prints out Msg;  always succeeds
% ------------------------------------------------------------------------------
if_warning(Msg,Cond):-
  telling(FileName),
  tell(user),
  ( Cond,
    write_list(['  *Warning: '|Msg]),
    ttynl,ttynl,
    fail
  ; told,
    tell(FileName)
  ).

new_if_warning(Msg,Cond):-
  if(call(Cond),
     (print_message(warning,Msg),
      fail),
     !)
  ; true.

% ------------------------------------------------------------------------------
% write_list(Xs)
% ------------------------------------------------------------------------------
% writes out elements of Xs with spaces between elements
% ------------------------------------------------------------------------------
write_list([]).
write_list([X|Xs]):-
  write(X), write(' '), write_list(Xs).

write_list([],_).
write_list([X|Xs],Stream) :-
  write(Stream,X), write(Stream,' '),
  write_list(Xs,Stream).
% ------------------------------------------------------------------------------
% query_user(Query)
% ------------------------------------------------------------------------------
% writes Query and then tries to read a y. from user
% ------------------------------------------------------------------------------
query_user(QueryList):-
  ttynl, ttynl, write_list(QueryList),
  read(y).

% ------------------------------------------------------------------------------
% duplicated(X,Xs)
% ------------------------------------------------------------------------------
% holds if X occurs more than once in Xsd
% ------------------------------------------------------------------------------
duplicated(X,[X|Xs]):-
  member(X,Xs).
duplicated(X,[_|Xs]):-
  duplicated(X,Xs).

% ------------------------------------------------------------------------------
% feat_cycle(S:type, Fs:path)
% ------------------------------------------------------------------------------
% holds if following the path Fs in the appropriateness definitions
% leads from S to S.  calls an auxiliary function which avoids infinite
% loops and tracks the features so far followed in reverse with an accumulator
% ------------------------------------------------------------------------------
feat_cycle(S,Fs):-
  feat_cycle2(S,S,[S],[],Fs).

% ------------------------------------------------------------------------------
% feat_cycle2(S1:type)>,
%             FsIn:path, FsOut:path)
% ------------------------------------------------------------------------------
% assumes following reverse of FsIn led to S2 from S1, visiting
% Ss along the way.  FsOut is the result of appending a path that will
% get from S2 back to S1 to the reverse of FsIn
% ------------------------------------------------------------------------------
feat_cycle2(S1,S2,_Ss,FsIn,FsOut):-
  approp(F,S2,S1),
  reverse([F|FsIn],FsOut).
feat_cycle2(S1,S2,Ss,FsIn,FsOut):-
  approp(F,S2,S3),
  \+ member(S3,Ss),
  feat_cycle2(S1,S3,[S2|Ss],[F|FsIn],FsOut).


% ==============================================================================
% Generator
% [User's Manual] [Reference Manual]
% ==============================================================================

% ------------------------------------------------------------------------------
% split_dtrs(+Dtrs:dtrs, -Head:desc,
%            -SemGoalBefore:goal, -SemGoalAfter:goal,
%            -DtrsBefore:dtrs, -DtrsAfter:dtrs)
% ------------------------------------------------------------------------------
% splits the RHS of a chain rule into Head, SemGoalBefore the Head, SemGoalAfter
% the Head, DtrsBefore the Head, and DtrsAfter the Head
% ------------------------------------------------------------------------------
split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,sem_goal> SemGoalAfter,
            DtrsAfter),
           Head,SemGoalBefore,SemGoalAfter,empty,DtrsAfter) :-
  !.
split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,sem_goal> SemGoalAfter),
           Head,SemGoalBefore,SemGoalAfter,
           empty,empty) :-
  !.
split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,DtrsAfter),
           Head,SemGoalBefore,empty,empty,DtrsAfter) :-
  !.
split_dtrs((sem_goal> SemGoalBefore,sem_head> Head),
           Head,SemGoalBefore,empty,empty,empty) :-
  !.
split_dtrs((sem_head> Head,sem_goal> SemGoalAfter,DtrsAfter),
           Head,empty,SemGoalAfter,empty,DtrsAfter) :-
  !.
split_dtrs((sem_head> Head,sem_goal> SemGoalAfter),
           Head,empty,SemGoalAfter,empty,empty) :-
  !.
split_dtrs((sem_head> Head,DtrsAfter),Head,empty,empty,empty,DtrsAfter) :-
  !.
split_dtrs((sem_head> Head),Head,empty,empty,empty,empty) :-
  !.
split_dtrs((Dtr,RestDtrs),Head,SemGoalBefore,SemGoalAfter,
           (Dtr,DtrsBefore),DtrsAfter) :-
  !,split_dtrs(RestDtrs,Head,SemGoalBefore,SemGoalAfter,DtrsBefore,DtrsAfter).

% ------------------------------------------------------------------------------
% Run-time generation support
% [User's Manual]
% ------------------------------------------------------------------------------

% ------------------------------------------------------------------------------
% gen(+Cat:desc)
% gen(+Tag:tag, +SVs:svs, +Iqs:ineq)
% ------------------------------------------------------------------------------
% top-level user calls to generate a sentence from a descriptor Cat
% or a FS specified by Tag, SVs, Iqs
% ------------------------------------------------------------------------------
gen(Cat) :-
  call_residue((add_to(Cat,Tag,bot),
frozen_term(Tag,Frozen),
                ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
  portray_cat(_,Cat,Tag,bot,Frozen)) -> true
; nl, write('INITIAL CATEGORY: '), nl, ttyflush,
                  pp_fs_res(Tag,bot,Frozen), nl
),
                gen(Tag,bot,Words)),Residue),
  ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
    portray_cat(Words,Cat,Tag,bot,Residue)) -> true
  ; nl, write('STRING: '),
    nl, write_list(Words),
    \+ \+ (nl, write('FINAL CATEGORY: '),nl, ttyflush,
   pp_fs_res(Tag,bot,Residue)), nl
  ),
  query_proceed.


gen(Tag,SVs) :-
%  secret_noadderrs,
  frozen_term([Tag|SVs],Frozen),
  ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
    portray_cat(_,bot,Tag,SVs,Frozen)) -> true
  ; nl, write('INITIAL CATEGORY: '), nl, ttyflush,
    pp_fs_res(Tag,SVs,Frozen), nl
  ),
  call_residue(gen(Tag,SVs,Words),Residue),
  ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)),
    portray_cat(Words,bot,Tag,SVs,Residue)) -> true
  ; nl, write('STRING: '),
    nl, write_list(Words),
    \+ \+ (nl, write('FINAL CATEGORY: '),nl, ttyflush,
           pp_fs_res(Tag,SVs,Residue)), nl
  ),
  query_proceed.
%,
%  secret_adderrs


% ------------------------------------------------------------------------------
% gen/4
% gen(+Tag:tag, +SVs:svs, +IqsIn:ineqs, -Words:words)
% [User's Manual]
% ------------------------------------------------------------------------------
% top-level functional interface for the generator
% generates the list of Words from the semantic specification of Tag-SVs,Iqs
% ------------------------------------------------------------------------------
gen(Tag,SVs,Words) :-
%  fully_deref_prune(Tag,SVs,NewTag,NewSVs,IqsIn,IqsPrunned),
  generate(Tag,SVs,Words,[]),
  deref(Tag,SVs,TagOut,SVsOut),
  extensionalise(TagOut,SVsOut).

% ------------------------------------------------------------------------------
% generate(+Tag:tag, +SVs:svs, +IqsIn:ineqs, -IqsOut:ineqs,
%          +Words:words, +RestWords:words)
% ------------------------------------------------------------------------------
% recursively generates the difference list Words-RestWords from the root
% Tag-SVs,IqsIn
% ------------------------------------------------------------------------------
generate(Tag,SVs,Words,RestWords) if_h
    [GoalIndex,GoalPivot,
     non_chain_rule(PivotTag,bot,Tag,SVs,Words,RestWords)] :-
  semantics(Pred),
  cat_atoms('fs_',Pred,CompiledPred),
  functor(GoalIndex,CompiledPred,2),
  arg(1,GoalIndex,Tag-SVs),
  arg(2,GoalIndex,IndexTag-bot),
  functor(GoalPivot,CompiledPred,2),
  arg(1,GoalPivot,PivotTag-bot),
  arg(2,GoalPivot,IndexTag-bot).

% ------------------------------------------------------------------------------
% generate_list(+Sort:sort, +Vs:vs, +IqsIn:ineqs, -IqsOut:ineqs,
%               -Words:words, +RestWords:words)
% ------------------------------------------------------------------------------
% generates a list of words Words-RestWords from a variable list of descriptions
% Sort(Vs)
% ------------------------------------------------------------------------------
generate_list(e_list,_,Words,Words) :-
  !.
generate_list(Sort,[HdFS,TlFS],Words,RestWords) :-
  sub_type(ne_list,Sort),
  !,deref(HdFS,DtrTag,DtrSVs),
  generate(DtrTag,DtrSVs,Words,MidWords),
  deref(TlFS,_,TlSVs), TlSVs =.. [TlSort|TlVs],
  generate_list(TlSort,TlVs,MidWords,RestWords).
generate_list(Sort,_,_,_) :-
  error_msg((nl,write('error: cats> value with sort, '),write(Sort),
            write(' is not a valid argument (e_list or ne_list)'))).


% ------------------------------------------------------------------------------
% Compiler
% ------------------------------------------------------------------------------

:- dynamic current_chain_length/1.
current_chain_length(4).

% ------------------------------------------------------------------------------
% chain_length(N:int)
% ------------------------------------------------------------------------------
% asserts chain_length/1 to N -- controls depth of chain rules application
% ------------------------------------------------------------------------------
chain_length(N):-
  retractall(current_chain_length(_)),
  assert(current_chain_length(N)).

% ------------------------------------------------------------------------------
% non_chain_rule(+PivotTag:tag,
%                +PivotSVs:svs, +RootTag:tag, +RootSVs:svs,
%                +IqsIn:ineqs, -IqsOut:ineqs,
%                -Words:words, -RestWords:words)
% ------------------------------------------------------------------------------
% compiles nonheaded grammar rules, lexical entries and empty categories into
% non_chain_rule predicates which unifies the mother against the
% PivotTag-PivotSVs FS, generates top-down the RHS, and connects the mother FS
% to the next chain rule
% the result Words-RestWords is the final list of words which includes the list
% NewWords-RestNewWords corresponding to the expansion of the current rule
% ------------------------------------------------------------------------------
non_chain_rule(_,_,_,_,_,_) if_b [fail] :-
  (current_predicate(empty,empty(_)) -> \+ empty(_) ; true),
  (current_predicate('--->',(_ ---> _)) -> \+ (_ ---> _) ; true),
  (current_predicate(rule,(_ rule _)) -> \+ (_ rule _) ; true).
non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs,
               Words,RestWords) if_b SubGoals :-
  current_predicate(empty,empty(_)),
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  empty(Desc),
  compile_desc(Desc,PivotTag,PivotSVs,SubGoals,
               [current_chain_length(Max),
                \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs),
                chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,
                        Words,Words,Words,RestWords)],true,VarsIn,_,
                        _FSPal,[],FSsOut,NVs),
  FSsOut = [].
%  build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsMid,non_chain_rule).
non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs,
               Words,RestWords) if_b SubGoals :-
(secret_noadderrs,fail % turn off adderrs for lexical compilation
; current_predicate('--->', (_ ---> _)),
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  (WordStart ---> DescOrGoalStart),
  ( var(DescOrGoalStart) -> DescStart = DescOrGoalStart, GoalStart = true
  ; functor(DescOrGoalStart,goal,2) -> arg(1,DescOrGoalStart,DescStart),
                                       arg(2,DescOrGoalStart,GoalStart)
  ; DescStart = DescOrGoalStart, GoalStart = true
  ),
  curr_lex_rule_depth(LRMax),
  gen_lex_close(0,LRMax,WordStart,DescStart,GoalStart,WordOut,DescOut,GoalOut),
%  SubGoalsMid = [lex_goal(_-(a_ WordOut),PivotTag-PivotSVs)|SubGoalsMid2],
  compile_desc(DescOut,PivotTag,PivotSVs,SubGoals,
               [current_chain_length(Max),
                \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs),
                chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,
                           [WordOut|NewWords],NewWords,Words,
                           RestWords)
       |SubGoalsMid],true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs),
  compile_body(GoalOut,SubGoalsMid,[],true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs),
  FSsOut = []
%  build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsFinal,non_chain_rule)
; secret_adderrs,fail).  % turn on again
non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs,
               Words,RestWords) if_b PGoals :-
  current_predicate(rule, (_ rule _)),
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  (_RuleName rule Mother ===> Dtrs),
  \+ split_dtrs(Dtrs,_,_,_,_,_),  % i.e., not a chain rule
  compile_desc(Mother,PivotTag,PivotSVs,
               PGoals,[current_chain_length(Max),
                          \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs)
                      |PGoalsDtrs],true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs),
  compile_gen_dtrs(Dtrs,HeadWords,RestHeadWords,PGoalsDtrs,
                   [chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs,
                               HeadWords,RestHeadWords,Words,
                               RestWords)],true,VarsMid,_,FSPal,FSsMid,FSsOut),
  FSsOut = [].
%  build_fs_palette(FSsOut,FSPal,PGoals,PGoalsMid,non_chain_rule).

% ------------------------------------------------------------------------------
% chain_rule(+PivotTag:tag, +PivotSVs:svs, +RootTag:tag, +RootSVs:svs,
%            +IqsIn:ineqs, -IqsOut:ineqs, +HeadWords:words,
%            +RestHeadWords:words, -Words:words, RestWords:words)
% ------------------------------------------------------------------------------
% compiles headed grammar rules into chain_rule predicates which unify the head
% agains the PivotTag-PivotSVS FS, generates top-down the rest of the RHS,
% and connects the mother FS to the next chain rule
% the result is the list Words-RestWords which includes the sublist
% HeadWords-RestHeadWords corresponding to the head
% ------------------------------------------------------------------------------
chain_rule(_,_,PivotTag,PivotSVs,RootTag,RootSVs,  % keep this clause
    Words,RestWords,Words,RestWords) if_b          % first after multi-hashing
  [ud(PivotTag,PivotSVs,RootTag,RootSVs)].
chain_rule(N,Max,PivotTag,PivotSVs,RootTag,RootSVs,
           HeadWords,RestHeadWords,Words,RestWords) if_b
  [N < Max|PGoalsSG] :-
  current_predicate(rule,(_ rule _)),
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  (_RuleName rule Mother ===> Dtrs),
  split_dtrs(Dtrs,Head,SGBefore,SGAfter,DtrsBefore,DtrsAfter),
  (SGBefore == empty
  -> PGoalsHead = PGoalsSG, VarsMid = VarsIn,
     FSsMid = []
   ; compile_body(SGBefore,PGoalsSG,PGoalsHead,true,
                  VarsIn,VarsMid,FSPal,[],FSsMid,NVs)),
  compile_desc(Head,PivotTag,PivotSVs,PGoalsHead,PGoalsMother,true,VarsMid,
            VarsMid2,FSPal,FSsMid,FSsMid2,NVs),
  (SGAfter == empty
  -> PGoalsSGAfter = PGoalsMother, VarsMid3=VarsMid2,
     FSsMid3 = FSsMid2
   ; compile_body(SGAfter,PGoalsMother,PGoalsSGAfter,
                  true,VarsMid2,VarsMid3,FSPal,FSsMid2,FSsMid3,NVs)),
  compile_desc(Mother,MotherTag,bot,PGoalsSGAfter,
               [SN is N + 1,
                \+ \+ chained(SN,Max,MotherTag,bot,RootTag,RootSVs)
               |PGoalsLeft],true,VarsMid3,VarsMid4,FSPal,FSsMid3,FSsMid4,NVs),
  compile_gen_dtrs(DtrsBefore,NewWords,HeadWords,
                   PGoalsLeft,PGoalsRight,true,VarsMid4,VarsMid5,FSPal,FSsMid4,
                   FSsMid5),
  compile_gen_dtrs(DtrsAfter,RestHeadWords,RestNewWords,PGoalsRight,
                   [chain_rule(SN,Max,MotherTag,bot,RootTag,RootSVs,
                               NewWords,RestNewWords,Words,
                               RestWords)],true,VarsMid5,_,FSPal,FSsMid5,FSsOut),
  FSsOut = [].
%  build_fs_palette(FSsOut,FSPal,PGoalsSG,PGoalsSGBefore,chain_rule).

% ------------------------------------------------------------------------------
% compile_gen_dtrs(+Dtrs:desc, +IqsIn:ineqs, -IqsOut:ineqs,
%                  -Words:words, -RestWords:words,
%                  -Goals:goals, -GoalsRest:goals, +VarsIn:avl,
%                  -VarsOut:avl, +FSPal:var, +FSsIn:fss, -FSsOut:fss)
% ------------------------------------------------------------------------------
% compiles the top-down expansion of a sequence Dtrs of RHS items
% (daughters or goals)
% ------------------------------------------------------------------------------
compile_gen_dtrs(empty,Words,Words,PGoals,PGoals,_,Vars,Vars,_,FSs,
                 FSs) :-
  !.
compile_gen_dtrs((cat> Dtr),Words,RestWords,
                 PGoalsDtr,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,bot,PGoalsDtr,
               [generate(Tag,bot,Words,RestWords)
               |PGoalsRest],CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_gen_dtrs((cat> Dtr,RestDtrs),Words,RestWords,
                 PGoalsDtr,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtr,Tag,bot,PGoalsDtr,
               [generate(Tag,bot,Words,WordsMid)
               |PGoalsDtrs],CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_gen_dtrs(RestDtrs,WordsMid,RestWords,
                   PGoalsDtrs,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,FSsMid,
                   FSsOut).
compile_gen_dtrs((goal> Goal),Words,Words,
                 PGoalsBody,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoalsBody,PGoalsRest,CBSafe,VarsIn,
               VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_gen_dtrs((goal> Goal,RestDtrs),Words,RestWords,
                 PGoalsBody,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_body(Goal,PGoalsBody,PGoalsDtrs,CBSafe,VarsIn,
               VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_gen_dtrs(RestDtrs,Words,RestWords,
                   PGoalsDtrs,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,FSsMid,
                   FSsOut).
compile_gen_dtrs((cats> Dtrs),Words,RestWords,
                 PGoalsDtrs,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtrs,Tag,bot,PGoalsDtrs,
               [deref(Tag,bot,_,SVs),
                SVs =.. [Sort|Vs],
                generate_list(Sort,Vs,Words,RestWords)
               |PGoalsRest],CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs).
compile_gen_dtrs((cats> Dtrs,RestDtrs),Words,RestWords,
                 PGoalsDtrs,PGoalsRest,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :-
  !, empty_assoc(NVs),
  compile_desc(Dtrs,Tag,bot,PGoalsDtrs,
               [deref(Tag,bot,_,SVs),
                SVs =.. [Sort|Vs],
                generate_list(Sort,Vs,Words,NewWords)
               |PGoalsRestDtrs],CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs),
  compile_gen_dtrs(RestDtrs,NewWords,RestWords,
                   PGoalsRestDtrs,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,FSsMid,
                   FSsOut).

% ------------------------------------------------------------------------------
% chained(+PivotTag:tag, +PivotSVs:svs, +RootTag:tag,
%         +RootSVs:svs, +IqsIn:ineqs, -IqsOut:ineqs)
% ------------------------------------------------------------------------------
% checks whether PivotTag-PivotSVs and RootTag-RootSVs can be connected through
% a chain of grammar rules
% ------------------------------------------------------------------------------
chained(_,_,PivotTag,PivotSVs,RootTag,RootSVs) if_b    % keep this clause
  [ud(PivotTag,PivotSVs,RootTag,RootSVs)].    % first after multi-hashing
chained(N,Max,PivotTag,PivotSVs,RootTag,RootSVs) if_b [N<Max|PGoals] :-
  current_predicate(rule,(_ rule _)),
  empty_assoc(VarsIn),
  empty_assoc(NVs),
  (_Rule rule Mother ===> Body),
  split_dtrs(Body,HeadIn,_,_,_,_),
  compile_desc(HeadIn,PivotTag,PivotSVs,PGoals,PGoalsPivot,true,VarsIn,
               VarsMid,FSPal,[],FSsMid,NVs),
  compile_desc(Mother,NewPTag,bot,PGoalsPivot,
               [SN is N + 1,
                chained(SN,Max,NewPTag,bot,RootTag,RootSVs)],
               true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs),
  FSsOut = [].
%  build_fs_palette(FSsOut,FSPal,PGoals,PGoalsMid,chained).

% ------------------------------------------------------------------------------
% gen_lex_close(+N:int, +Max:int, +WordIn:word, +MotherIn:desc,
%               -WordOutword, -MotherOut:desc,
%               +IqsIn:ineqs, -IqsOut:ineqs)
% ------------------------------------------------------------------------------
% computes the closure of lexical entries under lexical rules to get additional
% lexical grammar rules MotherOut ===> DtrsOut
% ------------------------------------------------------------------------------
gen_lex_close(_,_,Word,Desc,Goal,Word,Desc,Goal).
gen_lex_close(N,Max,WordStart,DescStart,GoalStart,WordEnd,DescEnd,GoalEnd) :-
  current_predicate(lex_rule,(_ lex_rule _)),
  N < Max,
  add_to(DescStart,TagIn,bot),
  ( (_RuleName lex_rule DescOrGoalIn **> DescOrGoalOut morphs Morphs),
    Cond = true
  ; (_RuleName lex_rule DescOrGoalIn **> DescOrGoalOut if Cond morphs Morphs)
  ),
  ( var(DescOrGoalIn) -> DescIn = DescOrGoalIn
  ; functor(DescOrGoalIn,goal,2) -> arg(1,DescOrGoalIn,DescIn),
                                    arg(2,DescOrGoalIn,GoalStart)
  ; DescIn = DescOrGoalIn
  ),
  ( var(DescOrGoalOut) -> DescOut = DescOrGoalOut, GoalOut = true
  ; functor(DescOrGoalOut,goal,2) -> arg(1,DescOrGoalOut,DescOut),
                                     arg(2,DescOrGoalOut,GoalOut)
  ; DescOut = DescOrGoalOut, GoalOut = true
  ),
  deref(TagIn,bot,DTagIn,DSVs),
  add_to(DescIn,DTagIn,DSVs),
  query_goal(Cond),
%  call(Goal), --- query_goal/1 now calls its Goal
  morph(Morphs,WordStart,WordOut),
  SN is N + 1,
  gen_lex_close(SN,Max,WordOut,DescOut,GoalOut,WordEnd,DescEnd,GoalEnd).

% ------------------------------------------------------------------------------

% 5/15/96 - Octav -- changed to display the new version and add the banner to
% the version/0 message
:- nl,write('
ALE Version 3.3 alpha; December, 2001
Copyright (C) 1992-1995, Bob Carpenter and Gerald Penn
Copyright (C) 1998,1999,2001,2002,2003 Gerald Penn
All rights reserved'),nl,
   nointerp,
   nosubtest,
   parse, hide_residue,
   assert(lexicon_consult).

%to_file(File) :-
%  bagof(e(I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName),
%        edge(I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName),
%        Es),
%  tell(File),
%  to_file_act(Es),
%  nl,told.

%to_file_act([]).
%to_file_act([e(I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName)|Es]) :-
%  write('edge('),write(I),comma,write(Left),comma,write(Right),comma,
%  write(Tag),comma,write(SVs),comma,write(Iqs),comma,write(Dtrs),comma,
%  write(RuleName),write(').'),
%  nl,to_file_act(Es).

%comma :- write(',').

%same(A, B) :-
%        edge(A, C, D, E, F, G, _,_),
%        edge(B, C, D, E, F, G, _,_).

%subfind(I,J,LReln,RReln) :-
%  edge(I,Left,Right,Tag,SVs,Iqs,_,_),
%  edge(J,Left,Right,STag,SSVs,SIqs,_,_),
%  subsume([s(Tag,SVs,STag,SSVs)],Iqs,SIqs,<,>,LReln,RReln,[],[]),
%  comparable(LReln,RReln).

%comparable(LReln,RReln) :-
%  (LReln \== #,! ; RReln \== #).

% [269,266,263,260,220,214,177,171]

subsume(Desc1,Desc2,LReln,RReln) :-
  call_residue((add_to(Desc1,Tag1,bot),
                fully_deref(Tag1,bot,DTag1,DSVs1)),Residue1),
  call_residue((add_to(Desc2,Tag2,bot),
                fully_deref(Tag2,bot,DTag2,DSVs2)),Residue2),
  empty_assoc(H),
  empty_assoc(K),
  build_iqs(Residue1,Iqs1,_),
  build_iqs(Residue2,Iqs2,_),
  subsume(s(DTag1,DSVs1,DTag2,DSVs2,sdone),<,>,LReln,RReln,H,K,Iqs1,Iqs2).