ALE/TRALE -- Attribute Logic Engine

% [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,