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,Clause,ArgNo). samrunh_no_dups(>,Head,Tail,Run,_,[],Run,[Head|Tail],_,_). % ------------------------------------------------------------------------------ % merge_no_dups/5 % ------------------------------------------------------------------------------ % like SICStus ord_union/3 but warns on duplicates % ------------------------------------------------------------------------------ merge_no_dups([],Set,Set,_,_). merge_no_dups([O|Os],Ns,Set,Clause,ArgNo) :- merge_no_dups(Ns,O,Os,Set,Clause,ArgNo). merge_no_dups([],O,Os,[O|Os],_,_). merge_no_dups([N|Ns],O,Os,Set,Clause,ArgNo) :- compare(C,O,N), merge_no_dups(C,O,Os,N,Ns,Set,Clause,ArgNo). merge_no_dups(<,O1,Os,N,Ns,[O1|Set],Clause,ArgNo) :- merge_no_dups(Os,N,Ns,Set,Clause,ArgNo). merge_no_dups(=,_,Os,N,Ns,[N|Set],Clause,ArgNo) :- (duplicate_types(N,Clause,ArgNo) warning), merge_no_dups(Os,Ns,Set,Clause,ArgNo). merge_no_dups(>,O,Os,N1,Ns,[N1|Set],Clause,ArgNo) :- merge_no_dups(Ns,O,Os,Set,Clause,ArgNo). % ------------------------------------------------------------------------------ % strip_subs(+MarkedSortedSubs,-SortedSubLHSs,-SortedSubs,-SortedSubIntros) % ------------------------------------------------------------------------------ % This predicate triages MarkedSortedSubs into sub/2 declarations with % (SortedSubIntros) and without (SortedSubs) the optional intro/2 modifier. % SortedSubLHSs is a list of the types that occur on the LHS of either kind % of declaration but are not found on the RHS of a sub/2 declaration. % ------------------------------------------------------------------------------ strip_subs([],[],[],[]). strip_subs([TS-MRHS|MSSubs],SubLHSs,[TS-Ss|Subs],SubIntros) :- ( functor(MRHS,intro,2) -> arg(1,MRHS,Ss), arg(2,MRHS,FRs), SubIntros = [TS-FRs|SubIntrosRest] ; MRHS = Ss, SubIntros = SubIntrosRest ), ale(unary_branch(TS,U)) new_if_warning (Ss = [U]), ( clause(sub_rhstype(TS),true) -> SubLHSs = SubLHSsRest ; TS = bot -> SubLHSs = SubLHSsRest ; SubLHSs = [TS|SubLHSsRest] ), strip_subs(MSSubs,SubLHSsRest,Subs,SubIntrosRest). % ------------------------------------------------------------------------------ % strip_keys(+KeyedList,-List) % ------------------------------------------------------------------------------ % List is KeyedList without its keys. % ------------------------------------------------------------------------------ strip_keys([],[]). strip_keys([T-_|KeySs],LHSs) :- ( clause(sub_rhstype(T),true) -> LHSs = LHSsRest ; LHSs = [T|LHSsRest] ), strip_keys(KeySs,LHSsRest). % ------------------------------------------------------------------------------ % defmax(?Max) % ------------------------------------------------------------------------------ % Max is a default maximally specific type. % ------------------------------------------------------------------------------ defmax(Max) :- current_predicate(sub,(_ sub _)) -> ( clause(sub_rhstype(Max),true) ; clause(ext_or_intro_rhstype(Max),true) ; current_predicate(intro,_ intro _) -> Max intro _ ), \+ (Max sub _) ; ( clause(sub_rhstype(Max),true) ; clause(ext_or_intro_rhstype(Max),true) ; current_predicate(intro,_ intro _) -> Max intro _ ). % ------------------------------------------------------------------------------ % no_duplicates_ksorted(+KeyedList,dup(-K1,-K2,-RHS1,-RHS2,?Arg1,?Arg2,+ArgBindGoal, % +Warning,+Exception)) % ------------------------------------------------------------------------------ % For every pair of adjacent keys on KeyedList, K1 and K2, with right-hand-sides % RHS1 and RHS2, if K1 = K2 and ArgBindGoal is true, then Warning is issued (if % Arg1 and Arg2 are variants) or Exception is raised (not variants). Typically, % ArgBindGoal, Warning and Exception contain one or more of K1, K2, RHS1, RHS2, % Arg1 or Arg2 upon invocation. % ------------------------------------------------------------------------------ no_duplicates_ksorted([],_). no_duplicates_ksorted([T-RHS|Ks],Dup) :- no_duplicates_ksorted_act(Ks,T,RHS,Dup). no_duplicates_ksorted_act([],_,_,_). no_duplicates_ksorted_act([T2-RHS2|Ks],T1,RHS1,Dup) :- T1 = T2 -> \+ \+ (Dup = dup(T1,T2,RHS1,RHS2,Arg1,Arg2,ArgBindGoal,Warning,Exception), call(ArgBindGoal), ( Warning new_if_warning_else_fail variant(Arg1,Arg2) -> true ; raise_exception(Exception) ) ) ; no_duplicates_ksorted_act(Ks,T2,RHS2,Dup). % ------------------------------------------------------------------------------ % exactly_once(-Sol,+Goal,-AllSolutions,+Exception) % ------------------------------------------------------------------------------ % Goal succeeds exactly once with Sol. If it does not succed, then fail. If % it succeeds more than once, then AllSolutions are the solutions and Exception % is raised. % ------------------------------------------------------------------------------ % fail if 0, succeed if 1, throw exception if >1. exactly_once(Sol,Goal,AllSols,Exception) :- findall(Sol,call(Goal),AllSols), ( AllSols == [] -> fail ; AllSols = [Sol] -> true ; raise_exception(Exception) ). % ------------------------------------------------------------------------------ % num_types(+Types,+In:int,-Out:int) % ------------------------------------------------------------------------------ % Types is sorted in topological order. Its members are assigned the integers % from In (inclusive) to Out (exclusive). % ------------------------------------------------------------------------------ num_types([],N,N). num_types([T|Types],NIn,NOut) :- assert(type_num(T,NIn)), assert(num_type(NIn,T)), NMid is NIn + 1, num_types(Types,NMid,NOut). % ============================================================================== % ZCQ MATRIX ARITHMETIC % [User's Manual] [Reference Manual] % ============================================================================== % ------------------------------------------------------------------------------ % seed_refl_close_zmatrix(+RowGraph,+Dim,-ZM) % ------------------------------------------------------------------------------ % Build a Dim x Dim ZCQ matrix from its row-indexed representation, and % reflexively close it. % ------------------------------------------------------------------------------ seed_refl_close_zmatrix([],_,_). seed_refl_close_zmatrix([T-Neibs|GraphRest],Dim,ZM) :- clause(type_num(T,N),true), seed_elt_zcu(N,N,Dim,ZM), % reflexive closure occurs here seed_row_zmatrix(Neibs,N,GraphRest,Dim,ZM). seed_row_zmatrix([],_,GraphRest,Dim,ZM) :- seed_refl_close_zmatrix(GraphRest,Dim,ZM). seed_row_zmatrix([T|Neibs],N,GraphRest,Dim,ZM) :- clause(type_num(T,M),true), seed_elt_zcu(N,M,Dim,ZM), seed_row_zmatrix(Neibs,N,GraphRest,Dim,ZM). % ------------------------------------------------------------------------------ % seed_elt_zcu(+I,+J,+Dim,?ZM) % ------------------------------------------------------------------------------ % Place a 1 in ZM[I,J]. ZM is Dim x Dim. % Preconditions: 1) 1 <= I <= Dim, % and 2) 1 <= J <= Dim. % ------------------------------------------------------------------------------ seed_elt_zcu(1,J,Dim,ZM) :- !,seed_elt_zcu1(J,Dim,ZM). seed_elt_zcu(I,J,Dim,zcu(A,B,C)) :- D2 is (Dim+1) >> 1, ( I > D2 -> NewI is I - D2, NewJ is J - D2, NewDim is Dim - D2, seed_elt_zcu(NewI,NewJ,NewDim,C) ; J > D2 -> NewJ is J - D2, CDim is Dim - D2, seed_elt_zmatrix(I,NewJ,D2,CDim,B) ; seed_elt_zcu(I,J,D2,A) ). seed_elt_zcu1(1,Dim,ZM) :- !,seed_origin_zcu(Dim,ZM). seed_elt_zcu1(J,Dim,zcu(A,B,_)) :- D2 is (Dim+1) >> 1, ( J > D2 -> NewJ is J - D2, CDim is Dim - D2, seed_elt_zmatrix1(NewJ,D2,CDim,B) ; seed_elt_zcu1(J,D2,A) ). seed_origin_zcu(1,1) :- !. seed_origin_zcu(Dim,zcu(A,_,_)) :- NewDim is (Dim+1) >> 1, seed_origin_zcu(NewDim,A). % ------------------------------------------------------------------------------ % seed_elt_zmatrix(I,J,RDim,CDim,ZM) % ------------------------------------------------------------------------------ % Place a 1 in ZM[I,J]. ZM is a RDim x Cdim submatrix. % Preconditions: 1) 1 <= I <= RDim, % 2) 1 <= J <= CDim, % and 3) either RDim==CDim or they differ by 1 % ------------------------------------------------------------------------------ seed_elt_zmatrix(1,J,RDim,CDim,ZM) :- !,seed_elt_zmatrix1(J,RDim,CDim,ZM). seed_elt_zmatrix(2,J,RDim,CDim,ZM) :- !,seed_elt_zmatrix2(J,RDim,CDim,ZM). seed_elt_zmatrix(I,J,RDim,CDim,zcm(A,B,D,C)) :- RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, ( I > RD2 -> ( J > CD2 -> NewI is I - RD2, NewJ is J-CD2, NewRDim is RDim - RD2, NewCDim is CDim - CD2, seed_elt_zmatrix(NewI,NewJ,NewRDim,NewCDim,C) ; NewI is I - RD2, NewRDim is RDim - RD2, seed_elt_zmatrix(NewI,J,NewRDim,CD2,D) ) ; J > CD2 -> NewJ is J - CD2, NewCDim is CDim - CD2, seed_elt_zmatrix(I,NewJ,RD2,NewCDim,B) ; seed_elt_zmatrix(I,J,RD2,CD2,A) ). seed_elt_zmatrix1(1,RDim,CDim,ZM) :- !,seed_origin_zmatrix(RDim,CDim,ZM). seed_elt_zmatrix1(2,RDim,CDim,ZM) :- !,seed_elt_zmatrix12(RDim,CDim,ZM). seed_elt_zmatrix1(J,RDim,CDim,zcm(A,B,_,_)) :- RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, ( J > CD2 -> NewJ is J - CD2, NewCDim is CDim - CD2, seed_elt_zmatrix1(NewJ,RD2,NewCDim,B) ; seed_elt_zmatrix1(J,RD2,CD2,A) ). seed_elt_zmatrix2(1,RDim,CDim,ZM) :- !,seed_elt_zmatrix21(CDim,RDim,ZM). % swap column and row dimensions seed_elt_zmatrix2(2,RDim,CDim,ZM) :- !,seed_elt_zmatrix22(RDim,CDim,ZM). seed_elt_zmatrix2(3,RDim,CDim,ZM) :- !,seed_elt_zmatrix23(RDim,CDim,ZM). seed_elt_zmatrix2(J,RDim,CDim,zcm(A,B,_,_)) :- % J > 3, so CDim > 3, so RDim > 2 RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, ( J > CD2 -> NewJ is J - CD2, NewCDim is CDim - CD2, seed_elt_zmatrix2(NewJ,RD2,NewCDim,B) ; seed_elt_zmatrix2(J,RD2,CD2,A) ). % column and row dimensions swapped seed_elt_zmatrix21(1,_2,zc21(_,1)) :- !. seed_elt_zmatrix21(2,RDim,ZM) :- !,seed_elt_zmatrix21_x2(RDim,ZM). seed_elt_zmatrix21(3,RDim,ZM) :- !,seed_elt_zmatrix21_x3(RDim,ZM). seed_elt_zmatrix21(CDim,RDim,zcm(A,_,_,_)) :- % CDim > 3, so RDim > 2 RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, seed_elt_zmatrix21(CD2,RD2,A). seed_elt_zmatrix21_x2(2,zcm(_,_,1,_)). seed_elt_zmatrix21_x2(3,zcm(zc21(_,1),_,_,_)). seed_elt_zmatrix21_x3(2,zcm(_,_,zc12(1,_),_)) :- !. seed_elt_zmatrix21_x3(_3or4,zcm(zcm(_,_,1,_),_,_,_)). seed_elt_zmatrix22(2,CDim,ZM) :- !,seed_elt_zmatrix22_2(CDim,ZM). seed_elt_zmatrix22(3,CDim,ZM) :- !,seed_elt_zmatrix22_3(CDim,ZM). seed_elt_zmatrix22(RDim,CDim,zcm(A,_,_,_)) :- % RDim > 3, so CDim > 2 RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, seed_elt_zmatrix22(RD2,CD2,A). seed_elt_zmatrix22_2(2,zcm(_,_,_,1)). seed_elt_zmatrix22_2(3,zcm(_,_,zc12(_,1),_)). seed_elt_zmatrix22_3(2,zcm(_,zc21(_,1),_,_)) :- !. seed_elt_zmatrix22_3(_3or4,zcm(zcm(_,_,_,1),_,_,_)). seed_elt_zmatrix23(2,_3,zcm(_,_,_,1)) :- !. % probably should have column-indexed seed_elt_zmatrix23(3,CDim,ZM) :- % this one like seed_elt_zmatrix21/3. !,seed_elt_zmatrix23_3(CDim,ZM). seed_elt_zmatrix23(4,CDim,ZM) :- !,seed_elt_zmatrix23_4(CDim,ZM). seed_elt_zmatrix23(5,CDim,ZM) :- !,seed_elt_zmatrix23_5(CDim,ZM). seed_elt_zmatrix23(RDim,CDim,zcm(A,_,_,_)) :- % RDim > 5, so CDim > 4 RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, seed_elt_zmatrix23(RD2,CD2,A). seed_elt_zmatrix23_3(3,zcm(_,zc21(_,1),_,_)). seed_elt_zmatrix23_3(4,zcm(_,zcm(_,_,1,_),_,_)). seed_elt_zmatrix23_4(3,zcm(_,zc21(_,1),_,_)). seed_elt_zmatrix23_4(4,zcm(_,zcm(_,_,1,_),_,_)). seed_elt_zmatrix23_4(5,zcm(zcm(_,_,_,1),_,_,_)). seed_elt_zmatrix23_5(4,zcm(_,zcm(zc21(_,1),_,_,_),_,_)) :- !. seed_elt_zmatrix23_5(_5or6,zcm(zcm(_,zc21(_,1),_,_),_,_,_)). seed_origin_zmatrix(1,CDim,ZM) :- !,seed_origin_zmatrix1(CDim,ZM). seed_origin_zmatrix(2,CDim,ZM) :- !,seed_origin_zmatrix2(CDim,ZM). seed_origin_zmatrix(RDim,CDim,zcm(A,_,_,_)) :- NewRDim is (RDim+1) >> 1, NewCDim is (CDim+1) >> 1, seed_origin_zmatrix(NewRDim,NewCDim,A). seed_origin_zmatrix1(1,1). seed_origin_zmatrix1(2,zc12(1,_)). seed_origin_zmatrix2(1,zc21(1,_)). seed_origin_zmatrix2(2,zcm(1,_,_,_)). seed_origin_zmatrix2(3,zcm(zc12(1,_),_,_,_)). seed_elt_zmatrix12(1,_2,zc12(_,1)) :- !. seed_elt_zmatrix12(2,CDim,ZM) :- !,seed_elt_zmatrix12_2(CDim,ZM). seed_elt_zmatrix12(3,CDim,ZM) :- !,seed_elt_zmatrix12_3(CDim,ZM). seed_elt_zmatrix12(RDim,CDim,zcm(A,_,_,_)) :- % RDim > 3, therefore CDim > 2 RD2 is (RDim+1) >> 1, CD2 is (CDim+1) >> 1, seed_elt_zmatrix12(RD2,CD2,A). % CDim==1 not possible: we asked for I==1,J==2 seed_elt_zmatrix12_2(2,zcm(_,1,_,_)). seed_elt_zmatrix12_2(3,zcm(zc12(_,1),_,_,_)). seed_elt_zmatrix12_3(2,zcm(_,zc21(1,_),_,_)) :- !. seed_elt_zmatrix12_3(_3or4,zcm(zcm(_,1,_,_),_,_,_)). % ------------------------------------------------------------------------------ % upper_tri_trans_close(+Dim,+Matrix,-StarMatrix) % [Reference Manual] [Reference Manual] % ------------------------------------------------------------------------------ % StartMatrix is transitive closure of Matrix. Matrix has 1s on its diagonal, % and is upper-triangular. Both Matrix and StartMatrix are Dim x Dim. % In a Boolean semiring: (A B) = (A* A*BC*) % (0 C) = (0 C* ) % ------------------------------------------------------------------------------ upper_tri_trans_close(1,ZM,ZM) :- !. upper_tri_trans_close(Dim,zcu(A,B,C),zcu(AStar,D,CStar)) :- ADim is (Dim+1) >> 1, CDim is Dim - ADim, upper_tri_trans_close(ADim,A,AStar), upper_tri_trans_close(CDim,C,CStar), mult_um(B,AStar,AStarB), mult_mu(AStarB,CStar,D). % calcuate C = A*B, A is upper-triangular with 1s on diagonal % (AA AB) (BA BB) = (AA*BA + AB*BD AA*BB + AB*BC) % ( 0 AC) (BD BC) ( AC*BD AC*BC ) % mult_um(0,_,0) :- !. mult_um(1,A,A). mult_um(zc12(BA,BB),_1,zc12(BA,BB)). mult_um(zc21(BA,BD),zcu(_1,AB,_Also1),C) :- AB = 0 -> ( (BA = 0,BD = 0) -> C = 0 ; C = zc21(BA,BD)) ; BA == 1 -> C = zc21(1,BD) ; BD == 1 -> C = zc21(1,BD) ; (BD = 0 -> C = 0 ; C = zc21(0,1)). mult_um(zcm(BA,BB,BD,BC),zcu(AA,AB,AC),C) :- mult_um(BA,AA,CA1), % A can't be 0, zc12 or zc21, and because mult_mm(AB,BD,CA2), % B is not 0, 1 or zc12, A can't be 1 sum(CA1,CA2,CA), mult_um(BB,AA,CB1), mult_mm(AB,BC,CB2), sum(CB1,CB2,CB), mult_um(BD,AC,CD), mult_um(BC,AC,CC), ( (CA = 0,CB = 0,CD = 0,CC = 0) -> C = 0 ; C = zcm(CA,CB,CD,CC) ). % calcuate C = A*B % (AA AB) (BA BB) = (AA*BA + AB*BD AA*BB + AB*BC) % (AD AC) (BD BC) (AD*BA + AC*BD AD*BB + AC*BC) % mult_mm(0,_,0) :- !. mult_mm(1,B,B). mult_mm(zc21(AA,AD),B,C) :- mult_mm_zc21(B,AA,AD,C). mult_mm(zc12(AA,AB),B,C) :- mult_mm_zc12(B,AA,AB,C). mult_mm(zcm(AA,AB,AD,AC),B,C) :- mult_mm_zcm(B,AA,AB,AD,AC,C). mult_mm_zc21(0,_,_,0) :- !. mult_mm_zc21(1,CA,CD,zc21(CA,CD)). mult_mm_zc21(zc12(BA,BB),AA,AD,C) :- ( AA = 0 -> ( AD = 0 -> C = 0 ; BA == 1 -> C = zcm(0,0,1,BB) ; BB == 1 -> C = zcm(0,0,0,1) ; C = 0 ) ; AD = 0 -> ( BA == 1 -> C = zcm(1,BB,0,0) ; BB == 1 -> C = zcm(0,1,0,0) ; C = 0 ) ; BA == 1 -> C = zcm(1,BB,1,BB) ; BB == 1 -> C = zcm(0,1,0,1) ; C = 0 ). mult_mm_zc12(0,_,_,0) :- !. mult_mm_zc12(zc21(BA,BD),AA,AB,C) :- AA = 0 -> ( AB = 0 -> C = 0 % should we require sparseness, i.e. AA || AB? ; BD = 0 -> C = 0 ; C = 1 ) ; BA = 0 -> ( AB = 0 -> C = 0 ; BD = 0 -> C = 0 ; C = 1 ) ; C = 1. mult_mm_zc12(zcm(BA,BB,BD,BC),AA,AB,C) :- AA = 0 -> ( AB = 0 -> C = 0 % B must be 2x2, or else CDim > RDim + 1 ; BD == 1 -> C = zc12(1,BC) ; BC == 1 -> C = zc12(0,1) ; C = 0 ) ; AB = 0 -> ( BA == 1 -> C = zc12(1,BB) ; BB == 1 -> C = zc12(0,1) ; C = 0 ) ; BA == 1 -> ( BB == 1 -> C = zc12(1,1) ; BC == 1 -> C = zc12(1,1) ; C = zc12(1,0) ) ; BD == 1 -> ( BB == 1 -> C = zc12(1,1) ; BC == 1 -> C = zc12(1,1) ; C = zc12(1,0) ) ; BB == 1 -> C = zc12(0,1) ; BC == 1 -> C = zc12(0,1) ; C = 0. mult_mm_zcm(0,_,_,_,_,0) :- !. mult_mm_zcm(zc21(BA,BD),AA,AB,AD,AC,C) :- % then A is 2x2 BA = 0 -> ( BD = 0 -> C = 0 ; AB == 1 -> C = zc21(1,AC) ; AC == 1 -> C = zc21(0,1) ; C = 0 ) ; BD = 0 -> ( AA == 1 -> C = zc21(1,AD) ; AD == 1 -> C = zc21(0,1) ; C = 0 ) ; AA == 1 -> ( AD == 1 -> C = zc21(1,1) ; AC == 1 -> C = zc21(1,1) ; C = zc21(1,0) ) ; AB == 1 -> ( AD == 1 -> C = zc21(1,1) ; AC == 1 -> C = zc21(1,1) ; C = zc21(1,0) ) ; AD == 1 -> C = zc21(0,1) ; AC == 1 -> C = zc21(0,1) ; C = 0. mult_mm_zcm(zcm(BA,BB,BD,BC),AA,AB,AD,AC,C) :- mult_mm(AA,BA,CA1), % to require sparseness, we would need to check mult_mm(AB,BD,CA2), % (CA || CB || CD || CC) here sum(CA1,CA2,CA), mult_mm(AA,BB,CB1), mult_mm(AB,BC,CB2), sum(CB1,CB2,CB), mult_mm(AD,BA,CD1), mult_mm(AC,BD,CD2), sum(CD1,CD2,CD), mult_mm(AD,BB,CC1), mult_mm(AC,BC,CC2), sum(CC1,CC2,CC), ( (CA=0,CB=0,CD=0,CC=0) -> C = 0 ; C = zcm(CA,CB,CD,CC) ). % calcuate C = A*B, B is upper-triangular with 1s on diagonal % (AA AB) (BA BB) = (AA*BA AA*BB + AB*BC) % (AD AC) (0 BC) (AD*BA AD*BB + AC*BC) % mult_mu(0,_,0) :- !. mult_mu(1,B,B). mult_mu(zc21(AA,AD),_1,zc21(AA,AD)). mult_mu(zc12(AA,AB),zcu(_1,BB,_Also1),C) :- BB = 0 -> ( (AA=0,AB=0) -> C = 0 ; C = zc12(AA,AB)) ; AA == 1 -> C = zc12(AA,1) ; AB == 1 -> C = zc12(AA,1) ; (AA = 0 -> C = 0 ; C = zc12(1,0)). mult_mu(zcm(AA,AB,AD,AC),zcu(BA,BB,BC),C) :- mult_mu(AA,BA,CA), mult_mm(AA,BB,CB1), mult_mu(AB,BC,CB2), sum(CB1,CB2,CB), mult_mu(AD,BA,CD), mult_mm(AD,BB,CC1), mult_mu(AC,BC,CC2), sum(CC1,CC2,CC), ( (CA=0,CB=0,CD=0,CC=0) -> C = 0 ; C = zcm(CA,CB,CD,CC) ). % calculate C = A+B sum(0,B,B) :- !. sum(1,_,1) :- !. sum(A,B,C) :- B = 0 -> C = A ; sum_nozero(A,B,C). sum_nozero(zc12(AA,AB),zc12(BA,BB),zc12(CA,CB)) :- sum(AA,BA,CA), sum(AB,BB,CB). sum_nozero(zc21(AA,AD),zc21(BA,BD),zc21(CA,CD)) :- sum(AA,BA,CA), sum(AD,BD,CD). sum_nozero(zcm(AA,AB,AD,AC),zcm(BA,BB,BD,BC),zcm(CA,CB,CD,CC)) :- sum(AA,BA,CA), sum(AB,BB,CB), sum(AC,BC,CC), sum(AD,BD,CD). % ------------------------------------------------------------------------------ % rconvert_stm(+ZCMatrix,-RowMatrix,+Col,+RDim,+CDim) % ------------------------------------------------------------------------------ % Convert the RDim x CDim submatrix ZCMatrix to row-indexed form. ZCMatrix % is offset by Col columns within its larger matrix. % ------------------------------------------------------------------------------ % Precondition: RowMatrix is proper % Postcondition: each row is proper rconvert_stm(0,RowMatrix,_Col,_NumRows,_NumCols) :- terminate_rows(RowMatrix). rconvert_stm(1,[[Col]],Col,_1,_Also1). rconvert_stm(zc12(A,B),RowMatrix,Col,_1,_2) :- A = 0 -> ( B = 0 -> RowMatrix = [[]] ; BCol is Col + 1, RowMatrix = [[BCol]] ) ; ( B = 0 -> RowMatrix = [[Col]] ; BCol is Col + 1, RowMatrix = [[Col,BCol]] ). rconvert_stm(zc21(A,D),RowMatrix,Col,_2,_1) :- A = 0 -> ( D = 0 -> RowMatrix = [[],[]] ; RowMatrix = [[],[Col]] ) ; ( D = 0 -> RowMatrix = [[Col],[]] ; RowMatrix = [[Col],[Col]] ). rconvert_stm(zcu(A,B,C),RowMatrix,Col,NumRows,NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,CRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm(B,BRowMatrix,BCCol,ABRows,BCCols), CRows is NumRows - ABRows, rconvert_stm(C,CRowMatrix,BCCol,CRows,BCCols). rconvert_stm(zcm(A,B,D,C),RowMatrix,Col,NumRows,NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm(B,BRowMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, rconvert_stm_tail(D,DRowMatrix,CRowMatrix,Col,CDRows,ADCols), rconvert_stm(C,CRowMatrix,BCCol,CDRows,BCCols). % Precondition: RowMatrix is proper % Postcondition: TailMatrix is proper, same length as RowMatrix, % and contains tails of its rows rconvert_stm_tail(0,RowMatrix,RowMatrix,_Col,_NumRows,_NumCols). rconvert_stm_tail(1,[[Col|Tail]],[Tail],Col,_1,_Also1). rconvert_stm_tail(zc12(A,B),RowMatrix,TailMatrix,Col,_1,_2) :- A = 0 -> ( B = 0 -> RowMatrix = [Tail], TailMatrix = RowMatrix ; BCol is Col + 1, RowMatrix = [[BCol|Tail]], TailMatrix = [Tail] ) ; ( B = 0 -> RowMatrix = [[Col|Tail]], TailMatrix = [Tail] ; BCol is Col + 1, RowMatrix = [[Col,BCol|Tail]], TailMatrix = [Tail] ). rconvert_stm_tail(zc21(A,D),RowMatrix,TailMatrix,Col,_2,_1) :- A = 0 -> ( D = 0 -> RowMatrix = [TailA,TailD], TailMatrix = RowMatrix ; RowMatrix = [TailA,[Col|TailD]], TailMatrix = [TailA,TailD] ) ; ( D = 0 -> RowMatrix = [[Col|TailA],TailD], TailMatrix = [TailA,TailD] ; RowMatrix = [[Col|TailA],[Col|TailD]], TailMatrix = [TailA,TailD] ). rconvert_stm_tail(zcu(A,B,C),RowMatrix,TailMatrix,Col,NumRows,NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,CRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols). rconvert_stm_tail(zcm(A,B,D,C),RowMatrix,TailMatrix,Col,NumRows,NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, rconvert_stm_tail(D,DRowMatrix,CRowMatrix,Col,CDRows,ADCols), rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols). % Precondition: RowMatrix is proper % PostCondition: TailMatrix is improper and contains tails of rows of RowMatrix, % TailRestMatrix is tail of TailMatrix rconvert_stm_opentail(0,RowMatrix,TailMatrix,TailRestMatrix,_Col,_NumRows,_NumCols) :- append(RowMatrix,TailRestMatrix,TailMatrix). rconvert_stm_opentail(1,[[Col|Tail]],[Tail|TailRest],TailRest,Col,_1,_Also1). rconvert_stm_opentail(zc12(A,B),RowMatrix,TailMatrix,TailRestMatrix,Col,_1,_2) :- A = 0 -> ( B = 0 -> RowMatrix = [Tail], TailMatrix = [Tail|TailRestMatrix] ; BCol is Col + 1, RowMatrix = [[BCol|Tail]], TailMatrix = [Tail|TailRestMatrix] ) ; ( B = 0 -> RowMatrix = [[Col|Tail]], TailMatrix = [Tail|TailRestMatrix] ; BCol is Col + 1, RowMatrix = [[Col,BCol|Tail]], TailMatrix = [Tail|TailRestMatrix] ). rconvert_stm_opentail(zc21(A,D),RowMatrix,TailMatrix,TailRestMatrix,Col,_2,_1) :- A = 0 -> ( D = 0 -> RowMatrix = [TailA,TailD], TailMatrix = [TailA,TailD|TailRestMatrix] ; RowMatrix = [TailA,[Col|TailD]], TailMatrix = [TailA,TailD|TailRestMatrix] ) ; ( D = 0 -> RowMatrix = [[Col|TailA],TailD], TailMatrix = [TailA,TailD|TailRestMatrix] ; RowMatrix = [[Col|TailA],[Col|TailD]], TailMatrix = [TailA,TailD|TailRestMatrix] ). rconvert_stm_opentail(zcu(A,B,C),RowMatrix,TailMatrix,TailRestMatrix,Col,NumRows, NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,CRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, rconvert_stm_opentail(C,CRowMatrix,CTailMatrix,TailRestMatrix,BCCol,CDRows,BCCols). rconvert_stm_opentail(zcm(A,B,D,C),RowMatrix,TailMatrix,TailRestMatrix,Col,NumRows, NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, rconvert_stm_tail(D,DRowMatrix,CRowMatrix,Col,CDRows,ADCols), rconvert_stm_opentail(C,CRowMatrix,CTailMatrix,TailRestMatrix,BCCol,CDRows,BCCols). % Precondition: RowMatrix is proper % Postcondition: TailMatrix is proper and contains tails of first NumRows rows % of RowMatrix, RestMatrix is remaining rows of RowMatrix. rconvert_stm_open(0,RowMatrix,RestMatrix,TailMatrix,_Col,NumRows,_NumCols) :- length(TailMatrix,NumRows), append(TailMatrix,RestMatrix,RowMatrix). rconvert_stm_open(1,[[Col|Tail]|Rest],Rest,[Tail],Col,_1,_Also1). rconvert_stm_open(zc12(A,B),RowMatrix,RestMatrix,TailMatrix,Col,_1,_2) :- A = 0 -> ( B = 0 -> RowMatrix = [Tail|RestMatrix], TailMatrix = [Tail] ; BCol is Col + 1, RowMatrix = [[BCol|Tail]|RestMatrix], TailMatrix = [Tail] ) ; ( B = 0 -> RowMatrix = [[Col|Tail]|RestMatrix], TailMatrix = [Tail] ; BCol is Col + 1, RowMatrix = [[Col,BCol|Tail]|RestMatrix], TailMatrix = [Tail] ). rconvert_stm_open(zc21(A,D),RowMatrix,RestMatrix,TailMatrix,Col,_2,_1) :- A = 0 -> ( D = 0 -> RowMatrix = [TailA,TailD|RestMatrix], TailMatrix = [TailA,TailD] ; RowMatrix = [TailA,[Col|TailD]|RestMatrix], TailMatrix = [TailA,TailD] ) ; ( D = 0 -> RowMatrix = [[Col|TailA],TailD|RestMatrix], TailMatrix = [TailA,TailD] ; RowMatrix = [[Col|TailA],[Col|TailD]|RestMatrix], TailMatrix = [TailA,TailD] ). rconvert_stm_open(zcu(A,B,C),RowMatrix,RestMatrix,TailMatrix,Col,NumRows,NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, length(CRowMatrix,CDRows), append(CRowMatrix,RestMatrix,DRowMatrix), rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols). rconvert_stm_open(zcm(A,B,D,C),RowMatrix,RestMatrix,TailMatrix,Col,NumRows,NumCols) :- ABRows is (NumRows+1) >> 1, ADCols is (NumCols+1) >> 1, rconvert_stm_open(A,RowMatrix,DRowMatrix,BRowMatrix,Col,ABRows,ADCols), BCCol is Col + ADCols, BCCols is NumCols - ADCols, rconvert_stm_opentail(B,BRowMatrix,TailMatrix,CTailMatrix,BCCol,ABRows,BCCols), CDRows is NumRows - ABRows, rconvert_stm_open(D,DRowMatrix,RestMatrix,CRowMatrix,Col,CDRows,ADCols), rconvert_stm_tail(C,CRowMatrix,CTailMatrix,BCCol,CDRows,BCCols). terminate_rows([]). terminate_rows([[]|Rest]) :- terminate_rows(Rest). % ============================================================================== % ------------------------------------------------------------------------------ % hash_stm_rows(RowMatrix,N) % ------------------------------------------------------------------------------ % Assert the rows of RowMatrix, beginning with index N. % ------------------------------------------------------------------------------ hash_stm_rows([],_). hash_stm_rows([Row|STMatrix],N) :- assert(stmatrix_num(N,Row)), NPlus1 is N + 1, hash_stm_rows(STMatrix,NPlus1). % ============================================================================== % compile_approp/0,1 % [User's Manual] [Reference Manual] % ============================================================================== compile_approp(File) :- abolish((sub)/2),abolish((intro)/2), reconsult(File), compile_approp. compile_approp :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), % verify_subintro_declarations(SortedSubIntros), % verify_intro_declarations(SortedIntros), % rebuild_stmatrix(STMatrix), compile_approp_act, % (SortedSubIntros,SortedIntros,STMatrix), retract(ale_compiling(_)). verify_subintro_declarations(SortedSubIntros) :- ( current_predicate(sub,_ sub _) -> findall(S-FRs, (S sub Ts intro FRs, % Error checks invariant to structure of Ss: ( var(S) -> raise_exception(ale(sub_lhs_var(S sub Ts intro FRs))) ; functor(S,a_,1) -> raise_exception(ale(sub_lhs_abrar)) ; atom(S) -> true ; raise_exception(ale(sub_lhs_other(S))) ), % Error checks for combined sub/intro declarations: ((S = bot, FRs \== []) -> raise_exception(ale(bot_feats(S sub Ts intro FRs))) ; verify_featrestr_list(FRs,(S sub Ts intro FRs),3) ) ),SubIntros) ; SubIntros = [] ), keysort(SubIntros,SortedSubIntros). % sort, but dups are still there rebuild_stmatrix(STMatrix) :- findall(N-Row,clause(stmatrix_num(N,Row),true),STMatrix), ( STMatrix == [] -> raise_exception(ale(no_stmatrix)) ; true ). compile_approp_act :- alec_announce('Compiling appropriateness...'), abolish((approp)/3), abolish((approps)/3), ensure_sub_intro, ale(bot_feats(bot sub Ss intro [F:R|FRs])) if_error (bot sub Ss intro [F:R|FRs]), ale(bot_feats(bot intro [F:R|FRs])) if_error (bot intro [F:R|FRs]), ale(no_features) new_if_warning (\+ (_ sub _ intro [_:_|_]), \+ (_ intro [_:_|_])), ale(duplicate_vr(F,S)) if_error ( S sub _ intro FRs, duplicated(F:_,FRs) ; S intro FRs2, duplicated(F:_,FRs2)), ale(duplicate_intro(S)) if_error (S sub _ intro _, S intro _ ;bagof(IType,FRs^(IType intro FRs),ITypes), duplicated(S,ITypes)), % multiple sub/2 taken care of above ( ( ( S sub _ intro FRs ; S intro FRs), member((_:(a_ X)),FRs), cyclic_term(X) ) -> error_msg((nl,write_list([atom,'a_',X,is,cyclic,in,declaration,of,S]),ttynl)) ; true ), ale(ground_abar_restriction(F,(a_ X),Clause,ArgNo)) new_if_warning ( ( S sub _ intro FRs, Clause = (S sub _ intro FRs), ArgNo = 3 ; S intro FRs, Clause = (S intro FRs), ArgNo = 2), member((F:(a_ X)),FRs), ground(X)), assert(alec(approp)), \+ \+ compile('.alec_throw'), assert(alec(approps)), \+ \+ compile('.alec_throw'), retractall(subsume_ready), assert(subsume_ready), % mark as ready for subtest ale(approp_cycle(S,Fs)) if_error ( type(S), feat_cycle(S,Fs) ), ale(nontriv_upward_closure(F,S,T2,T1)) new_if_warning ( approp(F,S,T1), restricts(S,F,T2), \+ variant(T1,T2)), ale(join_nopres(F,S1,S2)) new_if_warning non_join_pres(_,F,S1,S2). ensure_sub_intro :- (\+current_predicate(sub,(_ sub _)) -> assertz((_ sub _ :- fail)) ; true), (\+current_predicate(intro,(_ intro _)) -> assertz((_ intro _ :- fail)) ; true). %compile_approp_act(SortedSubIntros,SortedIntros,STMatrix) :- % alec_announce('Compiling appropriateness...'), % abolish((approp)/3), abolish((approps)/3), % trace, %DEBUG % ( no_features new_if_warning_else_fail (SortedSubIntros == [],SortedIntros == []) % ; no_duplicates_ksorted(SortedIntros, % dup(L1,_,R1,R2,A1,A2,(R1 = A1, R2 = A2),duplicate_decl(intro(L1,R1)), % ale(duplicate_intro(L1)))), % build_vrqmatrix(SortedSubIntros,SortedIntros,VRQMatrix), % build V % qtranspose(VRQMatrix,VRQMatrixTpose), % transpose(STMatrix,STMatrixTpose), % qmultiply(STMatrixTpose,VRQMatrixTpose,RQMatrix), % build R = ST * V % qtranspose(RQMatrix,RQMatrixTpose), % verify_upward_closure(VRQMatrixTpose,RQMatrixTpose), % warn on non-trivial up. closures % build_stiqmatrixtpose(RQMatrixTpose,STMatrix,VRQMatrix,STIQMatrixTPose), % qtranspose(STIQMatrixTPose,STIQMatrix), % build ST * I % convolute(RQMatrix,CMatrix), % build C = convolution of R % ( top_sort(CMatrix,_) % check for appropriateness cycles % -> true % ; member(T-Neibs,CMatrix), % member(S,Neibs), % min_path(S,T,CMatrix,Path,_), % raise_exception(ale(approp_cycle(T,[T|Path]))) % ), %% --- MUST CHANGE approp/3 % assert(alec(approp)), % \+ \+ compile('.alec_throw'), % assert(alec(approps)), % \+ \+ compile('.alec_throw'), % retractall(subsume_ready), % assert(subsume_ready), % mark as ready for subtest % verify_join_preservation(RQMatrix,STIQMatrix) % ). build_vrqmatrix([],SIntros,VRQMatrix) :- !,build_vrqmatrix_one(SIntros,VRQMatrix). build_vrqmatrix(SIntros1,SIntros2,VRQMatrix) :- SIntros2 = [T2-FRs2|SIntros2Rest] -> SIntros1 = [T1-FRs1|SIntros1Rest], clause(type_num(T1,N1),true), clause(type_num(T2,N2),true), compare(Op,N1,N2), build_vrqmatrix_act(Op,N1,FRs1,SIntros1Rest,N2,FRs2,SIntros2Rest, VRQMatrix) ; build_vrqmatrix_one(SIntros1,VRQMatrix). build_vrqmatrix_act(<,N1,FRs1,SIntros1,N2,FRs2,SIntros2, [N1-N1Row|VRQMatrix]) :- replace_colons(FRs1,KFRs1), keysort(KFRs1,SortedFRs1), no_duplicates_ksorted(SortedFRs1,dup(F1,_,VR1,VR2,A1,A2, (VR1 = A1, VR2 = A2, clause(num_type(N1,T1),true)), duplicate_feat(F1,VR1,T1), ale(duplicate_vr(F1,T1)))), flatten_keys(SortedFRs1,N1Row), build_vrqmatrix_rest(SIntros1,N2,FRs2,SIntros2,VRQMatrix). build_vrqmatrix_act(>,N1,FRs1,SIntros1,N2,FRs2,SIntros2, [N2-N2Row|VRQMatrix]) :- replace_colons(FRs2,KFRs2), keysort(KFRs2,SortedFRs2), no_duplicates_ksorted(SortedFRs2,dup(F1,_,VR1,VR2,A1,A2, (VR1 = A1, VR2 = A2, clause(num_type(N2,T2),true)), duplicate_feat(F1,VR1,T2), ale(duplicate_vr(F1,T2)))), flatten_keys(SortedFRs2,N2Row), build_vrqmatrix_rest(SIntros2,N1,FRs1,SIntros1,VRQMatrix). build_vrqmatrix_act(=,N,FRs1,SIntros1,_N,FRs2,SIntros2,[N-NRow|VRQMatrix]) :- duplicate_decl(intro(T,FRs1)) if_warning_else_fail (variant(FRs1,FRs2), clause(num_type(N,T),true)) -> replace_colons(FRs1,KFRs1), keysort(KFRs1,SortedFRs1), no_duplicates_ksorted(SortedFRs1,dup(F1,_,VR1,VR2,A1,A2, (VR1 = A1, VR2 = A2, clause(num_type(N,T),true)), duplicate_feat(F1,VR1,T), ale(duplicate_vr(F1,T)))), flatten_keys(SortedFRs1,NRow), build_vrqmatrix(SIntros1,SIntros2,VRQMatrix) ; clause(num_type(N,T),true), raise_exception(ale(duplicate_intro(T))). build_vrqmatrix_rest([],N2,FRs2,SIntros2,[N2-N2Row|VRQMatrix]) :- replace_colons(FRs2,KFRs2), keysort(KFRs2,SortedFRs2), no_duplicates_ksorted(SortedFRs2,dup(F1,_,VR1,VR2,A1,A2, (VR1 = A1, VR2 = A2, clause(num_type(N2,T2),true)), duplicate_feat(F1,VR1,T2), ale(duplicate_vr(F1,T2)))), flatten_keys(SortedFRs2,N2Row), build_vrqmatrix_one(SIntros2,VRQMatrix). build_vrqmatrix_rest([T1-FRs1|SIntros1],N2,FRs2,SIntros2,VRQMatrix) :- clause(type_num(T1,N1),true), compare(Op,N1,N2), build_vrqmatrix_act(Op,N1,FRs1,SIntros1,N2,FRs2,SIntros2,VRQMatrix). build_vrqmatrix_one([],[]). build_vrqmatrix_one([T-FRs|SIntros],[N-NRow|VRQMatrix]) :- clause(type_num(T,N),true), replace_colons(FRs,KFRs), keysort(KFRs,SortedFRs), no_duplicates_ksorted(SortedFRs,dup(F1,_,VR1,VR2,A1,A2, (VR1 = A1, VR2 = A2), duplicate_feat(F1,VR1,T), ale(duplicate_vr(F1,T)))), flatten_keys(SortedFRs,NRow), build_vrqmatrix_one(SIntros,VRQMatrix). replace_colons([],[]). replace_colons([F:R|FRs],[F-R|KFRs]) :- replace_colons(FRs,KFRs). flatten_keys([],[]). flatten_keys([K-V|KVs],[K,V|FlattenedKVs]) :- flatten_keys(KVs,FlattenedKVs). restore_keys([],[]). restore_keys([K,V|FlattenedKVs],[K-V|KVs]) :- restore_keys(FlattenedKVs,KVs). qtranspose(Graph, Transpose) :- qtranspose_edges(Graph, TEdges, []), sort(TEdges, TEdges2), vertices(Graph, Vertices), qgroup_edges(Vertices, TEdges2, Transpose). qtranspose_edges([]) --> []. qtranspose_edges([Vertex-Neibs|G]) --> qtranspose_edges(Neibs, Vertex), qtranspose_edges(G). qtranspose_edges([], _) --> []. qtranspose_edges([Neib,Q|Neibs], Vertex) --> [q(Neib,Vertex,Q)], qtranspose_edges(Neibs, Vertex). qgroup_edges([], _, []). qgroup_edges([Vertex|Vertices], Edges, [Vertex-Neibs|G]) :- qgroup_edges(Edges, Vertex, Neibs, RestEdges), qgroup_edges(Vertices, RestEdges, G). qgroup_edges([q(V0,X,Q)|Edges], V, [X,Q|Neibs], RestEdges) :- V0==V, !, qgroup_edges(Edges, V, Neibs, RestEdges). qgroup_edges(Edges, _, [], Edges). qmultiply([],_,[]). qmultiply([Row1-Cols1|M1],QM2Tpose,[Row1-QCols3|QM3]) :- qmultiply_row(QM2Tpose,Cols1,QCols3,M1,QM2Tpose,QM3,Row1). qmultiply_row([],_,[],M1,QM2Tpose,QM3,_) :- qmultiply(M1,QM2Tpose,QM3). qmultiply_row([Col2-QRows|QM2TposeRest],Cols1,QCols3,M1,QM2Tpose,QM3,Row1) :- ( qintersect(Cols1,QRows,[],Q) % [] is used to represent sub-bot -> ( Q == [] -> QCols3 = QCols3Rest ; QCols3 = [Col2,Q|QCols3Rest] ), qmultiply_row(QM2TposeRest,Cols1,QCols3Rest,M1,QM2Tpose,QM3,Row1) ; clause(num_type(Row1,T1),true), % unify_type/3 failed somewhere pretty_vrs(QRows,VRs), raise_exception(ale(upward_closure(Col2,T1,VRs))) ). qintersect([],_,Q,Q). qintersect([C|Cols],[R,QR|QRows],QIn,QOut) :- compare(Op,C,R), qintersect_act(Op,C,Cols,R,QR,QRows,QIn,QOut). qintersect_act(<,_,Cols,R,QR,QRows,QIn,QOut) :- qintersect_col(Cols,R,QR,QRows,QIn,QOut). qintersect_act(>,C,Cols,_,_,QRows,QIn,QOut) :- qintersect_row(QRows,C,Cols,QIn,QOut). qintersect_act(=,_C,Cols,_AlsoC,QR,QRows,QIn,QOut) :- qunify_type(QIn,QR,QMid), qintersect(Cols,QRows,QMid,QOut). qintersect_col([],_,_,_,Q,Q). qintersect_col([C|Cols],R,QR,QRows,QIn,QOut) :- compare(Op,C,R), qintersect_act(Op,C,Cols,R,QR,QRows,QIn,QOut). qintersect_row([],_,_,Q,Q). qintersect_row([R,QR|QRows],C,Cols,QIn,QOut) :- compare(Op,C,R), qintersect_act(Op,C,Cols,R,QR,QRows,QIn,QOut). qunify_type([],T,T) :- !. % sub-bot unification qunify_type(T1,T2,T3) :- unify_type(T1,T2,T3). pretty_types([],[]). pretty_types([N|Ns],[T|Ts]) :- clause(num_type(N,T),true), pretty_types(Ns,Ts). pretty_vrs([],[]). pretty_vrs([N,QR|QRows],[T:QR|QRs]) :- clause(num_type(N,T),true), pretty_vrs(QRows,QRs). verify_upward_closure([],[]). verify_upward_closure([Feat-VRQRows|VRQMatrixTpose],[_Feat-RQRows|RQMatrixTpose]) :- verify_upward_closure_feat(VRQRows,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat). verify_upward_closure_feat([],_,VRQMatrixTPose,RQMatrixTPose,_) :- verify_upward_closure(VRQMatrixTPose,RQMatrixTPose). verify_upward_closure_feat([VN,VQ|VRQRows],[RN,RQ|RQRows],VRQMatrixTpose,RQMatrixTPose, Feat) :- compare(Op,VN,RN), verify_ucf_act(Op,VN,VQ,VRQRows,RN,RQ,RQRows,VRQMatrixTpose,RQMatrixTPose,Feat). % verify_ucf_act(<,...): R contains all the rows that V does verify_ucf_act(>,VN,VQ,VRQRows,_,_,[RN,RQ|RQRows],VRQMatrixTpose,RQMatrixTpose,Feat) :- compare(Op,VN,RN), verify_ucf_act(Op,VN,VQ,VRQRows,RN,RQ,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat). verify_ucf_act(=,VN,VQ,VRQRows,_VN,RQ,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat) :- ( variant(VQ,RQ) -> true ; clause(num_type(VN,T),true), (nontriv_upward_closure(Feat,T,VQ,RQ) warning) ), verify_upward_closure_feat(VRQRows,RQRows,VRQMatrixTpose,RQMatrixTpose,Feat). build_stiqmatrixtpose([],_,_,[]). build_stiqmatrixtpose([VCol-RQRows|RQMatrixTpose],STMatrix,VRQMatrix, [VCol-SQRows|STIQMatrixTpose]) :- qdelta(RQRows,RRows), ( memberchk(VRow-RRows,STMatrix) -> memberchk(VRow-VRQCols,VRQMatrix), append(_,[VCol,V|_],VRQCols), qproject(RRows,V,SQRows), build_stiqmatrixtpose(RQMatrixTpose,STMatrix,VRQMatrix,STIQMatrixTpose) ; map_minimal(RRows,RMins), raise_exception(ale(feat_intro(VCol,RMins))) ). qdelta([],[]). qdelta([Col,_|QCols],[Col|Cols]) :- qdelta(QCols,Cols). qproject([],_,[]). qproject([Col|Cols],V,[Col,V|QCols]) :- qproject(Cols,V,QCols). convolute([],[]). convolute([N-QCols|QMatrix],[T-Cols|Matrix]) :- clause(num_type(N,T),true), convolute_cols(QCols,Cols,QMatrix,Matrix). convolute_cols([],[],QMatrix,Matrix) :- convolute(QMatrix,Matrix). convolute_cols([_,Q|QCols],Cols,QMatrix,Matrix) :- ( functor(Q,a_,1) -> Cols = ColsRest % a_/1 atoms have no features ; Q == bot -> Cols = ColsRest % neither does bot ; Cols = [Q|ColsRest] ), convolute_cols(QCols,ColsRest,QMatrix,Matrix). verify_join_preservation(RQMatrix,STIQMatrix) :- unify_type(A,B,C), A @< B, B \== C, A \== C, % no repetition, no subtypes atom(C), % no a_/1 atoms clause(type_num(A,NA),true), clause(type_num(B,NB),true), clause(type_num(C,NC),true), memberchk(NA-RA,RQMatrix), memberchk(NB-RB,RQMatrix), memberchk(NC-RC,RQMatrix), memberchk(NC-STIC,STIQMatrix), unify_vector(RA,RB,RAB), unify_vector(RAB,STIC,JP), vjp_act(JP,RC,A,B,C), fail. verify_join_preservation(_,_). vjp_act([],[],_,_,_). vjp_act([F,QJ|JP],[_F,QC|RC],A,B,C) :- ( variant(QJ,QC) -> true ; join_nopres(F,A,B) warning, ( clause(standard_non_jp(A,B,C),true) -> true ; assert(standard_non_jp(A,B,C)) ) ), vjp_act(JP,RC,A,B,C). unify_qvector([],V,V). unify_qvector([F1,Q1|V1],[F2,Q2|V2],[FRes,QRes|VRes]) :- compare(Op,F1,F2), uqv_act(Op,F1,Q1,V1,F2,Q2,V2,FRes,QRes,VRes). uqv_act(<,F1,Q1,V1,F2,Q2,V2,F1,Q1,VRes) :- uqv_act2(V1,F2,Q2,V2,VRes). uqv_act(>,F1,Q1,V1,F2,Q2,V2,F2,Q2,VRes) :- uqv_act2(V2,F1,Q1,V1,VRes). uqv_act(=,F,Q1,V1,_F,Q2,V2,F,QRes,VRes) :- unify_type(Q1,Q2,QRes), unify_qvector(V1,V2,VRes). uqv_act2([],F,Q,V,[F,Q|V]). uqv_act2([F1,Q1|V1],F2,Q2,V2,[FRes,QRes|VRes]) :- compare(Op,F1,F2), uqv_act(Op,F1,Q1,V1,F2,Q2,V2,FRes,QRes,VRes). compile_extensional(File) :- abolish((ext)/1), reconsult(File), compile_extensional. compile_extensional :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), % verify_ext_declaration(SortedExts), compile_extensional_act, % (SortedExts), retract(ale_compiling(_)). compile_extensional_act :- % (SortedExts) :- alec_announce('Compiling extensionality declarations...'), retractall(extensional(_)), retractall(ext_sub_type(_)),retractall(ext_sub_structs(_,_,_,_,_,_)), abolish((iso_sub_seq)/3), % abolish((check_sub_seq)/5), abolish((check_pre_traverse)/4),abolish((check_post_traverse)/3), % assert(alec(ext)), % \+ \+ compile('.alec_throw'), \+ \+ compile_ext_assert, % (SortedExts), \+ \+ compile_ext_sub_assert, assert(alec(iso)), \+ \+ compile('.alec_throw'), assert(alec(check)), \+ \+ compile('.alec_throw'). compile_ext_assert :- % (Es) :- current_predicate(ext,ext(_)), ext(Es), % should be passed as arg member(T,Es), ( maximal(T) -> assert(extensional(T)) ; raise_exception(ext_nomax(T)) ), fail. compile_ext_assert :- assert(extensional(a_ _)). compile_ext_sub_assert :- setof(T,E^(clause(extensional(E),true),sub_type(T,E)),ExtSuperTypes), member(T,ExtSuperTypes), assert(ext_sub_type(T)), fail. compile_ext_sub_assert :- esetof(ValueType-MotherType,F^(approp(F,MotherType,ValueType)), TposeApprops), vertices_edges_to_ugraph([],TposeApprops,TposeAppropGraph), top_sort(TposeAppropGraph,AppropTypes), compile_ext_sub_assert_act(AppropTypes). compile_ext_sub_assert_act([]). compile_ext_sub_assert_act([T|Ts]) :- approps(T,FRs,_), compile_ext_sub_assert_type(FRs,Vs,NewFSs,FSs,Goals,GoalsRest), ( Goals == GoalsRest -> compile_ext_sub_assert_act(Ts) ; SVs =.. [T|Vs], assert(ext_sub_structs(T,SVs,NewFSs,FSs,Goals,GoalsRest)), compile_ext_sub_assert_act(Ts) ). compile_ext_sub_assert_type([],[],FSs,FSs,Goals,Goals). compile_ext_sub_assert_type([_:R|FRs],[V|Vs],NewFSs,FSs,Goals,GoalsRest) :- ext_sub_type(R) -> NewFSs = fs(Tag,SVs,FSsMid), Goals = [deref(V,Tag,SVs)|GoalsMid], compile_ext_sub_assert_type(FRs,Vs,FSsMid,FSs,GoalsMid, GoalsRest) ; clause(ext_sub_structs(R,V,NewFSs,FSsMid,Goals,GoalsMid),true) -> % this is available if needed because we topologically sorted the types compile_ext_sub_assert_type(FRs,Vs,FSsMid,FSs,GoalsMid, GoalsRest) ; compile_ext_sub_assert_type(FRs,Vs,NewFSs,FSs,Goals,GoalsRest). compile_cons(File) :- abolish((cons)/2), reconsult(File), compile_cons. %------------------------------------------------------------------------------- % Type Constraints % [User's Manual] %------------------------------------------------------------------------------- compile_cons :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_cons_act, retract(ale_compiling(_)). compile_cons_act :- alec_announce('Compiling type constraints...'), abolish((ct)/4), retractall(constrained(_)), % retract_fs_palettes(ct), (current_predicate(cons,(_ cons _)) -> [bot,has,constraints] if_error ( bot cons _ ), [multiple,constraint,declarations,for,CType] if_error (bagof(CT,Cons^(CT cons Cons),CTypes), duplicated(CType,CTypes)), [constraint,declaration,given,for,atom] if_error ( (a_ _) cons _ ), % ['=@',accessible,by,procedural,attachment,calls,from,constraint,for,Type] % if_warning (current_predicate(if,(_ if _)), % find_xeqs([],EGs), % Type cons _ goal Gs, % find_xeq_act(Gs,EGs)), assert(alec(ct)), \+ \+ compile('.alec_throw') ; ([no,constraints,found] if_warning true) ). find_xeqs(Accum,EGs) :- findall(EG,find_xeq(Accum,EG),NewAccum,Accum), find_xeqs_act(NewAccum,Accum,EGs). find_xeqs_act(EGs,EGs,EGs) :- !. find_xeqs_act(NewAccum,_,EGs) :- find_xeqs(NewAccum,EGs). find_xeq(Accum,G/N) :- (Head if Body), functor(Head,G,N), \+member(G/N,Accum), find_xeq_act(Body,Accum). find_xeq_act(=@(_,_),_) :- !. find_xeq_act((G1,_),Accum) :- find_xeq_act(G1,Accum), !. find_xeq_act((_,G2),Accum) :- find_xeq_act(G2,Accum), !. find_xeq_act((G1 -> G2),Accum) :- ( find_xeq_act(G1,Accum) ; find_xeq_act(G2,Accum) ), !. find_xeq_act((G1;_),Accum) :- find_xeq_act(G1,Accum), !. find_xeq_act((_;G2),Accum) :- find_xeq_act(G2,Accum), !. find_xeq_act((\+ G),Accum) :- find_xeq_act(G,Accum), !. find_xeq_act(At,Accum) :- functor(At,AG,AN), member(AG/AN,Accum). compile_logic :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_logic_act, retract(ale_compiling(_)). compile_logic_act :- compile_mgsc_act, compile_add_to_type_act, compile_featval_act, compile_u_act. compile_mgsat :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_mgsc_act, retract(ale_compiling(_)). compile_mgsc_act :- alec_announce('Compiling most general satisfiers...'), abolish((mgsc)/4), \+ \+ compile_mgsat_assert. % assert(alec(mgsc)), % compile('.alec_throw'). %mgsc(T,FS,IqsIn,IqsOut) if_b SubGoals :- % clause(mgsat(T,FS,IqsIn,IqsOut,SubGoals,[]),true). compile_mgsat_assert:- esetof(ValueType-MotherType,F^(approp(F,MotherType,ValueType), \+ ValueType = (a_ _)),TposeApprops), setof(T,non_a_type(T),Types), vertices_edges_to_ugraph(Types,TposeApprops,TposeAppropGraph), top_sort(TposeAppropGraph,AppropTypes), % build t'pose graph since top_sort assert(mgsc((a_ X),_-(a_ X),CGs,CGs)), % returns reverse ordering map_mgsat(AppropTypes). map_mgsat([]). map_mgsat([T|AppropTypes]) :- approps(T,FRs,_), map_mgsat_act(FRs,Vs,ConsGoals,ConsGoalsMid), SVs =.. [T|Vs], mgsat_cons(T,FS,ConsGoalsMid2,ConsGoalsRest), ( ConsGoalsMid2 == ConsGoalsRest % if there are no constraints at this type, then instantiate -> assert(mgsc(T,_-SVs,ConsGoals,ConsGoalsMid)) % var now - add_to_type etc. will bind to this at % compile-time if ConsGoals == ConsGoalsMid, and % bind at run-time after executing ConsGoals-ConsGoalsMid otherwise. ; ConsGoalsMid = [(FS = _-SVs)|ConsGoalsMid2], % Otherwise, take care of values, then instantiate, assert(mgsc(T,FS,ConsGoals,ConsGoalsRest)) % then take care of root constraints. add_to_type % etc. will bind FS after the entire ConsGoals-ConsGoalsRest stream. ), map_mgsat(AppropTypes). map_mgsat_act([],[],ConsGoals,ConsGoals). map_mgsat_act([_:TypeRestr|FRs],[FS|Vs],ConsGoals, ConsGoalsRest) :- clause(mgsc(TypeRestr,FS,ConsGoals,ConsGoalsMid),true), map_mgsat_act(FRs,Vs,ConsGoalsMid,ConsGoalsRest). mgsat_cons(Type,FS,ConsGoals,ConsGoalsRest) :- findall(T,(clause(constrained(T),true), sub_type(T,Type)),ConsTypes), map_cons(ConsTypes,FS,ConsGoals,ConsGoalsRest). compile_add_to_type :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_add_to_type_act, retract(ale_compiling(_)). compile_add_to_type_act :- alec_announce('Compiling type promotion...'), abolish((add_to_type)/3), assert(alec(addtype)), \+ \+ consult('.alec_throw'). % HACK: compiling takes too much memory, not much RT loss - and % for some reason, Win32 SICStus needs to consult this % assert(alec(at3)), % compile('.alec_throw'). %compile_add_to_type3(Code,CodeRest) :- % findall((Goal :- % deref(FS,Tag,SVs), % Goal2), % (non_a_type(Type), % types other than a_/1 atoms % cat_atoms('add_to_type_',Type,Rel), % Goal =.. [Rel,FS], % Goal2 =.. [Rel,SVs,Tag]), % Code, % [('add_to_type_a_'(FS,X) :- % deref(FS,Tag,SVs), % 'add_to_type_a_'(SVs,Tag,X))|CodeRest]). compile_featval :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_featval_act, retract(ale_compiling(_)). compile_featval_act :- alec_announce('Compiling feature selection...'), abolish((featval)/4), ( ((_ sub _ intro _) ; (_ intro _)) -> (assert(alec(featval)), \+ \+ compile('.alec_throw')) % assert(alec(fv4)), % compile('.alec_throw')) ; true). %compile_featval4(Code) :- % setof(Clause, % Feat^Goal^Goal2^Rel^Type^Subs^FRs^R^( % (Clause = (Goal :- % deref(FS,Tag,SVs), % Goal2)), % ( (Type subs Subs intro FRs), % member(Feat:R,FRs), % cat_atoms('featval_',Feat,Rel), % Goal =.. [Rel,FS,FSOut], % Goal2 =.. [Rel,SVs,Tag,FSOut] % ; (Type intro FRs), % member(Feat:R,FRs), % cat_atoms('featval_',Feat,Rel), % Goal =.. [Rel,FS,FSOut], % Goal2 =.. [Rel,SVs,Tag,FSOut])), % CodeNoEnd), % append(CodeNoEnd,[end_of_file],Code). compile_u :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_u_act, retract(ale_compiling(_)). compile_u_act :- alec_announce('Compiling unification...'), abolish((u)/4), assert(alec(u)), \+ \+ consult('.alec_throw'). % HACK: compiling takes too long, not much RT loss compile_subsume :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_subsume_act, retract(ale_compiling(_)). compile_subsume_act :- no_subsumption -> true ; (retract(subsume_ready),parsing) -> alec_announce('Compiling subsumption checking...'), abolish((subsume_type)/13), assert(alec(subsume)), \+ \+ compile('.alec_throw') ; true. compile_grammar(File):- abolish((empty)/1),abolish((rule)/2), abolish((lex_rule)/2), % 5/1/96 - Octav -- added abolish/2 calls for generation predicates abolish(('--->')/2), abolish((semantics)/1), reconsult(File), compile_grammar. compile_grammar :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_grammar_act, retract(ale_compiling(_)). compile_grammar_act :- compile_lex_rules_act, compile_lex_act, compile_rules_act, % 5/1/96 - Octav -- added call for compilation of generation predicate compile_generate_act. compile_lex_rules(File):- abolish((lex_rule)/2), reconsult(File), compile_lex_rules. compile_lex_rules :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_lex_rules_act, retract(ale_compiling(_)). compile_lex_rules_act :- abolish((lex_rule)/8), % retract_fs_palettes(lex_rule), (parsing -> alec_announce('Compiling lexical rules...'), ( [no,lexical,rules,found] if_warning_else_fail (\+ current_predicate(lex_rule,lex_rule(_,_))) -> true % 5/1/96 - Octav -- added test to signal lack of 'morphs' specification ; ([lexical,rule,RuleName,lacks,morphs,specification] if_error ((RuleName lex_rule _ **> _ if _) ;(RuleName lex_rule _ **> _)), assert(alec(lexrules)), \+ \+ consult('.alec_throw')) % would compile but routinely exceeds 256-var limit ) ; true). compile_lex(File):- % 5/1/96 - Octav -- added abolish/2 calls for generation predicates abolish(('--->')/2),abolish((lex_rule)/2),abolish((semantics)/1), reconsult(File), compile_lex. %------------------------------------------------------------------------------- % Lexical Entries % [User's Manual] %------------------------------------------------------------------------------- compile_lex :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_lex_act, retract(ale_compiling(_)). compile_lex_act :- abolish((lex)/2), retract_fs_palettes(lex), secret_noadderrs, (parsing -> alec_announce('Compiling lexicon...'), [no,lexicon,found] if_warning (\+ current_predicate('--->',(_ ---> _))), assert(alec(lex)), (lexicon_consult -> \+ \+ consult('.alec_throw') ; \+ \+ compile('.alec_throw')) ; true ), secret_adderrs. % update_lex(+File) % ----------------- % add the lexical entries in File to the lexicon, closing under lexical rules. update_lex(File) :- lexicon_consult, assert(lexicon_updating), reconsult(File), retract(lexicon_updating). % retract_lex(+LexSpec) % --------------------- % retract the lexical entries specified by LexSpec, not closing under lexical % rules. LexSpec is either a word, or a list of words. retract_lex(LexSpec) :- ( current_predicate(lex,lex(_,_,_)) -> ( predicate_property(lex(_,_,_),dynamic) -> (LexSpec = [_|_] -> retract_lex_list(LexSpec) ; retract_lex_one(LexSpec) ) ; error_msg((nl,write('retract_lex/1: lexicon is currently static'),nl)) ) ; error_msg((nl,write('retract_lex/1: no compiled lexicon in memory'),nl)) ). retract_lex_list([]). retract_lex_list([Lex|LexRest]) :- retract_lex_one(Lex), retract_lex_list(LexRest). retract_lex_one(Word) :- call_residue((clause(lex(Word,FS),Body,Ref), call(Body), extensionalise(FS), deref(FS,Tag,SVs)),Residue), ((current_predicate(portray_lex,portray_lex(_,_,_,_)), portray_lex(Word,Tag,SVs,Residue)) -> true ; nl, write('WORD: '), write(Word), nl, write('ENTRY: '), nl, pp_fs_res(Tag,SVs,Residue),ttynl ), write('RETRACT? '),ttyflush,read(y), erase(Ref), fail. retract_lex_one(_). retractall_lex(LexSpec) :- LexSpec = [_|_] -> retractall_lex_list(LexSpec) ; retractall(lex(LexSpec,_,_,_)). retractall_lex_list([]). retractall_lex_list([Lex|LexRest]) :- retractall(lex(Lex,_,_,_)), retract_lex_list(LexRest). % export_words(+Stream,+Delimiter) % -------------------------------- % Write the words in the current lexicon in a Delimiter-separated list to % Stream export_words(Stream,Delimiter) :- setof(Word,FS^lex(Word,FS),Words), export_words_act(Words,Stream,Delimiter). export_words_act([],_,_). export_words_act([W|Ws],Stream,Delimiter) :- write(Stream,W),write(Stream,Delimiter), export_words_act(Ws,Stream,Delimiter). :- dynamic emptynum/1. :- dynamic alec_rule/7. :- dynamic fspal_ref/2. %compile_empty(File):- % abolish((empty)/1), % reconsult(File), % compile_empty. %------------------------------------------------------------------------------- % Empty Categories % [User's Manual] %------------------------------------------------------------------------------- %compile_empty :- % touch('.alec_throw'), % absolute_file_name('.alec_throw',AbsFileName), % retractall(ale_compiling(_)), % assert(ale_compiling(AbsFileName)), % compile_empty_act, % retract(ale_compiling(_)). %compile_empty_act :- % abolish((empty_cat)/4), % retractall(emptynum(_)), % assert(emptynum(-1)), % secret_noadderrs, % (parsing % -> alec_announce('Compiling empty categories...'), % (assert(alec(empty)), % (lexicon_consult -> consult('.alec_throw') % ; compile('.alec_throw'))) % ; true), % secret_adderrs. %retract_empty :- % empty_cat(N,Tag,SVs,IqsIn), % extensionalise(Tag,SVs,IqsIn), % check_inequal(IqsIn,IqsOut), % nl, write('EMPTY CATEGORY: '), % pp_fs_col(Tag,SVs,IqsOut,4), % ttynl, write('RETRACT? '),ttyflush,read(y), % retract(empty_cat(N,Tag,SVs,IqsIn)), % fail. %retract_empty. %retractall_empty :- % retractall(empty_cat(_,_,_,_)). compile_rules(File):- % 5/1/96 - Octav -- added abolish/2 calls for generation predicates abolish((rule)/2),abolish((empty)/1), reconsult(File), compile_rules. compile_rules :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_rules_act, retract(ale_compiling(_)). retract_fs_palettes(Source) :- retract(fspal_ref(Source,Ref)), erase(Ref), fail ; true. compile_rules_act :- alec_announce('Compiling empty categories and phrase structure rules...'), abolish((empty_cat)/6), retractall(emptynum(_)), assert(emptynum(-1)), abolish((rule)/6), abolish((chain_rule)/10), abolish((non_chain_rule)/6),abolish((chained)/6), retractall(alec_rule(_,_,_,_,_,_)), % retract_fs_palettes(chained), retract_fs_palettes(chain_rule), % retract_fs_palettes(non_chain_rule), retract_fs_palettes(rule), ( [no,phrase,structure,rules,found] if_warning_else_fail (\+ current_predicate(rule,rule(_,_))) -> true % 5/1/96 - Octav -- added 'sem_head>' in the list of labels tested for ; [rule,RuleName,has,no,'cat>','cats>',or,'sem_head>',specification] if_error ((RuleName rule _ ===> Body), \+ cat_member(Body), \+ cats_member(Body), \+ sem_head_member(Body)), % 5/1/96 - Octav -- added check for multiple occurences of 'sem_head>' label [rule,RuleName,has,multiple,'sem_head>',specifications] if_error ((RuleName rule _ ===> Body), multiple_heads(Body)), % 6/10/97 - Octav -- added check for bad 'sem_goal>' labels [rule,RuleName,has,wrongly,placed,'sem_goal>',specifications] if_error ((RuleName rule _ ===> Body), bad_sem_goal(Body))), (parsing -> (secret_noadderrs, assert(alec(empty)), \+ \+ consult('.alec_throw'), secret_adderrs, assert(alec(rules)), \+ \+ consult('.alec_throw')) % HACK - should be compile/1 but too many vars ; true), % 5/1/96 - Octav -- added secret_noadderrs/0 to prevent printing 'unification % failure' messages during chaining compilation % 7/1/98 - Gerald -- changed secret_noadderrs/0 calls to have scope only % over relevant (non-chain) lexical compilation (generating -> % 5/1/96 - Octav -- added compilation of chain rules for generation ( [no,chain,rules,found] if_warning_else_fail (\+ (current_predicate(rule,(_ rule _)), (_ rule _ ===> Body), split_dtrs(Body,_,_,_,_,_))) -> true ; assert(alec(chain)), \+ \+ compile('.alec_throw'), assert(alec(chained)), \+ \+ compile('.alec_throw')), % 5/1/96 - Octav - added compilation of non_chain rules for generation ( [no,non_chain,rules,found] if_warning_else_fail (\+ (current_predicate(rule,(_ rule _)), (_ rule _ ===> Body), \+ split_dtrs(Body,_,_,_,_,_)), \+ current_predicate(empty,empty(_)), \+ current_predicate('--->',(_ ---> _))) -> true ; (assert(alec(nochain)), \+ \+ compile('.alec_throw'))) ; true). % 5/1/96 - Octav -- added rules to compile the generation predicate compile_generate(File) :- abolish((semantics)/1), reconsult(File), compile_generate. compile_generate :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_generate_act, retract(ale_compiling(_)). compile_generate_act :- abolish((generate)/4), (generating -> alec_announce('Compiling semantics directive...'), ( [no,semantics,directive,found] if_warning_else_fail (\+ current_predicate(semantics,semantics(_))) -> true ; semantics(Pred), functor(Goal,Pred,2), ([no,Pred,definite,clause,found] if_warning_else_fail (\+ (current_predicate(if,(_ if _)), (Goal if _))) -> true ; (assert(alec(generate)), \+ \+ compile('.alec_throw')))) ; true). compile_dcs(File):- abolish((if)/2), reconsult(File), compile_dcs. compile_dcs :- touch('.alec_throw'), absolute_file_name('.alec_throw',AbsFileName), retractall(ale_compiling(_)), assert(ale_compiling(AbsFileName)), compile_dcs_act, retract(ale_compiling(_)). compile_dcs_act :- alec_announce('Compiling definite clauses...'), retractall(fun_exp(_,_)), % retract_fs_palettes(dcs), [no,definite,clauses,found] if_warning (\+ current_predicate(if,if(_,_))), assert(alec(dcs)), \+ \+ compile('.alec_throw'). :- dynamic fun_exp/2. compile_dcs(Code,CodeRest) :- empty_assoc(VarsIn), empty_assoc(NVs), findall((CompiledHead :- CompiledBody), ( ( current_predicate('+++>',(_ +++> _)), (FunDesc +++> Result), functor(FunDesc,Rel,FunArity), RelArity is FunArity + 1, fun_expand_act(0,FunArity,FunDesc,ArgDescs,Result), ( clause(fun_exp(Rel,RelArity),true) -> true ; assert(fun_exp(Rel,RelArity))), Body = true ; current_predicate(if,if(_,_)), (Head if Body), functor(Head,Rel,RelArity), Head =.. [_|ArgDescs] ), compile_descs(ArgDescs,Args,CompiledBodyList,CompiledBodyRest, true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs), % append(Args,[IqsIn,IqsOut],CompiledArgs), cat_atoms('fs_',Rel,CompiledRel), CompiledHead =.. [CompiledRel|Args], compile_body(Body,CompiledBodyRest,[],true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs), FSsOut = [], % build_fs_palette(FSsOut,FSPal,CompiledBodyList,CompiledBodyMid,dcs), goal_list_to_seq(CompiledBodyList,CompiledBody)), Code,CodeRest), esetof((Rel/RelArity),(current_predicate(if,if(_,_)), (Head if _Body), functor(Head,Rel,RelArity), clause(fun_exp(Rel,RelArity),true)),FunRedefines), ( member(Spec,FunRedefines), [Spec,already,implicitly,defined,by,'+++>',declaration] if_warning true, fail ; true ). % KNOWN BUG - should register these predicates so that we can abolish them on % recompiles. Unclear what's happening at present. % , \+ (CodeRest =[], member(C,Code), write(user_error,C), nl(user_error), fail) % ; CodeRest = Code. fun_expand_act(A,A,_,[Result],Result) :- !. fun_expand_act(I,A,FunDesc,[ArgDesc|ArgDescs],Result) :- NewI is I + 1, arg(NewI,FunDesc,ArgDesc), fun_expand_act(NewI,A,FunDesc,ArgDescs,Result). compile_fun(File):- abolish(('+++>')/2), abolish((fun)/1), reconsult(File), compile_fun_act. compile_fun :- compile_fun_act. compile_fun_act :- alec_announce('Compiling functional descriptions...'), retractall(fun_spec(_,_,_)), compile_fun_assert. :- dynamic fun_spec/3. compile_fun_assert :- current_predicate(fun,fun(_)), (fun FunSpec), functor(FunSpec,Functor,RelArity), FunArity is RelArity - 1, [nullary,relation,FunSpec,specified,as,function] if_error (FunArity < 0), [nullary,function,FunSpec,identical,to,type] if_error ( FunArity == 0, non_a_type(Functor) ), [unary,function,FunSpec,identical,to,'a_',atom] if_error ( FunArity == 1, Functor == 'a_' ), ( compile_fun_act(0,RelArity,FunSpec,ResArg) -> assert(fun_spec(Functor,FunArity,ResArg)), fail ; error_msg((nl,write(' **ERROR: no result argument specified in '),write(FunSpec),nl)) ). compile_fun_assert :- current_predicate('+++>',(_ +++> _)), (FunDesc +++> _Result), functor(FunDesc,Functor,FunArity), ResArg is FunArity + 1, [nullary,function,FunSpec,identical,to,type] if_error ( FunArity == 0, non_a_type(Functor) ), [unary,function,FunSpec,identical,to,'a_',atom] if_error ( FunArity == 1, Functor == 'a_' ), assert(fun_spec(Functor,FunArity,ResArg)), fail. compile_fun_assert :- [conflicting,argument,positions,ResArg1,and,ResArg2,for,function,Functor,'/',FunArity] if_warning (clause(fun_spec(Functor,FunArity,ResArg1),true), clause(fun_spec(Functor,FunArity,ResArg2),true), ResArg1 \== ResArg2). compile_fun_act(I,N,FunSpec,ResArg) :- I < N, NewI is I + 1, arg(NewI,FunSpec,A), ( A == '-' -> ResArg = NewI, compile_fun_flush(NewI,N,FunSpec) ; compile_fun_act(NewI,N,FunSpec,ResArg) ). compile_fun_flush(N,N,_) :- !. compile_fun_flush(I,N,FunSpec) :- % I < N, NewI is I + 1, arg(NewI,FunSpec,A), [multiple,result,arguments,specified,in,FunSpec] if_error (A == '-'), compile_fun_flush(NewI,N,FunSpec). % touch('.alec_throw'), % absolute_file_name('.alec_throw',AbsFileName), % retractall(ale_compiling(_)), % assert(ale_compiling(AbsFileName)), % compile_fun_act, % retract(ale_compiling(_)). %compile_fun_act :- % alec_announce('Compiling functional descriptions...'), % assert(alec(fun)), % \+ \+ compile('.alec_throw'), % assert(alec(fsolve)), % \+ \+ compile('.alec_throw'). %compile_fun(Code,CodeRest) :- % ([no,functional,descriptions,found] if_warning_else_fail % (\+ current_predicate(+++>,+++>(_,_))) % -> (Code = [(fun(_) :- !,fail)|CodeRest]) % ; (setof(Functor/Arity,F^((F +++> _), % functor(F,Functor,Arity)),Functions), % compile_fun_act(Functions,Code,CodeRest)) % ). %compile_fun_act([],Code,Code). %compile_fun_act([(Functor/Arity)|Functions], % [fun(Template)|CodeMid],CodeRest) :- % functor(Template,Functor,Arity), % compile_fun_act(Functions,CodeMid,CodeRest). % ------------------------------------------------------------------------------ % cat_member(Dtrs) % ------------------------------------------------------------------------------ % true if Dtrs has at least one category member % ------------------------------------------------------------------------------ cat_member((cat> _)). cat_member((cat> _, _)):-!. cat_member((_,Body)):- cat_member(Body). % ------------------------------------------------------------------------------ % sem_head_member(+Dtrs:descs) % ------------------------------------------------------------------------------ % true if Dtrs has at least one sem_head> member % ------------------------------------------------------------------------------ sem_head_member((sem_head> _)). sem_head_member((sem_head> _,_)):-!. sem_head_member((_,Body)):- sem_head_member(Body). % ------------------------------------------------------------------------------ % sem_goal_member(+Dtrs:descs) % ------------------------------------------------------------------------------ % true if Dtrs has at least one sem_goal> member % ------------------------------------------------------------------------------ sem_goal_member((sem_goal> _)). sem_goal_member((sem_goal> _,_)):-!. sem_goal_member((_,Body)):- sem_goal_member(Body). % ------------------------------------------------------------------------------ % cats_member(Dtrs) % ------------------------------------------------------------------------------ % true if Dtrs has at least one cats member % ------------------------------------------------------------------------------ cats_member((cats> _)). cats_member((cats> _, _)):- !. % doesn't check for cats> [] or elist! cats_member((_,Body)):- cats_member(Body). % ------------------------------------------------------------------------------ % multiple_heads(+Dtrs:descs) % ------------------------------------------------------------------------------ % checks whether Dtrs has multiple sem_head> members % ------------------------------------------------------------------------------ multiple_heads((sem_head> _,Dtrs)) :- !, sem_head_member(Dtrs). multiple_heads((_,Dtrs)) :- multiple_heads(Dtrs). % ------------------------------------------------------------------------------ % bad_sem_goal(+Dtrs:descs) % ------------------------------------------------------------------------------ % checks whether Dtrs has wrongly placed sem_goal> members % ------------------------------------------------------------------------------ bad_sem_goal(Dtrs) :- % there's a sem_head split_dtrs(Dtrs,_,_,_,DtrsBefore,DtrsAfter), !,(sem_goal_member(DtrsBefore) -> true ; sem_goal_member(DtrsAfter)). bad_sem_goal(Dtrs) :- % there's no sem_head sem_goal_member(Dtrs). % ------------------------------------------------------------------------------ % if_h(Goal:goal, SubGoals:goals) +user % ------------------------------------------------------------------------------ % accounts for multi-hash goals with no subgoals given % ------------------------------------------------------------------------------ Goal if_h [] :- Goal if_h. % ------------------------------------------------------------------------------ % multi_hash(N:int, Fun/Arity:fun_sym/int,Code:goals,CodeRest:goals) % ------------------------------------------------------------------------------ % for each solution T1,...,TK of ?- G(T1,...,TK) if_h SubGoals. % G(f1(X11,...,X1J1),V2,...,VK):- % G_f1(V2,...,VK,X11,...,X1J1). % ... % G_f1_f2_..._fN(TN+1,...,TK,X11,...,X1J1,X21,..,X2J2,...,XN1,..,XNJN):- % SubGoals. % order matters for clauses listed with if_b, but not with if_h % clauses with if_b must have subgoals listed, even if empty (for order) % Will not behave properly with if_b on discontiguous user declarations for N>0 % ------------------------------------------------------------------------------ multi_hash(N,(Fun)/Arity,Code,CodeRest):- length(Args,Arity), Goal =.. [Fun|Args], % DEBUG % statistics(walltime,B),write(user_error,'pre-setof: '), % write(user_error,B),nl(user_error), ( setof(sol(Args,SubGoals), if_h(Goal,SubGoals), Sols) -> true ; bagof(sol(Args,SubGoals), if_b(Goal,SubGoals), Sols) ), % statistics(walltime,E),write(user_error,'pre-hash: '), % write(user_error,E),nl(user_error), mh(N,Sols,Fun,Code,CodeRest). % statistics(walltime,H),write(user_error,'post-hash: '), % write(user_error,H),nl(user_error). my_multi_hash(N,(Fun)/Arity,Code,CodeRest):- % DEBUG length(Args,Arity), Goal =.. [Fun|Args], statistics(walltime,_), ( setof(sol(Args,SubGoals), if_h(Goal,SubGoals), Sols) -> true ; bagof(sol(Args,SubGoals), if_b(Goal,SubGoals), Sols) ), statistics(walltime,[_,SolS]), write(user_error,'DEBUG: solutions '),write(user_error,SolS),nl(user_error),flush_output(user_error), mh(N,Sols,Fun,Code,CodeRest), statistics(walltime,[_,HashS]), write(user_error,'DEBUG: hash '),write(user_error,HashS),nl(user_error),flush_output(user_error). mh(0,Sols,Fun,Code,CodeRest):- !, mh_zero(Sols,Fun,Code,CodeRest). mh(N,Sols,Fun,Code,CodeRest):- mh_nonzero(Sols,Fun,N,Code,CodeRest). mh_zero([],_,Code,Code). mh_zero([sol(Args,SubGoals)|Sols],Fun,[Clause|CodeMid],CodeRest) :- Goal =.. [Fun|Args], (SubGoals = [] -> (Clause = Goal) ; (goal_list_to_seq(SubGoals,SubGoalSeq), Clause = (Goal :- SubGoalSeq))), mh_zero(Sols,Fun,CodeMid,CodeRest). mh_nonzero([],_,_,Code,Code). mh_nonzero([sol(Args,SubGoals)],Fun,_,[Clause|CodeRest],CodeRest):- !, Goal =.. [Fun|Args], (SubGoals = [] -> (Clause = Goal) ; (goal_list_to_seq(SubGoals,SubGoalSeq), Clause = (Goal :- SubGoalSeq))). mh_nonzero([sol([Arg|Args],SubGoals)|Sols],Fun,N,Code,CodeRest):- nonvar(Arg), functor(Arg,FunArg,Arity), Arg =.. [_|ArgsArg], ( (Sols = [sol([Arg2|_],_)|_], nonvar(Arg2), functor(Arg2,FunArg,Arity)) -> (cat_atoms('_',FunArg,FunTail), cat_atoms(Fun,FunTail,FunNew), same_length(Args,OtherArgs), Goal =.. [Fun,Arg|OtherArgs], append(OtherArgs,ArgsArg,ArgsNew), SubGoal =.. [FunNew|ArgsNew], append(Args,ArgsArg,ArgsOld), (Code = [(Goal :- SubGoal)|CodeMid]), SolsSub = [sol(ArgsOld,SubGoals)|SolsSubRest], mh_arg(FunArg,Arity,Sols,SolsSub,SolsSubRest,Fun,FunNew,N, CodeMid,CodeRest)) ; Goal =.. [Fun,Arg|Args], (Code = [Clause|CodeMid]), (SubGoals = [] -> (Clause = Goal) ; (goal_list_to_seq(SubGoals,SubGoalSeq), Clause = (Goal :- SubGoalSeq))), mh_nonzero(Sols,Fun,N,CodeMid,CodeRest) ). mh_arg(FunMatch,Arity,[sol([Arg|Args],SubGoals)|Sols],SolsSub,SolsSubMid, Fun,FunNew,N,Code,CodeRest):- nonvar(Arg), Arg =.. [FunMatch|ArgsSub], % formerly cut here - standard order ensures length(ArgsSub,Arity), % correctness for if_h in both cases !,append(Args,ArgsSub,ArgsNew), SolsSubMid = [sol(ArgsNew,SubGoals)|SolsSubRest], mh_arg(FunMatch,Arity,Sols,SolsSub,SolsSubRest,Fun,FunNew,N, Code,CodeRest). mh_arg(_,_,Sols,SolsSub,[],Fun,FunNew,N,Code,CodeRest):- NMinusOne is N-1, mh(NMinusOne,SolsSub,FunNew,Code,CodeMid), mh_nonzero(Sols,Fun,N,CodeMid,CodeRest). % ============================================================================== % Debugger / Top Level I/O % [User's Manual] % ============================================================================== % ------------------------------------------------------------------------------ % show_type(Type:type) % [User's Manual] % ------------------------------------------------------------------------------ % Displays information about Type, including appropriate features, immediate % subtypes, supertypes, and constraints. Continues by allowing to browse % super or subtypes % ------------------------------------------------------------------------------ show_type(Type):- type(Type), immed_subtypes(Type,SubTypes), ( setof(T,T2^(sub_type(T,Type), T \== Type, \+ (sub_type(T2,Type), T2 \== Type, T2 \== T, sub_type(T,T2))),SuperTypes) -> true ; SuperTypes = [] ), (current_predicate(cons,(_ cons _)) -> ((Type cons Cons goal Goal) -> true ; Type cons Cons -> Goal = none ; Cons = none, Goal = none) ; Cons = none, Goal = none ), ( join_reducible(Type) -> JoinReducible = 1 ; JoinReducible = 0), esetof(F,non_join_pres(Type,F),Fs), esetof(T,unary_branch(T,Type),Ts), ((current_predicate(portray_type_info,portray_type_info(_,_,_,_,_,_,_,_)), portray_type_info(Type,SubTypes,SuperTypes,JoinReducible,Fs,Ts,Cons,Goal)) -> true ; nl, write('TYPE: '), write(Type), nl, write('SUBTYPES: '), write_list(SubTypes), nl, write('SUPERTYPES: '), write_list(SuperTypes), ( JoinReducible == 1 -> nl,write(Type),write(' is JOIN-REDUCIBLE') ; true), ( Fs == [] -> true ; nl,write('HOMOMORPHISM CONDITION fails at: '), write_list(Fs)), ( Ts == [] -> true ; nl,write('UNARY BRANCHES from: '), write_list(Ts)), empty_assoc(EAssoc), nl, write('IMMEDIATE CONSTRAINT: '), pp_desc(Cons,EAssoc,_,EAssoc,_,22,EAssoc,_), (Goal == none -> true ; nl, write(' WITH GOAL: '), pp_goal(Goal,EAssoc,_,EAssoc,_,22,EAssoc,_) ) ), call_residue((add_to(Type,Tag,bot), deref(Tag,bot,Ref,SVs), extensionalise(Ref,SVs)),Residue), ((current_predicate(portray_mgsat,portray_mgsat(_,_,_,_)), portray_mgsat(Type,Ref,SVs,Residue)) -> true ; nl, write('MOST GENERAL SATISFIER: '), pp_fs_res_col(Ref,SVs,Residue,5),nl ), query_proceed. % ------------------------------------------------------------------------------ % show_cons(Type:type) % [User's Manual] %------------------------------------------------------------------------------- show_cons(Type):- immed_cons(Type,Cons,Goal), nl, write('Immediate Constraint for type: '),write(Type), nl, write(Cons), (Goal = true -> true ; nl, write('with goal: '), write(Goal)). % ------------------------------------------------------------------------------ % mgsat(Desc:desc) % [User's Manual] % ------------------------------------------------------------------------------ % prints out most general satisfiers of Desc % ------------------------------------------------------------------------------ mgsat(Desc):- \+ \+ (call_residue((add_to(Desc,Tag,bot), deref(Tag,bot,Ref,SVs), extensionalise(Ref,SVs)),Residue), ((current_predicate(portray_mgsat,portray_mgsat(_,_,_,_)), portray_mgsat(Desc,Ref,SVs,Residue)) -> true ; nl, write('MOST GENERAL SATISFIER OF: '), write(Desc), nl, pp_fs_res(Ref,SVs,Residue), nl ), query_proceed). % ------------------------------------------------------------------------------ % iso_desc(Desc1:desc, Desc2:desc) % ------------------------------------------------------------------------------ % checks if Desc1 and Desc2 create extensionally identical structures % ------------------------------------------------------------------------------ iso_desc(D1,D2):- add_to(D1,Tag1,bot), add_to(D2,Tag2,bot), deref(Tag1,bot,DTag1,DSVs1), deref(Tag2,bot,DTag2,DSVs2), iso_seq_act(DTag1,DSVs1,DTag2,DSVs2,done). % ------------------------------------------------------------------------------ % rec(Words:words) % [User's Manual] % ------------------------------------------------------------------------------ % basic predicate to parse Words; prints out recognized categories % one at a time % ------------------------------------------------------------------------------ rec(Words):- nl, write('STRING: '), nl, number_display(Words,0), ttynl, \+ \+ on_exception(ale(Exception), (rec(Words,Tag,SVs,Residue), ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(Words,bot,Tag,SVs,Residue)) -> true % see also gen/1 - portray_cat/5 can be called with var 1st arg. ; nl, write('CATEGORY: '),nl, ttyflush, pp_fs_res(Tag,SVs,Residue), nl ), query_proceed), alex(Exception)). % ------------------------------------------------------------------------------ % rec(Words:words,Desc:desc) % [User's Manual] % ------------------------------------------------------------------------------ % Like rec/1, but solution FSs must satisfy Desc % ------------------------------------------------------------------------------ rec(Words,Desc):- % must add code to print residues nl, write('STRING: '), nl, number_display(Words,0), ttynl, \+ \+ on_exception(ale(Exception), (rec(Words,Tag,SVs,Desc,Residue), ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(Words,Desc,Tag,SVs,Residue)) -> true ; nl, write('CATEGORY: '),nl, ttyflush, pp_fs_res(Tag,SVs,Residue),nl ), query_proceed), alex(Exception)). % ------------------------------------------------------------------------------ % rec_best(+WordsList:list(words),Desc) % [User's Manual] % ------------------------------------------------------------------------------ % Parses every list of words in WordsList until one succeeds, satisfying Desc, % or there are no more lists. If one succeeds, then rec_best/2 will backtrack % through all of its solutions that satisfy Desc, but not through the % subsequent lists of words in WordsList. rec_best([],_) :- fail. rec_best([Ws|WordsList],Desc) :- \+ \+ on_exception(ale(Exception), (if(rec(Ws,Tag,SVs,Desc,Residue), (((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(Ws,Desc,Tag,SVs,Residue)) -> true ; nl,write('STRING: '), nl,number_display(Ws,0), nl, write('CATEGORY: '),nl, ttyflush, pp_fs_res(Tag,SVs,Residue),nl ), query_proceed), rec_best(WordsList,Desc))), alex(Exception)). % ------------------------------------------------------------------------------ % rec_list(+WordsList:list(words),Desc) % [User's Manual] % ------------------------------------------------------------------------------ % Parses every list of words in WordsList until one succeeds, satisfying Desc, % or there are no more lists. Unlike rec_best/2, rec_list/2 will backtrack % through all of the solutions of a list that succeeds, and then continue % parsing the subsequent lists of words in WordsList. rec_list([],_) :- fail. rec_list([Ws|WordsList],Desc) :- \+ \+ on_exception(ale(Exception), ((rec(Ws,Tag,SVs,Desc,Residue), ((current_predcicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(Ws,Desc,Tag,SVs,Residue)) -> true ; nl,write('STRING: '), nl,number_display(Ws,0), nl, write('CATEGORY: '),nl, ttyflush, pp_fs_res(Tag,SVs,Residue),nl ), query_proceed) ; rec_list(WordsList,Desc) ), alex(Exception)). % ------------------------------------------------------------------------------ % rec_list(+WordsList:list(words),Desc,SolnsList:list(s)) % ------------------------------------------------------------------------------ % Like rec_list/2, but collects the solutions in a list of lists, one for each % list of words in WordsList. % ------------------------------------------------------------------------------ rec_list([],_,[]). rec_list([Ws|WordsList],Desc,[Solns|SolnsList]) :- bagof(soln(Tag-SVs,Residue), on_exception(ale(Exception),rec(Ws,Tag,SVs,Desc,Residue),alex(Exception)), Solns), rec_list(WordsList,Desc,SolnsList). % ------------------------------------------------------------------------------ % lex(Word:word) % [User's Manual] % ------------------------------------------------------------------------------ % prints out all categories for Word, querying user in between % ------------------------------------------------------------------------------ lex(Word):- on_exception(ale(Exception), (current_predicate(lex,lex(_,_)) -> call_residue((if(lex(Word,FS), extensionalise(FS), raise_exception(ale(unk_word(Word)))), deref(FS,Tag,SVs)),Residue), ((current_predicate(portray_lex,portray_lex(_,_,_,_)), portray_lex(Word,Tag,SVs,Residue)) -> true ; nl, write('WORD: '), write(Word), nl, write('ENTRY: '), nl, pp_fs_res(Tag,SVs,Residue), nl ), query_proceed ; raise_exception(ale(no_lex))), alex(Exception)). % ------------------------------------------------------------------------------ % query(GoalDesc:goal_desc) % [User's Manual] % ------------------------------------------------------------------------------ % given a goal description GoalDesc, finds most general satisfier of it % and then calls it as a goal % ------------------------------------------------------------------------------ query(GoalDesc):- % must add code to print residues \+ \+ (nl, empty_assoc(AssocIn), call_residue((query_goal(GoalDesc,Args,[],Goal,Zip), % call(Goal), --- query_goal/5 now calls its Goal Zip = [], % Args isn't well-formed until we instantiate this. extensionalise_list(Args)),Residue), \+ \+ (((current_predicate(portray_ale_goal,portray_ale_goal(_,_)), portray_ale_goal(Goal,Residue)) -> true ; build_iqs(Residue,Iqs,FSResidue), (show_res -> residue_args(FSResidue,ResArgs,Args) ; ResArgs = Args), duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid), duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_), pp_goal(Goal,DupsMid2,DupsMid3,AssocIn,VisMid2,0,AssocIn,HDMid), nl,nl, pp_iqs(Iqs,DupsMid3,DupsOut,VisMid2,VisOut,0,HDMid,HDOut), ((show_res,FSResidue \== []) -> nl,nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_) ; true), nl ), query_proceed) ). query_goal(GD) :- query_goal(GD,_,_,_,[]). % instantiating Zip now guarantees no Arg suspensions. query_goal(GD,DtrCats,DtrCatsRest,G,Zip) :- empty_assoc(NVs), on_exception(cut,query_goal0(GD,DtrCats,DtrCatsRest,G,NVs,Zip),fail). % IS THIS EXCEPTION HANDLER PROPERLY PLACED? WHAT TO DO ABOUT RULE % ATTACHMENTS WITH EXPOSED CUTS? query_goal0((GD1,GD2),DtrCats,DtrCatsRest,(G1,G2),NVs,Zip):- !, query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip), query_goal0(GD2,DtrCatsMid,DtrCatsRest,G2,NVs,Zip). query_goal0((GD1 -> GD2 ; GD3),DtrCats,DtrCatsRest,(G1 -> G2 ; G3),NVs,Zip) :- !,( query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip) -> query_goal0(GD2,DtrCatsMid,DtrCatsMid2,G2,NVs,Zip), nv_replace_body(GD3,G3,DtrCatsMid2,DtrCatsRest,NVs) ; query_goal0(GD3,DtrCatsMid2,DtrCatsRest,G3,NVs,Zip), nv_replace_body(GD1,G1,DtrCats,DtrCatsMid,NVs), nv_replace_body(GD2,G2,DtrCatsMid,DtrCatsMid2,NVs) ). query_goal0((GD1;GD2),DtrCats,DtrCatsRest,(G1;G2),NVs,Zip):- !,( query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip), nv_replace_body(GD2,G2,DtrCatsMid,DtrCatsRest,NVs) ; query_goal0(GD2,DtrCatsMid,DtrCatsRest,G2,NVs,Zip), nv_replace_body(GD1,G1,DtrCats,DtrCatsMid,NVs) ). query_goal0((\+ GD1),DtrCats,DtrCatsRest,(\+ G1),NVs,_) :- !, \+ query_goal0(GD1,_,_,_,NVs,_), nv_replace_body(GD1,G1,DtrCats,DtrCatsRest,NVs). query_goal0(prolog(Hook),DtrCats,DtrCats,prolog(Hook),_NVs,_) :- !, call(Hook). query_goal0(prolog(NVs,Hook),DtrCats,DtrCats,prolog(NVs,Hook),NVs,_) :- !, call(Hook). query_goal0(when(Cond,Body),DtrCats,DtrCatsRest,when(NCond,Goal),NVs,Zip) :- !, query_cond(Cond,NCond,Body,DtrCats,DtrCatsRest,Goal,NVs,Zip,_). query_goal0(true,DtrCats,DtrCats,true,_,_) :- !. query_goal0(fail,_,_,_,_,_) :- !, fail. query_goal0(!,DtrCats,DtrCats,!,_,_) :- !, ( true ; raise_exception(cut) ). query_goal0((GD1 -> GD2),DtrCats,DtrCatsRest,(G1 -> G2),NVs,Zip) :- !,( query_goal0(GD1,DtrCats,DtrCatsMid,G1,NVs,Zip) -> query_goal0(GD2,DtrCatsMid,DtrCatsRest,G2,NVs,Zip) ). query_goal0((Desc1 =@ Desc2),[Tag1Out-SVs1Out,Tag2Out-SVs2Out|DtrCatsMid],DtrCatsRest, ((Tag1Out-SVs1Out) =@ (Tag2Out-SVs2Out)),NVs,_) :- !, nv_replace_desc(Desc1,NDesc1,DtrCatsMid,DtrCatsMid2,NVs), add_to(NDesc1,Tag1,bot), nv_replace_desc(Desc2,NDesc2,DtrCatsMid2,DtrCatsRest,NVs), add_to(NDesc2,Tag2,bot), deref(Tag1,bot,DTag1,DSVs1), deref(Tag2,bot,DTag2,DSVs2), ext_act(fs(DTag1,DSVs1,fs(DTag2,DSVs2,fsdone)),edone), deref(DTag1,DSVs1,Tag1Out,SVs1Out), deref(DTag2,DSVs2,Tag2Out,SVs2Out), (Tag1Out == Tag2Out). query_goal0((Desc1 = Desc2),[TagOut-SVsOut,TagOut-SVsOut|DtrCatsMid],DtrCatsRest, ((TagOut-SVsOut) = (TagOut-SVsOut)),NVs,_) :- !, nv_replace_desc(Desc1,NDesc1,DtrCatsMid,DtrCatsMid2,NVs), add_to(NDesc1,Tag,bot), nv_replace_desc(Desc2,NDesc2,DtrCatsMid2,DtrCatsRest,NVs), deref(Tag,bot,TagMid,SVsMid), add_to(NDesc2,TagMid,SVsMid), deref(Tag,bot,TagOut,SVsOut). query_goal0(AtGD,DtrCats,DtrCatsRest,Goal,NVs,_):- AtGD =.. [Rel|ArgDescs], query_goal_args(ArgDescs,DtrCats,DtrCatsRest,GoalArgs,NVs), cat_atoms('fs_',Rel,CompiledRel), AtG =.. [CompiledRel|GoalArgs], Goal =.. [Rel|GoalArgs], call(AtG). query_goal_args([],DtrCats,DtrCats,[],_). query_goal_args([D|Ds],[FS|DtrCats],DtrCatsRest,[FS|GArgs],NVs):- nv_replace_desc(D,ND,DtrCats,DtrCatsMid,NVs), FS = Tag-bot, add_to(ND,Tag,bot), query_goal_args(Ds,DtrCatsMid,DtrCatsRest,GArgs,NVs). query_cond(X^(Cond),Fresh^(NCond),Body,DtrCats,DtrCatsRest,NBody,NVs,Zip,FreshNVs) :- !, % ['non-variable',X,used,in,quantifier] if_error nonvar(X), - do we need this? % References might make it difficult to index instantiated narrow vars, % and we can't tell one from another Tag-SVs in prolog hooks. (var(Zip) -> when(nonvar(FreshNVs),get_assoc(X,FreshNVs,seen(Fresh))) ; true), % nonvar(Zip) means don't care about Fresh put_assoc(X,NVs,unseen,NVsMid), query_cond(Cond,NCond,Body,DtrCats,DtrCatsRest,NBody,NVsMid,Zip,FreshNVs). query_cond(Cond,NCond,Body,DtrCats,DtrCatsRest,NBody,NVs,Zip,FreshNVs) :- var(Zip), !, when(nonvar(FreshNVs),nv_replace_cond0(Cond,NCond,DtrCats,DtrCatsMid,FreshNVs)), when(nonvar(Zip),(var(FreshNVs) -> map_assoc(nv_fresh,NVs,NVsSeen), nv_replace_body(Body,NBody,DtrCatsMid,DtrCatsRest, NVsSeen), FreshNVs = NVsSeen % FreshNVs must be well-formed when bound ; true)), transform_cond(Cond,CUFCond), query_cond0(CUFCond,(map_assoc(nv_fresh,NVsOut,NVsSeen), FreshNVs = NVsSeen, % FreshNVs must be well-formed when bound query_goal0(Body,DtrCatsMid,DtrCatsRest,NBody,FreshNVs,Zip)), NVs,NVsOut). query_cond(Cond,_,Body,_,_,_,NVs,Zip,_) :- % nonvar(Zip) - so forget about NCond, NBody, FreshNVs, and DtrCats-Rest transform_cond(Cond,CUFCond), query_cond0(CUFCond,(map_assoc(nv_fresh,NVsOut,NVsSeen), query_goal0(Body,_,_,_,NVsSeen,Zip)), NVs,NVsOut). query_cond0([Cond1|Cond2],WBody,NVs,FreshNVs) :- query_cond0_act(Cond2,Cond1,WBody,NVs,FreshNVs). query_cond0_act([],(C1;C2),WBody,NVs,NVsOut) :- !, when(nonvar(Trigger),(Trigger == 0 -> NVsOut = NVsOut0 ; NVsOut = NVsOut1)), query_cond0(C1,(Trigger = 0 -> WBody ; true),NVs,NVsOut0), query_cond0(C2,(Trigger = 1 -> WBody ; true),NVs,NVsOut1). query_cond0_act([],FS=Desc,WBody,NVs,NVsOut) :- [narrowly,quantified,variable,used,on,'LHS',of,delay,FS=Desc] if_error get_assoc(FS,NVs,unseen), query_cond_desc(Desc,FS,WBody,NVs,NVsOut). query_cond0_act([Cond|CondRest],FS=Desc,WBody,NVs,NVsOut) :- [narrowly,quantified,variable,used,on,'LHS',of,delay,FS=Desc] if_error get_assoc(FS,NVs,unseen), query_cond_desc(Desc,FS,query_cond0_act(CondRest,Cond,WBody,NVsMid,NVsOut),NVs,NVsMid). query_cond_desc(Var,FS,Body,NVs,NVsOut) :- var(Var), !, ( get_assoc(Var,NVs,unseen,NVsOut,seen(FS)) -> call(Body) ; NVsOut = NVs, when_eq(FS,Var,Body) ). query_cond_desc(F:Desc,FS,Body,NVs,NVsOut) :- introduce(F,FIntro), !, name(F,FName), append("featval_",FName,RelName), name(Rel,RelName), FGoal =.. [Rel,SVs,Tag,FSatF], when_type(FIntro,FS,(deref(FS,Tag,SVs), FGoal, query_cond_desc(Desc,FSatF,Body,NVs,NVsOut))). query_cond_desc((Path1 == Path2),FS,Body,NVs,NVsOut) :- !, expand_path(Path1,PathVar,ExpPath1), expand_path(Path2,PathVar,ExpPath2), put_assoc(PathVar,NVs,unseen,PathNVs), query_cond_desc((ExpPath1,ExpPath2),FS,Body,PathNVs,NVsOut). query_cond_desc((Desc1,Desc2),FS,Body,NVs,NVsOut) :- !, query_cond_desc(Desc1,FS,query_cond_desc(Desc2,FS,Body,NVsMid,NVsOut),NVs,NVsMid). query_cond_desc((a_ X),FS,Body,NVs,NVs) :- !, when_a_(X,FS,Body). query_cond_desc(Type,FS,Body,NVs,NVs) :- type(Type), !, (Type == bot -> call(Body) ; when_type(Type,FS,Body) ). query_cond_desc(FS2,FS,Body,NVs,NVsOut) :- functor(FS2,-,2), !, ( get_assoc(FS2,NVs,SeenFlag) -> ( SeenFlag = seen(FVar) -> NVsOut = NVs, when_eq(FS,FVar,Body) ; % SeenFlag = unseen, put_assoc(FS2,NVs,seen(FS),NVsOut), call(Body) ) ; NVsOut = NVs, when_eq(FS,FS2,Body) ). query_cond_desc(X,_,_,_,_) :- error_msg((nl,write('unrecognised conditional: '),write(X))). pp_goal(\+ Goal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- !, write('\\+ '), write('( '), NewCol is Col+5, pp_goal(Goal,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut), nl, tab(Col), tab(3), write(')'). pp_goal((G1 -> G2 ; G3),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('( '), NewCol is Col + 3, pp_goal(G1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('-> '), pp_goal(G2,DupsMid,DupsMid2,VisMid,VisMid2,NewCol,HDMid,HDMid2), nl, tab(Col), write('; '), pp_goal(G3,DupsMid2,DupsOut,VisMid2,VisOut,NewCol,HDMid2,HDOut), nl, tab(Col), write(')'). pp_goal((Goal1;Goal2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- !, write('( '), NewCol is Col + 2, pp_goal(Goal1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('; '), pp_goal(Goal2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col), write(')'). pp_goal((Goal1,Goal2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- !, pp_goal(Goal1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, tab(Col), pp_goal(Goal2,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_goal(prolog(Hook),Dups,Dups,Vis,Vis,_,HD,HD) :- !, write(prolog(Hook)). pp_goal(prolog(NVs,Hook),Dups,Dups,Vis,Vis,_,HD,HD) :- !, write(prolog(NVs,Hook)). pp_goal(when(Cond,Goal),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('when('), NewCol is Col + 5, pp_cond(Cond,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), write(','), nl, tab(NewCol), pp_goal(Goal,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), write(')'). pp_goal(Desc1 =@ Desc2,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('('), NewCol is Col+3, pp_desc(Desc1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('=@'), nl, tab(NewCol), pp_desc(Desc2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col), write(')'). pp_goal(true,Dups,Dups,Vis,Vis,_,HD,HD) :- !, write(true). pp_goal(!,Dups,Dups,Vis,Vis,_,HD,HD) :- !, write(!). pp_goal((G1 -> G2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('( '), NewCol is Col + 3, pp_goal(G1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('-> '), pp_goal(G2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col), write(')'). pp_goal(fail,Dups,Dups,Vis,Vis,_,HD,HD) :- !, write(fail). pp_goal((Desc1 = Desc2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('('), NewCol is Col+3, pp_desc(Desc1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('='), nl, tab(NewCol), pp_desc(Desc2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col), write(')'). pp_goal(Goal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- Goal =.. [Rel|Args], write(Rel), ( Args = [] % inequation threading occupies the last two positions -> VisOut = VisIn, DupsOut = DupsIn, HDOut = HDIn ; write('('), name(Rel,Name), length(Name,N), NewCol is Col+N+1, pp_goal_args(Args,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut) ). pp_goal_args([Arg],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- % one left !, pp_desc(Arg,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut), write(')'). pp_goal_args([Arg|Args],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- pp_desc(Arg,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, tab(Col), pp_goal_args(Args,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_cond(X^(Cond),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- pp_desc(X,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), nl, tab(Col), write('^ '), NewCol is Col + 2, pp_cond(Cond,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut). pp_cond((C1,C2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- write('('), NewCol is Col + 1, pp_cond(C1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), write(','), nl, tab(NewCol), pp_cond(C2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), write(')'). pp_cond((C1;C2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- write('( '), NewCol is Col + 2, pp_cond(C1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('; '), pp_cond(C2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col), write(')'). pp_cond(FS=Desc,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- pp_desc(FS,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), nl, tab(Col), write('='), nl, tab(Col), pp_desc(Desc,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_desc(X,Dups,Dups,Vis,Vis,_,HD,HD) :- var(X), % should name these !, write(X). pp_desc(Tag-SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, pp_fs(Tag,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut). pp_desc([],Dups,Dups,Vis,Vis,_,HD,HD) :- !,write([]). pp_desc([H|T],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !,write('['), pp_desc(H,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), pp_tail(T,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_desc(F:Desc,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write_feature(F,LengthF), NewCol is Col + LengthF +1, pp_desc(Desc,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut). pp_desc(@ Macro,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- write('@ '), NewCol is Col + 2, pp_desc(Macro,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut). % will fall through to function clause pp_desc((D1,D2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('('), NewCol is Col + 1, pp_desc(D1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), write(','), nl, tab(NewCol), pp_desc(D2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), write(')'). pp_desc((D1;D2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- !, write('( '), NewCol is Col + 2, pp_desc(D1,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid), nl, tab(Col), write('; '), pp_desc(D2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut), nl, tab(Col), write(')'). pp_desc((=\= Desc),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('=\\= '), NewCol is Col+4, pp_desc(Desc,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut). pp_desc(Path1 == Path2,Dups,Dups,Vis,Vis,_,HD,HD) :- !, write(Path1),write(' == '),write(Path2). pp_desc(a_ X,Dups,Dups,Vis,Vis,_,HD,HD) :- !, write('a_ '),write(X). pp_desc(Other,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- % handles types, functions and macros Other =.. [Head|Args], write(Head), ( Args = [] -> VisOut = VisIn, DupsOut = DupsIn, HDOut = HDIn ; write('('), name(Head,Name), length(Name,N), NewCol is Col + N + 1, pp_descs(Args,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut) ). pp_descs([Desc],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, pp_desc(Desc,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut), write(')'). pp_descs([D|Ds],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- pp_desc(D,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, tab(Col), pp_descs(Ds,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_tail([],Dups,Dups,Vis,Vis,_,HD,HD) :- !,write(']'). pp_tail([H|T],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !,write(','),pp_desc(H,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), pp_tail(T,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_tail(NonList,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- write('|'),pp_desc(NonList,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut), write(']'). % ------------------------------------------------------------------------------ % mg_sat_fun(FunDesc,Fun,IqsIn,IqsOut) eval % ------------------------------------------------------------------------------ % Fun is most general satisfier of FunDesc % (also used for functional descriptions) % ------------------------------------------------------------------------------ %mg_sat_fun(GoalDesc,Goal,IqsIn,IqsOut):- % GoalDesc =.. [Rel|ArgDescs], % mg_sat_list(ArgDescs,Args,IqsIn,IqsOut), % Goal =.. [Rel|Args]. % ------------------------------------------------------------------------------ % mg_sat_list(GoalDescs,Goals,IqsIn,IqsOut) % ------------------------------------------------------------------------------ % maps mg_sat_fun on GoalDescs % ------------------------------------------------------------------------------ mg_sat_list([],[]). mg_sat_list([ArgDesc|ArgDescs],[Ref-bot|Args]) :- add_to(ArgDesc,Ref,bot), mg_sat_list(ArgDescs,Args). % ------------------------------------------------------------------------------ % macro(MacroName:name) % [User's Manual] % ------------------------------------------------------------------------------ % prints out possible instantiations of macro named MacroName % ------------------------------------------------------------------------------ macro(MacroName) :- % MacroName = VarName, % \+ \+ empty_assoc(AssocIn), (MacroName macro Desc), call_residue((add_to(Desc,Tag,bot), MacroName =.. [Name|MacroArgDescs], mg_sat_list(MacroArgDescs,MacroArgs), MacroSat =.. [Name|MacroArgs], ArgsOut = [Tag-bot|MacroArgs], extensionalise_list(ArgsOut)),Residue), \+ \+ (((current_predicate(portray_ale_macro,portray_ale_macro(_,_,_,_,_)), portray_ale_macro(MacroName,Desc,Tag,bot,Residue)) -> true ; build_iqs(Residue,Iqs,FSResidue), (show_res -> residue_args(FSResidue,ResArgs,ArgsOut) ; ResArgs = ArgsOut), duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid), duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_), nl, write('MACRO: '), nl, tab(4), pp_goal(MacroSat,DupsMid2,DupsMid3,AssocIn,VisMid2,4,AssocIn,HDMid), nl, write('ABBREVIATES:'), nl, tab(4), pp_fs(Tag-bot,DupsMid3,DupsMid4,VisMid2,VisMid3,4,HDMid,HDMid2), nl, nl, tab(4), pp_iqs(Iqs,DupsMid4,DupsOut,VisMid3,VisOut,4,HDMid2,HDOut), ((show_res,FSResidue \== []) -> nl, nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_) ; true),nl ), query_proceed). %insert_vars(MacroName,VarName):- % MacroName =.. [Rel|Args], % insert_vars_list(Args,ArgsVars), % VarName =.. [Rel|ArgsVars]. %insert_vars_list([],[]). %insert_vars_list([X|Xs],[(_,X)|XsVar]):- % insert_vars_list(Xs,XsVar). % ------------------------------------------------------------------------------ % empty % [User's Manual] % ------------------------------------------------------------------------------ % displays empty categories % ------------------------------------------------------------------------------ empty:- call_residue((empty_cat(I,-1,Tag,SVs,Dtrs,RuleName), extensionalise(Tag,SVs)),Residue), length(Dtrs,ND), print_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue). print_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue) :- ((current_predicate(portray_empty,portray_empty(_,_,_,_,_,_,_)), portray_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue)) -> true ; nl, write('EMPTY CATEGORY: '), pp_fs_res_col(Tag,SVs,Residue,4), (no_interpreter -> true ; nl, write(' index: '),(functor(I,empty,2) -> arg(1,I,E), write(E) ; write(I)), nl, write(' rule: '),write(RuleName), nl, write(' # of dtrs: '),write(ND) ), nl ), (no_interpreter -> query_proceed ; query_empty(I,Tag,SVs,Dtrs,RuleName,ND,Residue) ). query_empty(I,Tag,SVs,Dtrs,RuleName,ND,Res) :- write('Action(dtr-#,continue,abort)? '), nl,read(Response), query_empty_act(Response,I,Tag,SVs,Dtrs,RuleName,ND,Res). query_empty_act(continue,_,_,_,_,_,_,_) :- !,fail. query_empty_act(abort,_,_,_,_,_,_,_) :- !,abort. query_empty_act(dtr-D,I,Tag,SVs,Dtrs,RuleName,ND,Res) :- nth_index(Dtrs,D,empty(DI,-1),-1,-1,DTag,DSVs,DDtrs,DRule,DResidue), !,length(DDtrs,DND), ( print_empty(DI,DTag,DSVs,DDtrs,DRule,DND,DResidue) ; print_empty(I,Tag,SVs,Dtrs,RuleName,ND,Res) ). query_empty_act(_,I,Tag,SVs,Dtrs,RuleName,ND,Res) :- !,query_empty(I,Tag,SVs,Dtrs,RuleName,ND,Res). % ------------------------------------------------------------------------------ % edge(N:int, M:int) % [User's Manual] % ------------------------------------------------------------------------------ % prints out edges from N to M, querying user in between % ------------------------------------------------------------------------------ edge(I) :- (I < 0 -> call_residue(empty_cat(I,N,Tag,SVs,Dtrs,RuleName),Residue), M = N ; call_residue(clause(edge(I,M,N,Tag,SVs,Dtrs,RuleName),true),Residue) ) -> (nl, write('COMPLETED CATEGORY SPANNING: '), write_out(M,N), nl, edge_act(I,M,N,Tag,SVs,Dtrs,RuleName,Residue)) ; error_msg((nl,write('edge/1: edge has been retracted'),nl)). edge(M,N):- (M < N -> (M >=0 -> nl, write('COMPLETED CATEGORIES SPANNING: '), write_out(M,N), nl, call_residue(clause(edge(I,M,N,Tag,SVs,Dtrs,RuleName),true),Residue), % not indexed nl, edge_act(I,M,N,Tag,SVs,Dtrs,RuleName,Residue), fail ; error_msg((nl,write('edge/2: arguments must be non-negative')))) ; error_msg((nl,write('edge/2: first argument must be < second argument'))) ). edge_act(I,M,N,Tag,SVs,Dtrs,RuleName,Residue) :- length(Dtrs,ND), print_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Residue). print_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Residue) :- ((current_predicate(portray_edge,portray_edge(_,_,_,_,_,_,_,_)), portray_edge(I,M,N,Tag,SVs,RuleName,ND,Residue)) -> true ; nl,pp_fs_res(Tag,SVs,Residue), (no_interpreter -> true ; nl,write('Edge created for category above: '), nl,write(' index: '),(functor(I,empty,2) -> arg(1,I,E), write(E) ; write(I)), nl,write(' from: '),write(M),write(' to: '),write(N), nl,write(' string: '),write_out(M,N), nl,write(' rule: '),write(RuleName), nl,write(' # of dtrs: '),write(ND) ), nl ), (no_interpreter -> query_proceed ; query_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Residue) ). query_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res) :- nl,write('Action(retract,dtr-#,continue,abort)? '), nl,read(Response), query_edgeout_act(Response,I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res). query_edgeout_act(retract,I,M,_,_,_,_,_,_,_) :- retract(edge(I,M,_,_,_,_,_)), % will fail on empty cats !. query_edgeout_act(dtr-D,I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res) :- nth_index(Dtrs,D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DResidue), !,length(DDtrs,DND), print_dtr_edge(D,DI,DLeft,DRight,DTag,DSVs,DDtrs,DRule,DND,DResidue), print_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res). query_edgeout_act(continue,_,_,_,_,_,_,_,_,_) :- !. query_edgeout_act(abort,_,_,_,_,_,_,_,_,_) :- !,abort. query_edgeout_act(_,I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res) :- query_edgeout(I,M,N,Tag,SVs,Dtrs,RuleName,ND,Res). write_out(M,N):- parsing(Ws), all_but_first(M,Ws,WsRest), K is N-M, write_first(K,WsRest). all_but_first(0,Ws,Ws):-!. all_but_first(M,[_|Ws],WsOut):- K is M-1, all_but_first(K,Ws,WsOut). write_first(0,_):-!. write_first(N,[W|Ws]):- write(W), write(' '), K is N-1, write_first(K,Ws). % ------------------------------------------------------------------------------ % lex_rule(RuleName:name) % [User's Manual] % ------------------------------------------------------------------------------ % Displays lexical rule with name RuleName % ------------------------------------------------------------------------------ lex_rule(RuleName):- % \+ \+ % lexrule2(RuleName). %lexrule2(RuleName):- ( (RuleName lex_rule Desc1 **> Desc2 if Cond morphs Morphs) ; (RuleName lex_rule Desc1 **> Desc2 morphs Morphs), Cond = true ), empty_assoc(AssocIn), call_residue((add_to(Desc1,Tag1,bot), add_to(Desc2,Tag2,bot), nv_replace_body(Cond,Goal,Args,[],AssocIn), ArgsOut = [Tag1-bot,Tag2-bot|Args], extensionalise_list(ArgsOut)),Residue), \+ \+ (((current_predicate(portray_lex_rule,portray_lex_rule(_,_,_,_,_,_,_,_,_,_)), portray_lex_rule(RuleName,Desc1,Desc2,Tag1,bot,Tag2,bot,Residue,Goal,Morphs)) -> true ; build_iqs(Residue,Iqs,FSResidue), nl, write('LEX RULE: '), write(RuleName), (show_res -> residue_args(FSResidue,ResArgs,ArgsOut) ; ResArgs = ArgsOut), duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid), duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_), nl, write('INPUT CATEGORY: '), nl, tab(4), pp_fs(Tag1,bot,DupsMid2,DupsMid3,AssocIn,VisMid2,4,AssocIn,HDMid), nl, write('OUTPUT CATEGORY: '), nl, tab(4), pp_fs(Tag2,bot,DupsMid3,DupsMid4,VisMid2,VisMid3,4,HDMid,HDMid2), ( Cond = true -> VisMid4 = VisMid3, DupsMid5 = DupsMid4, HDMid3 = HDMid2 ; nl, write('CONDITION: '), nl, tab(4), pp_goal(Goal,DupsMid4,DupsMid5,VisMid3,VisMid4,4,HDMid2,HDMid3) ), nl, write('MORPHS: '), numbervars(Morphs,0,_), pp_morphs(Morphs), nl, nl, tab(4), pp_iqs(Iqs,DupsMid5,DupsOut,VisMid4,VisOut,4,HDMid3,HDOut), ((show_res,FSResidue \== []) -> nl,nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_) ; true ),nl ), query_proceed). pp_morphs((Morph,Morphs)):- !, nl, tab(4), pp_morph(Morph), pp_morphs(Morphs). pp_morphs(Morph):- nl, tab(4), pp_morph(Morph). pp_morph((P1 becomes P2)):- pp_patt(P1), write(' becomes '), pp_patt(P2). pp_morph((P1 becomes P2 when Cond)):- pp_patt(P1), write(' becomes '), pp_patt(P2), nl, tab(8), write('when '), write(Cond). pp_patt((X,Xs)):- !, pp_at_patt(X), write(','), pp_patt(Xs). pp_patt(X):- pp_at_patt(X). pp_at_patt(Atom):- atom(Atom), !, name(Atom,Codes), make_char_list(Codes,Chars), write(Chars). pp_at_patt(List):- write(List). % ------------------------------------------------------------------------------ % show_clause(PredSpec:predspec) % [User's Manual] % ------------------------------------------------------------------------------ % Displays ALE definite clause source code % ------------------------------------------------------------------------------ show_clause(Spec):- ( (nonvar(Spec),Spec = Name/Arity) -> true ; Spec = Name ), empty_assoc(EAssoc), (Head if Body), functor(Head,Name,Arity), ((current_predicate(portray_ale_clause,portray_ale_clause(_,_)), portray_ale_clause(Head,Body)) -> true ; nl, write('HEAD: '), pp_goal(Head,EAssoc,_,EAssoc,_,6,EAssoc,_), nl, write('BODY: '), pp_goal(Body,EAssoc,_,EAssoc,_,6,EAssoc,_),nl ), query_proceed. % ------------------------------------------------------------------------------ % rule(RuleName:name) % [User's Manual] % ------------------------------------------------------------------------------ % Displays rule with name RuleName % ------------------------------------------------------------------------------ rule(RuleName):- clause(alec_rule(RuleName,DtrsDesc,_,Moth,_,_),true), % (RuleName rule Moth ===> DtrsDesc), nl, write('RULE: '), write(RuleName), empty_assoc(AssocIn), call_residue((satisfy_dtrs(DtrsDesc,DtrCats,[],Dtrs,gdone), add_to(Moth,TagMoth,bot), CatsOut = [TagMoth-bot|DtrCats], extensionalise_list(CatsOut)),Residue), \+ \+ (((current_predicate(portray_rule,portray_rule(_,_,_,_)), portray_rule(TagMoth,bot,Dtrs,Residue)) -> true ; build_iqs(Residue,Iqs,FSResidue), (show_res -> residue_args(FSResidue,ResArgs,CatsOut) ; ResArgs = CatsOut), duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid), duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_), nl, nl, write('MOTHER: '), nl, nl, tab(2), pp_fs(TagMoth,bot,DupsMid2,DupsMid3,AssocIn,VisMid2,2,AssocIn,HDMid), nl, nl, write('DAUGHTERS/GOALS: '), show_rule_dtrs(Dtrs,DupsMid3,DupsMid4,VisMid2,VisMid3,HDMid,HDMid2), nl,nl, tab(2), pp_iqs(Iqs,DupsMid4,DupsOut,VisMid3,VisOut,2,HDMid2,HDOut), ((show_res,FSResidue \== []) -> nl, nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_) ; true), nl ), query_proceed). show_rule_dtrs([],Dups,Dups,Vis,Vis,HD,HD). show_rule_dtrs([(cat> C)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):- !,nl, nl, write('CAT '), pp_fs(C,DupsIn,DupsMid,VisIn,VisMid,5,HDIn,HDMid), show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut). % 5/1/96 - Octav -- added clause for sem_head> label show_rule_dtrs([(sem_head> C)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):- !,nl, nl, write('SEM_HEAD '), pp_fs(C,DupsIn,DupsMid,VisIn,VisMid,10,HDIn,HDMid), show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut). show_rule_dtrs([(cats> Cs)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):- !,nl, nl, write('CATs '), pp_fs(Cs,DupsIn,DupsMid,VisIn,VisMid,5,HDIn,HDMid), show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut). show_rule_dtrs([(goal> G)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):- !,nl, nl, write('GOAL '), pp_goal(G,DupsIn,DupsMid,VisIn,VisMid,6,HDIn,HDMid), show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut). % 6/1/97 - Octav -- added clause for sem_goal> label show_rule_dtrs([(sem_goal> G)|Dtrs],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut):- nl, nl, write('SEM_GOAL '), pp_goal(G,DupsIn,DupsMid,VisIn,VisMid,10,HDIn,HDMid), show_rule_dtrs(Dtrs,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut). satisfy_dtrs((cat> Desc),[Tag-bot|DtrCatsRest],DtrCatsRest, [(cat> Tag-bot)],Goals):- !, add_to(Desc,Tag,bot), nv_replace_goals(Goals). % must postpone to make sure all variables that % will be instantiated are instantiated. % 5/1/96 - Octav -- added clause for sem_head> label satisfy_dtrs((sem_head> Desc),[Tag-bot|DtrCatsRest],DtrCatsRest, [(sem_head> Tag-bot)],Goals):- !, add_to(Desc,Tag,bot), nv_replace_goals(Goals). satisfy_dtrs((cats> Descs),[Tag-bot|DtrCatsRest],DtrCatsRest, [(cats> Tag-bot)],Goals) :- !, add_to(Descs,Tag,bot), nv_replace_goals(Goals). satisfy_dtrs(remainder(RTag,RSVs),[RTag-RSVs|DtrCatsRest],DtrCatsRest, [(cats> RTag-RSVs)],Goals) :- !, nv_replace_goals(Goals). satisfy_dtrs((goal> GoalDesc),DtrCats,DtrCatsRest, [(goal> Goal)],Goals):- !, nv_replace_goals(goal(GoalDesc,Goal,DtrCats,DtrCatsRest,Goals)). % satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut). % 6/1/97 - Octav -- added clause for sem_goal> label satisfy_dtrs((sem_goal> GoalDesc),DtrCats,DtrCatsRest, [(sem_goal> Goal)],Goals):- !, nv_replace_goals(goal(GoalDesc,Goal,DtrCats,DtrCatsRest,Goals)). % satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsRest,Goal,IqsIn,IqsOut). satisfy_dtrs(((cat> Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest, [(cat> Tag-bot)|DtrsSats],Goals):- !, add_to(Desc,Tag,bot), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals). % 5/1/96 - Octav -- added clause for sem_head> label satisfy_dtrs(((sem_head> Desc),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest, [(sem_head> Tag-bot)|DtrsSats],Goals):- !, add_to(Desc,Tag,bot), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals). satisfy_dtrs(((cats> Descs),Dtrs),[Tag-bot|DtrCatsMid],DtrCatsRest, [(cats> Tag-bot)|DtrsSats],Goals):- !, add_to(Descs,Tag,bot), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals). satisfy_dtrs((remainder(RTag,RSVs),Dtrs),[RTag-RSVs|DtrCatsMid],DtrCatsRest, [(cats> RTag-RSVs)|DtrsSats],Goals) :- !, satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats,Goals). satisfy_dtrs(((goal> GoalDesc),Dtrs),DtrCats,DtrCatsRest, [goal> Goal|DtrsSats],Goals):- % satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsMid,Goal,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats, goal(GoalDesc,Goal,DtrCats,DtrCatsMid,Goals)). % 6/1/97 - Octav -- added clause for sem_goal> label satisfy_dtrs(((sem_goal> GoalDesc),Dtrs),DtrCats,DtrCatsRest, [sem_goal> Goal|DtrsSats],Goals):- % satisfy_dtrs_goal(GoalDesc,DtrCats,DtrCatsMid,Goal,IqsIn,IqsMid), satisfy_dtrs(Dtrs,DtrCatsMid,DtrCatsRest,DtrsSats, goal(GoalDesc,Goal,DtrCats,DtrCatsMid,Goals)). %satisfy_dtrs_goal((GD1,GD2),DtrCats,DtrCatsRest, % (G1,G2),IqsIn,IqsOut,NVs):- % !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs), % satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut,NVs). %satisfy_dtrs_goal((GD1 -> GD2 ; GD3),DtrCats,DtrCatsRest, % (G1 -> G2 ; G3),IqsIn,IqsOut,NVs) :- % !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs), % satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsMid2,G2,IqsMid,IqsMid2,NVs), % satisfy_dtrs_goal(GD3,DtrCatsMid2,DtrCatsRest,G3,IqsMid2,IqsOut,NVs). %satisfy_dtrs_goal((GD1;GD2),DtrCats,DtrCatsRest,(G1;G2),IqsIn,IqsOut,NVs):- % !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs), % satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut,NVs). %satisfy_dtrs_goal((\+ GD1),DtrCats,DtrCatsRest,(\+ G1),IqsIn,IqsOut,NVs):- % !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsRest,G1,IqsIn,IqsOut,NVs). %satisfy_dtrs_goal(prolog(Hook),DtrCats,DtrCats,prolog(Hook),Iqs,Iqs,_) :- % !. %satisfy_dtrs_goal(when(Cond,Body),DtrCats,DtrCatsRest,when(NCond,NBody),Iqs,Iqs,NVs) :- % !, satisfy_dtrs_cond(Cond,NCond,Body,NBody,DtrCats,DtrCatsRest,NVs). %satisfy_dtrs_goal((GD1 -> GD2),DtrCats,DtrCatsRest,(G1 -> G2),IqsIn,IqsOut,NVs) :- % !, satisfy_dtrs_goal(GD1,DtrCats,DtrCatsMid,G1,IqsIn,IqsMid,NVs), % satisfy_dtrs_goal(GD2,DtrCatsMid,DtrCatsRest,G2,IqsMid,IqsOut,NVs). %satisfy_dtrs_goal(AtGD,DtrCats,DtrCatsRest,AtG,IqsIn,IqsOut,NVs):- % AtGD =.. [Rel|ArgDescs], % same_length(ArgDescs,Args), % AtG =.. [Rel|Args], % satisfy_dtrs_goal_args(ArgDescs,DtrCats,DtrCatsRest,Args,IqsIn,IqsOut,NVs). %satisfy_dtrs_goal_args([],DtrCats,DtrCats,[],Iqs,Iqs,_). %satisfy_dtrs_goal_args([D|Ds],[Tag-bot|DtrCats],DtrCatsRest,[Tag-bot|Args], % IqsIn,IqsOut):- % add_to(D,Tag,bot,IqsIn,IqsMid), % satisfy_dtrs_goal_args(Ds,DtrCats,DtrCatsRest,Args,IqsMid,IqsOut). % ============================================================================== % Pretty Printing % [User's Manual] % ============================================================================== % ------------------------------------------------------------------------------ % pp_fs(FS:fs,Iqs:ineqs) % ------------------------------------------------------------------------------ % pretty prints FS with inequations Iqs % ------------------------------------------------------------------------------ pp_fs(FS):- pp_fs_col(FS,0). pp_fs(Ref,SVs) :- pp_fs_col(Ref,SVs,0). pp_fs_col(FS,N):- \+ \+ ( empty_assoc(AssocIn), duplicates(FS,AssocIn,DupsMid,AssocIn,_,0,_), nl, tab(N), pp_fs(FS,DupsMid,_,AssocIn,_,N,AssocIn,_)). pp_fs_col(Ref,SVs,N):- \+ \+ ( empty_assoc(AssocIn), duplicates(Ref,SVs,AssocIn,DupsMid,AssocIn,_,0,_), nl, tab(N), pp_fs(Ref,SVs,DupsMid,_,AssocIn,_,N,AssocIn,_)). pp_fs_res(Ref,SVs,Residue) :- pp_fs_res_col(Ref,SVs,Residue,0). pp_fs_res_col(Ref,SVs,Residue,Col) :- empty_assoc(AssocIn), build_iqs(Residue,Iqs,FSResidue), (show_res -> residue_args(FSResidue,ResArgs,[Ref-SVs]) ; ResArgs = [Ref-SVs]), duplicates_list(ResArgs,AssocIn,DupsMid,AssocIn,VisMid,0,NumMid), duplicates_iqs(Iqs,DupsMid,DupsMid2,VisMid,_,NumMid,_), pp_fs(Ref,SVs,DupsMid2,DupsMid3,AssocIn,VisMid2,Col,AssocIn,HDMid), nl,nl, tab(Col), pp_iqs(Iqs,DupsMid3,DupsOut,VisMid2,VisOut,0,HDMid,HDOut), ((show_res,FSResidue\==[]) -> nl,nl, write('Residue:'), pp_residue(FSResidue,DupsOut,_,VisOut,_,HDOut,_) ; true ). % ------------------------------------------------------------------------------ % duplicates(FS:fs, Iqs:ineqs, % VisIn:refs, VisOut:refs, NumIn:int, NumOut:int) % ------------------------------------------------------------------------------ % DupsOut is the result of adding the duplicate references % in FS and Iqs to those in DupsIn. VisIn are those nodes already % visited and VisOut are those visited in FS. NumIn is % the current number for variables and NumOut is the % next available after numbering only the shared refs in FS. % ------------------------------------------------------------------------------ %duplicates(FS,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :- % duplicates_fs(FS,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid). % duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). %duplicates(Ref,SVs,Iqs,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :- % duplicates_fs(Ref,SVs,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid), % duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). duplicates(FS,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):- deref(FS,Ref,SVs), ( get_assoc(Ref,DupsIn,_) -> VisOut = VisIn, NumOut = NumIn, DupsOut = DupsIn ; (get_assoc(Ref,VisIn,_) -> put_assoc(Ref,DupsIn,NumIn,DupsOut), NumOut is NumIn + 1, VisOut = VisIn ; ((SVs = a_ _) -> put_assoc(Ref,VisIn,_,VisOut), NumOut = NumIn, DupsOut = DupsIn ; (SVs =.. [_|Vs], put_assoc(Ref,VisIn,_,VisMid), duplicates_list(Vs,DupsIn,DupsOut,VisMid,VisOut,NumIn,NumOut))))). duplicates(RefIn,SVsIn,DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):- deref(RefIn,SVsIn,Ref,SVs), ( get_assoc(Ref,DupsIn,_) -> VisOut = VisIn, NumOut = NumIn, DupsOut = DupsIn ; (get_assoc(Ref,VisIn,_) -> put_assoc(Ref,DupsIn,NumIn,DupsOut), NumOut is NumIn + 1, VisOut = VisIn ; ((SVs = a_ _) -> put_assoc(Ref,VisIn,_,VisOut), NumOut = NumIn, DupsOut = DupsIn ; (SVs =.. [_|Vs], put_assoc(Ref,VisIn,_,VisMid), duplicates_list(Vs,DupsIn,DupsOut,VisMid,VisOut,NumIn,NumOut))))). duplicates_iqs([],Dups,Dups,Vis,Vis,Num,Num). duplicates_iqs([Iq|Iqs],DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut) :- duplicates_ineq(Iq,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid), duplicates_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). duplicates_ineq(done,Dups,Dups,Vis,Vis,Num,Num). duplicates_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):- duplicates(Tag1,SVs1,DupsIn,DupsMid1,VisIn,VisMid1,NumIn,NumMid1), duplicates(Tag2,SVs2,DupsMid1,DupsMid2,VisMid1,VisMid2,NumMid1,NumMid2), duplicates_ineq(Ineqs,DupsMid2,DupsOut,VisMid2,VisOut,NumMid2,NumOut). duplicates_list([],Dups,Dups,Vis,Vis,Num,Num). duplicates_list([V|Vs],DupsIn,DupsOut,VisIn,VisOut,NumIn,NumOut):- duplicates(V,DupsIn,DupsMid,VisIn,VisMid,NumIn,NumMid), duplicates_list(Vs,DupsMid,DupsOut,VisMid,VisOut,NumMid,NumOut). % ------------------------------------------------------------------------------ % pp_iqs(Iqs:ineqs, VisIn:vars, VisOut:vars,Col:int) % ------------------------------------------------------------------------------ % pretty-prints a list of inequations, indented Col columns %------------------------------------------------------------------------------- pp_iqs([],Dups,Dups,Vis,Vis,_,HD,HD). pp_iqs([Iq|Iqs],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- arg(5,Iq,Ineqs), (Ineqs = done -> true ;write('(')), pp_ineq(Iq,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), (Ineqs = done -> true ;write(')')), (Iqs = [] -> nl ; write(','), nl, pp_iqs(Iqs,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut)). % ineq(Tag1,SVs1,Tag2,SVs2,Ineqs) pp_ineq(done,Dups,Dups,Vis,Vis,_,HD,HD). pp_ineq(ineq(Tag1,SVs1,Tag2,SVs2,Ineqs),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- tab(Col),pp_fs(Tag1,SVs1,DupsIn,DupsMid1,VisIn,VisMid1,Col,HDIn,HDMid1), write(' =\\= '), NewCol is Col+7, pp_fs(Tag2,SVs2,DupsMid1,DupsMid2,VisMid1,VisMid2,NewCol,HDMid1,HDMid2), nl, (Ineqs = done -> true ;write(';')), pp_ineq(Ineqs,DupsMid2,DupsOut,VisMid2,VisOut,Col,HDMid2,HDOut). frozen_term(Term,Frozen) :- term_variables(Term,Vars), frozen_term_act(Vars,UnsortedRes), sort(UnsortedRes,Frozen). frozen_term_act([],[]). frozen_term_act([Var|Vars],Frozen) :- frozen(Var,Goal), filter_goals(Goal,Frozen,Rest,Var), frozen_term_act(Vars,Rest). filter_goals(true,Rest,Rest,_) :- !. filter_goals((G1,G2),Frozen,Rest,Var) :- !,filter_goals(G1,Frozen,Mid,Var), filter_goals(G2,Mid,Rest,Var). filter_goals(prolog:trig_nondif(_,_,_,Trig),Frozen,Rest,_) :- !,frozen(Trig,Goal), filter_goals(Goal,Frozen,Rest,Trig). filter_goals(prolog:trig_and(_,_,_,_,Trig),Frozen,Rest,_) :- !,frozen(Trig,Goal), filter_goals(Goal,Frozen,Rest,Trig). filter_goals(prolog:trig_or(_,_,Trig),Frozen,Rest,_) :- !,frozen(Trig,Goal), filter_goals(Goal,Frozen,Rest,Trig). filter_goals(G,[[Var]-G|Rest],Rest,Var). residue_args([],Args,Args). residue_args([_-Goal|Residue],Args,ArgsRest) :- resgoal_args(Goal,Args,ArgsMid), residue_args(Residue,ArgsMid,ArgsRest). resgoal_args(prolog:when(_,_,user:when_eq0(FS1,Tag2,SVs2,WGoal)), [FS1,Tag2-SVs2|Args],ArgsRest) :- !,resgoal_args_wgoal(WGoal,Args,ArgsRest). resgoal_args(prolog:when(_,_,user:when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal)), [Tag1-SVs1,Tag2-SVs2|Args],ArgsRest) :- !,resgoal_args_wgoal(WGoal,Args,ArgsRest). resgoal_args(prolog:when(_,_,user:when_eq_a2(X1,X2,Tag1,Tag2,WGoal)), [Tag1-(a_ X1),Tag2-(a_ X2)|Args],ArgsRest) :- !,resgoal_args_wgoal(WGoal,Args,ArgsRest). resgoal_args(prolog:when(_,_,user:when_type0(_,FS,WGoal)),Args,Rest) :- !,(var(FS) -> ArgsMid = Args ; Args = [FS|ArgsMid]), resgoal_args_wgoal(WGoal,ArgsMid,Rest). resgoal_args(prolog:when(_,_,user:when_type_delayed0(_,Tag,SVs,WGoal)),[Tag-SVs|Args],ArgsRest) :- !,resgoal_args_wgoal(WGoal,Args,ArgsRest). % Should look in WGoal too resgoal_args(_,Args,Args). resgoal_args_wgoal(Var,Args,ArgsRest) :- var(Var), !,ArgsRest = Args. resgoal_args_wgoal((G1 -> G2 ; G3),Args,ArgsRest) :- !,resgoal_args_wgoal(G1,Args,ArgsMid), resgoal_args_wgoal(G2,ArgsMid,ArgsMid2), resgoal_args_wgoal(G3,ArgsMid2,ArgsRest). resgoal_args_wgoal((G1 -> G2),Args,ArgsRest) :- !,resgoal_args_wgoal(G1,Args,ArgsMid), resgoal_args_wgoal(G2,ArgsMid,ArgsRest). resgoal_args_wgoal((G1,G2),Args,ArgsRest) :- !,resgoal_args_wgoal(G1,Args,ArgsMid), resgoal_args_wgoal(G2,ArgsMid,ArgsRest). resgoal_args_wgoal((G1;G2),Args,ArgsRest) :- !,resgoal_args_wgoal(G1,Args,ArgsMid), resgoal_args_wgoal(G2,ArgsMid,ArgsRest). resgoal_args_wgoal(\+ G1,Args,ArgsRest) :- !,resgoal_args_wgoal(G1,Args,ArgsRest). resgoal_args_wgoal(when_type(_,FS,WGoal),Args,ArgsRest) :- !, ( var(FS) -> Args = ArgsMid ; Args = [FS|ArgsMid] ), resgoal_args_wgoal(WGoal,ArgsMid,ArgsRest). resgoal_args_wgoal(when_a_(_,FS,WGoal),Args,ArgsRest) :- !, ( var(FS) -> Args = ArgsMid ; Args = [FS|ArgsMid] ), resgoal_args_wgoal(WGoal,ArgsMid,ArgsRest). resgoal_args_wgoal(when_eq(FS,Var,WGoal),Args,ArgsRest) :- !, ( var(FS) -> Args = ArgsMid ; Args = [FS|ArgsMid] ), ( var(Var) -> ArgsMid = ArgsMid2 ; ArgsMid = [Var|ArgsMid2] ), resgoal_args_wgoal(WGoal,ArgsMid2,ArgsRest). resgoal_args_wgoal(ud(FS1,FS2),Args,ArgsRest) :- !, ( var(FS1) -> Args = ArgsMid ; Args = [FS1|ArgsMid]), ( var(FS2) -> ArgsMid = ArgsRest ; ArgsMid = [FS2|ArgsRest]). resgoal_args_wgoal(ud(FS1,Tag2,SVs2),Args,ArgsRest) :- !, ( var(FS1) -> Args = ArgsMid ; Args = [FS1|ArgsMid]), ( var(SVs2) -> ArgsMid = ArgsRest ; ArgsMid = [Tag2-SVs2|ArgsRest]). resgoal_args_wgoal(ud(Tag1,SVs1,Tag2,SVs2),Args,ArgsRest) :- !, ( var(SVs1) -> Args = ArgsMid ; Args = [Tag1-SVs1|ArgsMid]), ( var(SVs2) -> ArgsMid = ArgsRest ; ArgsMid = [Tag2-SVs2|ArgsRest]). resgoal_args_wgoal(deref(FS,_,_),Args,ArgsRest) :- !, (var(FS) -> Args = ArgsRest ; Args = [FS|ArgsRest]). resgoal_args_wgoal(deref(Tag,SVs,_,_),Args,ArgsRest) :- !, (var(SVs) -> Args = ArgsRest ; Args = [Tag-SVs|ArgsRest]). resgoal_args_wgoal(when_type(_,FS,WGoal),Args,ArgsRest) :- !, (var(FS) -> Args = ArgsMid ; Args = [FS|ArgsMid]), resgoal_args_wgoal(WGoal,ArgsMid,ArgsRest). resgoal_args_wgoal(FGoal,Args,ArgsRest) :- FGoal =.. [FRel|FGoalArgs], name(FRel,FRelName), append("featval_",_,FRelName), !, FGoalArgs = [SVs,Tag,ValatF], ( var(SVs) -> Args = ArgsMid ; Args = [Tag-SVs|ArgsMid]), ( var(ValatF) -> ArgsMid = ArgsRest ; ArgsMid = [ValatF|ArgsRest]). resgoal_args_wgoal(Goal,Args,ArgsRest) :- Goal =.. [_|GoalArgs], resgoal_args_wargs(GoalArgs,Args,ArgsRest). resgoal_args_wargs([],Args,Args). resgoal_args_wargs([GA|GArgs],Args,ArgsRest) :- ( var(GA) -> Args = ArgsMid ; functor(GA,-,2) -> Args = [GA|ArgsMid] ; Args = ArgsMid ), resgoal_args_wargs(GArgs,ArgsMid,ArgsRest). pp_residue([],Dups,Dups,Vis,Vis,HD,HD). pp_residue([_-Goal|Residue],DupsIn,DupsOut,VisIn,VisOut,HDIn,HDOut) :- pp_resgoal(Goal,DupsIn,DupsMid,VisIn,VisMid,HDIn,HDMid), pp_residue(Residue,DupsMid,DupsOut,VisMid,VisOut,HDMid,HDOut). % pp_resgoal(prolog:trig_nondif(_,_,_,_),Dups,Dups,Vis,Vis,HD,HD) :- !. % pp_resgoal(prolog:trig_or(_,_,_),Dups,Dups,Vis,Vis,HD,HD) :- !. pp_resgoal(prolog:when(_,_,user:when_eq0(Tag1,SVs1,Tag2,SVs2,WGoal)),DupsIn,DupsOut, VisIn,VisOut,HDIn,HDOut) :- !,nl, write('when_eq('),pp_fs(Tag1,SVs1,DupsIn,DupsMid,VisIn,VisMid,8,HDIn,HDMid), write(','), nl, write(' '), pp_fs(Tag2,SVs2,DupsMid,DupsMid2,VisMid,VisMid2,8,HDMid,HDMid2), write(','), nl, write(' '), pp_res_wgoal(WGoal,DupsMid2,DupsOut,VisMid2,VisOut,8,HDMid2,HDOut), % DupsOut = DupsMid2, VisOut = VisMid2, HDOut = HDMid2, % write(WGoal), write(')'). pp_resgoal(prolog:when(_,_,user:when_eq_a2(X1,X2,Tag1,Tag2,WGoal)),DupsIn,DupsOut, VisIn,VisOut,HDIn,HDOut) :- !,nl, write('when_eq('),pp_fs(Tag1,(a_ X1),DupsIn,DupsMid,VisIn,VisMid,8,HDIn,HDMid), write(','), nl, write(' '), pp_fs(Tag2,(a_ X2),DupsMid,DupsMid2,VisMid,VisMid2,8,HDMid,HDMid2), write(','), nl, write(' '), pp_res_wgoal(WGoal,DupsMid2,DupsOut,VisMid2,VisOut,8,HDMid2,HDOut), % DupsOut = DupsMid2, VisOut = VisMid2, HDOut = HDMid2, % write(WGoal), write(')'). pp_resgoal(prolog:when(_,_,user:when_type0(Type,FS,WGoal)),DupsIn,DupsOut, VisIn,VisOut,HDIn,HDOut) :- !,nl,write('when_type('),write(Type),write(','), name(Type,TName), length(TName,TLen), Col is 10+TLen, (var(FS) -> write(FS) ; pp_fs(FS,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid) ), write(','), nl, write(' '), pp_res_wgoal(WGoal,DupsMid,DupsOut,VisMid,VisOut,10,HDMid,HDOut), % DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid, % write(WGoal), write(')'). pp_resgoal(prolog:when(_,_,user:when_type_delayed0(Type,Tag,SVs,WGoal)),DupsIn,DupsOut, VisIn,VisOut,HDIn,HDOut) :- !,nl,write('when_type('),write(Type),write(','), name(Type,TName), length(TName,TLen), Col is 10+TLen, pp_fs(Tag,SVs,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, write(' '), pp_res_wgoal(WGoal,DupsMid,DupsOut,VisMid,VisOut,10,HDMid,HDOut), % DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid, % write(WGoal), write(')'). pp_resgoal(Goal,Dups,Dups,Vis,Vis,HD,HD) :- nl,write(Goal). % query_cond/9 prefixes pp_res_wgoal((map_assoc(nv_fresh,_,_),(_=_),query_goal0(_,_,_,NBody,_,_)),DupsIn,DupsOut, VisIn,VisOut,Col,HDIn,HDOut) :- !,pp_goal(NBody,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut). pp_res_wgoal((map_assoc(nv_fresh,_,_),query_goal0(_,_,_,NBody,_,_)),DupsIn,DupsOut, VisIn,VisOut,Col,HDIn,HDOut) :- !,pp_goal(NBody,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut). pp_res_wgoal((G1 -> G2 ; G3),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !,pp_res_wgoal(G1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), nl, tab(Col), write(' -> '), NewCol is Col + 4, pp_res_wgoal(G2,DupsMid,DupsMid2,VisMid,VisMid2,NewCol,HDMid,HDMid2), nl, tab(Col), write(' ; '), NewCol2 is Col + 3, pp_res_wgoal(G3,DupsMid2,DupsOut,VisMid2,VisOut,NewCol2,HDMid2,HDOut). pp_res_wgoal((G1,G2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !,pp_res_wgoal(G1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid), write(','), nl, tab(Col), pp_res_wgoal(G2,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_res_wgoal(\+ G,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !,write('\\+ ( '), NewCol is Col + 5, pp_res_wgoal(G,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut), nl, tab(Col), tab(3), write(')'). pp_res_wgoal(ud(FS1,FS2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, NewCol is Col + 4, ( var(FS1) -> write(FS1), DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn ; pp_fs(FS1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid) ), nl, tab(Col), write(' = '), ( var(FS2) -> write(FS2), DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid ; pp_fs(FS2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut) ). pp_res_wgoal(ud(FS1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, NewCol is Col + 4, ( var(FS1) -> write(FS1), DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn ; pp_fs(FS1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid) ), nl, tab(Col), write(' = '), ( var(SVs2) -> write(Tag2-SVs2), DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid ; pp_fs(Tag2,SVs2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut) ). pp_res_wgoal(ud(Tag1,SVs1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, NewCol is Col + 4, ( var(SVs1) -> write(Tag1-SVs1), DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn ; pp_fs(Tag1,SVs1,DupsIn,DupsMid,VisIn,VisMid,Col,HDIn,HDMid) ), nl, tab(Col), write(' = '), ( var(SVs2) -> write(Tag2-SVs2), DupsOut = DupsMid, VisOut = VisMid, HDOut = HDMid ; pp_fs(Tag2,SVs2,DupsMid,DupsOut,VisMid,VisOut,NewCol,HDMid,HDOut) ). pp_res_wgoal(deref(FS1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('deref('), NewCol is Col + 6, ( var(FS1) -> write(FS1), DupsOut = DupsIn, VisOut = VisIn, HDOut = HDIn ; pp_fs(FS1,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut) ), write(','),nl,tab(NewCol),write(Tag2), write(','),nl,tab(NewCol),write(SVs2), write(')'). pp_res_wgoal(deref(Tag1,SVs1,Tag2,SVs2),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !, write('deref('), NewCol is Col + 6, ( var(SVs1) -> write(Tag1), write(','), write(SVs1), DupsOut = DupsIn, VisOut = VisIn, HDOut = HDIn ; pp_fs(Tag1,SVs1,DupsIn,DupsOut,VisIn,VisOut,NewCol,HDIn,HDOut) ), write(','),nl,tab(NewCol),write(Tag2), write(','),nl,tab(NewCol),write(SVs2), write(')'). pp_res_wgoal(when_type(Type,FS,WGoal),DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- !,write('when_type('),write(Type),write(','), name(Type,TName), length(TName,TLen), NewCol is Col+10+TLen, (var(FS) -> write(FS), DupsMid = DupsIn, VisMid = VisIn, HDMid = HDIn ; pp_fs(FS,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid) ), write(','), nl, tab(Col), write(' '), NewCol2 is Col+10, pp_res_wgoal(WGoal,DupsMid,DupsOut,VisMid,VisOut,NewCol2,HDMid,HDOut), write(')'). pp_res_wgoal(CompGoal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- nonvar(CompGoal), CompGoal =.. [CompRel|Args], name(CompRel,CompRelName), append("fs_",RelName,CompRelName), !,name(Rel,RelName), Goal =.. [Rel|Args], pp_goal(Goal,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut). % everything else pp_res_wgoal(WGoal,Dups,Dups,Vis,Vis,_,HD,HD) :- write(WGoal). build_iqs(Residue,Iqs,FSResidue) :- empty_assoc(AssocIn), filter_iqs(Residue,[],IqsOut,AssocIn,IqFragsOut,AssocIn,TrigsOut,NonIqResidue), filter_triggers(NonIqResidue,TrigsOut,FSResidue), build_complex_iqs(IqsOut,IqFragsOut,Iqs). filter_iqs([],Iqs,Iqs,IqFrags,IqFrags,Trigs,Trigs,[]). filter_iqs([K-Goal|Residue],IqsIn,IqsOut,IqFragsIn,IqFragsOut,TrigsIn,TrigsOut,NonIqResidue) :- filter_iqs_resgoal(Goal,K,Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,TrigsIn,TrigsOut,NonIqResidue). filter_iqs_resgoal(prolog:when(Trigger,(_;ground(G)),user:ineq_resolve_decomp(_,F)),_, Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,NonIqResidue) :- !,put_assoc(Trigger,Triggers,_,TrigsMid), G =.. [_|Keys], ( var(F) -> put_assoc(F,IqFragsIn,Keys,IqFragsMid), IqsMid = IqsIn ; IqsMid = [Keys|IqsIn], IqFragsMid = IqFragsIn % if nonvar(F), then this is a root inequation ), filter_iqs(Residue,IqsMid,IqsOut,IqFragsMid,IqFragsOut,TrigsMid,TrigsOut,NonIqResidue). filter_iqs_resgoal(prolog:when(Trigger,_,user:ineq_resolve_suspend(Tag1,SVs1,Tag2,SVs2,_,F)),_, Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,NonIqResidue) :- !,put_assoc(Trigger,Triggers,_,TrigsMid), ( var(F) -> put_assoc(F,IqFragsIn,ineq(Tag1,SVs1,Tag2,SVs2,_),IqFragsMid), IqsMid = IqsIn ; IqsMid = [ineq(Tag1,SVs1,Tag2,SVs2,done)|IqsIn], IqFragsMid = IqFragsIn ), filter_iqs(Residue,IqsMid,IqsOut,IqFragsMid,IqFragsOut,TrigsMid,TrigsOut,NonIqResidue). filter_iqs_resgoal(Goal,K,Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut, [K-Goal|NonIqResRest]) :- filter_iqs(Residue,IqsIn,IqsOut,IqFragsIn,IqFragsOut,Triggers,TrigsOut,NonIqResRest). % should strip off keys here, but this is input to pp_residue/7. filter_triggers([],_,[]). filter_triggers([ResGoal|Residue],Triggers,FSResidue) :- ResGoal = _-Goal, filter_trigs_resgoal(Goal,ResGoal,Residue,Triggers,FSResidue). filter_trigs_resgoal(prolog:trig_or(_,Trigger,_),ResGoal,Residue,Triggers,FSResidue) :- !, (get_assoc(Trigger,Triggers,_) -> filter_triggers(Residue,Triggers,FSResidue) ; FSResidue = [ResGoal|FSResRest], filter_triggers(Residue,Triggers,FSResRest) ). filter_trigs_resgoal(prolog:trig_ground(_,_,_,Trigger,_),ResGoal,Residue,Triggers,FSResidue) :- !, (get_assoc(Trigger,Triggers,_) -> filter_triggers(Residue,Triggers,FSResidue) ; FSResidue = [ResGoal|FSResRest], filter_triggers(Residue,Triggers,FSResRest) ). filter_trigs_resgoal(prolog:trig_nondif(_,_,Trigger,_),ResGoal,Residue,Triggers,FSResidue) :- !, (get_assoc(Trigger,Triggers,_) -> filter_triggers(Residue,Triggers,FSResidue) ; FSResidue = [ResGoal|FSResRest], filter_triggers(Residue,Triggers,FSResRest) ). filter_trigs_resgoal(_,ResGoal,Residue,Triggers,[ResGoal|FSResRest]) :- filter_triggers(Residue,Triggers,FSResRest). build_complex_iqs([],_,[]). build_complex_iqs([IqOrList|IqOrLists],IqFrags,[Iq|Iqs]) :- ( functor(IqOrList,ineq,5) -> Iq = IqOrList ; build_complex_iqs_act(IqOrList,IqFrags,Iq,done) ), build_complex_iqs(IqOrLists,IqFrags,Iqs). build_complex_iqs_act([],_,Rest,Rest). build_complex_iqs_act([Key|Keys],IqFrags,Ineq,IneqRest) :- ( nonvar(Key) -> IneqMid = Ineq % some (but not all) disjuncts may have already failed ; get_assoc(Key,IqFrags,IqOrList) -> ( functor(IqOrList,ineq,5) -> Ineq = IqOrList, arg(5,Ineq,IneqMid) ; build_complex_iqs_act(IqOrList,IqFrags,Ineq,IneqMid) ) ; error_msg((nl,write('inequation lost in residue'))) ), build_complex_iqs_act(Keys,IqFrags,IneqMid,IneqRest). % ------------------------------------------------------------------------------ % pp_fs(FS:fs,VisIn:vars, VisOut:vars, Col:int) % ------------------------------------------------------------------------------ % prints FS where VisOut is the result of adding all of the % referents of substructures in FS to VisIn % Col is where printing begins for FS % ------------------------------------------------------------------------------ pp_fs(FS,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- deref(FS,Ref,SVs), pp_fs_act(Ref,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut). pp_fs(RefIn,SVsIn,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- deref(RefIn,SVsIn,Ref,SVs), pp_fs_act(Ref,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut). pp_fs_act(Ref,SVs,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- ( SVs = (a_ _) -> Type = SVs, FRs = [], Vs = [] ; SVs =.. [Type|Vs], approps(Type,FRs,_) ), build_keyed_feats(FRs,Vs,KeyedFeats), ( (current_predicate(portray_fs,portray_fs(_,_,_,_,_,_,_,_,_,_)), portray_fs(Type,Ref-SVs,KeyedFeats,VisIn,VisOut,DupsIn,DupsOut,Col,HDIn,HDOut)) -> true ; pp_fs_default(Type,Ref,KeyedFeats,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) ). build_keyed_feats([],[],[]). build_keyed_feats([F:Restr|FRs],[V|Vs],[fval(F,V,Restr)|KFs]) :- build_keyed_feats(FRs,Vs,KFs). pp_fs_default(Type,Ref,KeyedFeats,DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- ( get_assoc(Ref,DupsIn,TagNum) % print ref if shared (nonvar) -> write('['), write(TagNum), write('] ') ; true ), ( get_assoc(Ref,VisIn,_) -> VisOut = VisIn, DupsOut = DupsIn, HDOut = HDIn ; (Type = a_ X) -> (no_write_type_flag(a_ X) -> true ; write(a_ X) ), put_assoc(Ref,VisIn,_,VisOut), DupsOut = DupsIn, HDOut = HDIn ; put_assoc(Ref,VisIn,_,VisMid), % print FS if not already visited ( no_write_type_flag(Type) -> pp_vs_unwritten(KeyedFeats,DupsIn,DupsOut,VisMid,VisOut,Col,HDIn,HDOut) ; write(Type), pp_vs(KeyedFeats,DupsIn,DupsOut,VisMid,VisOut,Col,HDIn,HDOut) ) ). % recursive callback for portray_fs print_fs(_VarType,FS,VisIn,VisOut,TagsIn,TagsOut,Col,HDIn,HDOut) :- pp_fs(FS,TagsIn,TagsOut,VisIn,VisOut,Col,HDIn,HDOut). %------------------------------------------------------------------------------- % Write Flags % [User's Manual] %------------------------------------------------------------------------------- :- dynamic no_write_type_flag/1. :- dynamic no_write_feat_flag/1. write_types:- write_type(_). write_feats:- write_feat(_). write_type(Type):- retractall(no_write_type_flag(Type)). write_feat(Feat):- retractall(no_write_feat_flag(Feat)). no_write_type(Type):- retractall(no_write_type_flag(Type)), assert(no_write_type_flag(Type)). no_write_feat(Feat):- retractall(no_write_feat_flag(Feat)), assert(no_write_feat_flag(Feat)). % ------------------------------------------------------------------------------ % pp_vs(FRs:fs, Vs:vs, Dups:vars, % VisIn:vars, VisOut:vars, Col:int) % ------------------------------------------------------------------------------ % prints Vs at Col % ------------------------------------------------------------------------------ pp_vs([],Dups,Dups,Vis,Vis,_,HD,HD). pp_vs([fval(F,V,_)|KFs],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut) :- ( no_write_feat_flag(F) -> VisMid = VisIn, DupsMid = DupsIn, HDMid = HDIn ; nl, tab(Col), write_feature(F,LengthF), NewCol is Col + LengthF +1, pp_fs(V,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid) ), pp_vs(KFs,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). pp_vs_unwritten([],Dups,Dups,Vis,Vis,_,HD,HD). pp_vs_unwritten([fval(F,V,_)|KFs],DupsIn,DupsOut,VisIn,VisOut,Col,HDIn,HDOut):- ( no_write_feat_flag(F) -> VisMid = VisIn, DupsMid = DupsIn, HDMid = HDIn ; write_feature(F,LengthF), NewCol is Col + LengthF +1, pp_fs(V,DupsIn,DupsMid,VisIn,VisMid,NewCol,HDIn,HDMid) ), pp_vs(KFs,DupsMid,DupsOut,VisMid,VisOut,Col,HDMid,HDOut). write_feature(F,LengthF):- name(F,NameF), count_and_capitalize(NameF,0,LengthF), write(' '). write_desc_feature(F,LengthF) :- name(F,NameF), length(NameF,LengthF), write(F), write(':'). count_and_capitalize([],Length,Length). count_and_capitalize([L|Ls],LengthIn,Length):- capitalize(L,LCap), write(LCap), LengthInPlus1 is LengthIn + 1, count_and_capitalize(Ls,LengthInPlus1,Length). capitalize(X,XCap):- ( (name(a,[Name_a]), name(z,[Name_z]), Name_a =< X, X =< Name_z) -> name('A',[Name_A]), Gap is Name_A - Name_a, NameXCap is X + Gap, name(XCap,[NameXCap]) ; name(XCap,[X]) ). % ============================================================================== % Utilities % ============================================================================== % ------------------------------------------------------------------------------ % cat_atoms/3 % ------------------------------------------------------------------------------ cat_atoms(A1,A2,A3):- name(A1,L1), name(A2,L2), append(L1,L2,L3), name(A3,L3). % ------------------------------------------------------------------------------ % esetof(X:Alpha, Goal:goal, Xs:) % ------------------------------------------------------------------------------ % setof returning empty list if no solutions % ------------------------------------------------------------------------------ esetof(X,Goal,Xs) :- if(setof(X,Goal,Xs), true, (Xs = [])). % ------------------------------------------------------------------------------ % member_eq(X:term, Xs:terms) % ------------------------------------------------------------------------------ % X is strictly == equal to a member of list Xs % ------------------------------------------------------------------------------ member_eq(X,[Y|Ys]):- X==Y ; member_eq(X,Ys). % ------------------------------------------------------------------------------ % member_rest(Elt,List,Rest) % ------------------------------------------------------------------------------ % like member/2 but also returns remainder of list after Elt % ------------------------------------------------------------------------------ member_rest(Element, [Head|Tail], Rest) :- member_rest_act(Tail, Head, Element, Rest). % auxiliary to avoid choicepoint for last element member_rest_act(Rest, Element, Element, Rest). member_rest_act([Head|Tail], _, Element, Rest) :- member_rest_act(Tail, Head, Element, Rest). % ------------------------------------------------------------------------------ % select_eq(X:term, Xs:terms, XsLeft:terms) % ------------------------------------------------------------------------------ % X is strictly == equal to a member of list Xs with XsLeft left over % ------------------------------------------------------------------------------ select_eq(X,[Y|Ys],Zs):- X==Y, Zs = Ys ; Zs = [Y|Zs2], select_eq(X,Ys,Zs2). % ------------------------------------------------------------------------------ % transitive_closure(Graph:graph, Closure:graph) % ------------------------------------------------------------------------------ % Warshall's Algorithm (O'Keefe, Craft of Prolog, p. 172) % Input: Graph = [V1-Vs1,...,VN-VsN] % describes the graph G = where % * Vertices = {V1,..,VN} and % * VsI = {VJ | VI -> VJ in Edges} % Output: Closure is transitive closure of Graph in same form % SICStus Prolog's transitive_closure/2 will not add loops in case of % subsumption cycles, so we cannot use it. % ------------------------------------------------------------------------------ transitive_closure(Graph,Closure):- warshall(Graph,Graph,Closure). warshall([],Closure,Closure). warshall([V-_|G],E,Closure):- memberchk(V-Y,E), warshall(E,V,Y,NewE), warshall(G,NewE,Closure). warshall([],_,_,[]). warshall([X-Neibs|G],V,Y,[X-NewNeibs|NewG]):- memberchk(V,Neibs), !, ord_union(Neibs,Y,NewNeibs), warshall(G,V,Y,NewG). warshall([X-Neibs|G],V,Y,[X-Neibs|NewG]):- warshall(G,V,Y,NewG). % ------------------------------------------------------------------------------ % reverse_count_lex_check(ListIn:list,Acc:list,ListOut:list, % CountIn:int,CountOut:int) % ------------------------------------------------------------------------------ % using accumulators, reverses ListIn into ListOut, with initial segment % Acc; CountIn is current count (of Acc) and CountOut is result; call % by: reverse_count_lex_check(ListIn,[],ListOut,0,Count). Also verify that each % word/member of the list has an entry in the lexicon. % ------------------------------------------------------------------------------ reverse_count_lex_check([],Xs,Xs,Count,Count). reverse_count_lex_check([X|Xs],Ys,Zs,CountIn,Count):- CountInPlus1 is CountIn+1, ( \+ lex(X,_) -> raise_exception(ale(unk_word(X))) ; reverse_count_lex_check(Xs,[X|Ys],Zs,CountInPlus1,Count) ). % ------------------------------------------------------------------------------ % query_proceed % ------------------------------------------------------------------------------ % prompts user for n. response, otherwise proceeds % ------------------------------------------------------------------------------ query_proceed:- ttynl, write('ANOTHER? '), ttyflush, read(n). % ------------------------------------------------------------------------------ % number_display/2 % ------------------------------------------------------------------------------ number_display([],M):- !,write(M). % need cut for variable 1st arguments number_display([W|Ws],N):- write(N), write(' '), write(W), write(' '), SN is N + 1, number_display(Ws,SN). % ------------------------------------------------------------------------------ % error_msg(Goal:goal) % ------------------------------------------------------------------------------ % tells user, solves Goal, then goes back to old file being told % ------------------------------------------------------------------------------ error_msg(Goal):- telling(FileName), tell(user), write(' **ERROR: '), Goal, told, tell(FileName), fail. % ------------------------------------------------------------------------------ % if_error(Msg,Cond) % ------------------------------------------------------------------------------ % if condition Cond holds, provides Msg as error message; always succeeds % ------------------------------------------------------------------------------ if_error(Msg,Cond):- ( call(Cond) -> raise_exception(Msg) ; true ). % ------------------------------------------------------------------------------ % if_warning_else_fail(Msg,Cond) % ------------------------------------------------------------------------------ % if Cond holds, provides warning message Msg, otherwise fails % ------------------------------------------------------------------------------ if_warning_else_fail(Msg,Cond):- if_warning(Msg,Cond), Cond. new_if_warning_else_fail(Msg,Cond):- if(call(Cond), (print_message(warning,Msg), fail), (!,fail)) ; true. % ------------------------------------------------------------------------------ % if_warning(Msg,Cond) % ------------------------------------------------------------------------------ % if condition Cond holds, prints out Msg; always succeeds % ------------------------------------------------------------------------------ if_warning(Msg,Cond):- telling(FileName), tell(user), ( Cond, write_list([' *Warning: '|Msg]), ttynl,ttynl, fail ; told, tell(FileName) ). new_if_warning(Msg,Cond):- if(call(Cond), (print_message(warning,Msg), fail), !) ; true. % ------------------------------------------------------------------------------ % write_list(Xs) % ------------------------------------------------------------------------------ % writes out elements of Xs with spaces between elements % ------------------------------------------------------------------------------ write_list([]). write_list([X|Xs]):- write(X), write(' '), write_list(Xs). write_list([],_). write_list([X|Xs],Stream) :- write(Stream,X), write(Stream,' '), write_list(Xs,Stream). % ------------------------------------------------------------------------------ % query_user(Query) % ------------------------------------------------------------------------------ % writes Query and then tries to read a y. from user % ------------------------------------------------------------------------------ query_user(QueryList):- ttynl, ttynl, write_list(QueryList), read(y). % ------------------------------------------------------------------------------ % duplicated(X,Xs) % ------------------------------------------------------------------------------ % holds if X occurs more than once in Xsd % ------------------------------------------------------------------------------ duplicated(X,[X|Xs]):- member(X,Xs). duplicated(X,[_|Xs]):- duplicated(X,Xs). % ------------------------------------------------------------------------------ % feat_cycle(S:type, Fs:path) % ------------------------------------------------------------------------------ % holds if following the path Fs in the appropriateness definitions % leads from S to S. calls an auxiliary function which avoids infinite % loops and tracks the features so far followed in reverse with an accumulator % ------------------------------------------------------------------------------ feat_cycle(S,Fs):- feat_cycle2(S,S,[S],[],Fs). % ------------------------------------------------------------------------------ % feat_cycle2(S1:type)>, % FsIn:path, FsOut:path) % ------------------------------------------------------------------------------ % assumes following reverse of FsIn led to S2 from S1, visiting % Ss along the way. FsOut is the result of appending a path that will % get from S2 back to S1 to the reverse of FsIn % ------------------------------------------------------------------------------ feat_cycle2(S1,S2,_Ss,FsIn,FsOut):- approp(F,S2,S1), reverse([F|FsIn],FsOut). feat_cycle2(S1,S2,Ss,FsIn,FsOut):- approp(F,S2,S3), \+ member(S3,Ss), feat_cycle2(S1,S3,[S2|Ss],[F|FsIn],FsOut). % ============================================================================== % Generator % [User's Manual] [Reference Manual] % ============================================================================== % ------------------------------------------------------------------------------ % split_dtrs(+Dtrs:dtrs, -Head:desc, % -SemGoalBefore:goal, -SemGoalAfter:goal, % -DtrsBefore:dtrs, -DtrsAfter:dtrs) % ------------------------------------------------------------------------------ % splits the RHS of a chain rule into Head, SemGoalBefore the Head, SemGoalAfter % the Head, DtrsBefore the Head, and DtrsAfter the Head % ------------------------------------------------------------------------------ split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,sem_goal> SemGoalAfter, DtrsAfter), Head,SemGoalBefore,SemGoalAfter,empty,DtrsAfter) :- !. split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,sem_goal> SemGoalAfter), Head,SemGoalBefore,SemGoalAfter, empty,empty) :- !. split_dtrs((sem_goal> SemGoalBefore,sem_head> Head,DtrsAfter), Head,SemGoalBefore,empty,empty,DtrsAfter) :- !. split_dtrs((sem_goal> SemGoalBefore,sem_head> Head), Head,SemGoalBefore,empty,empty,empty) :- !. split_dtrs((sem_head> Head,sem_goal> SemGoalAfter,DtrsAfter), Head,empty,SemGoalAfter,empty,DtrsAfter) :- !. split_dtrs((sem_head> Head,sem_goal> SemGoalAfter), Head,empty,SemGoalAfter,empty,empty) :- !. split_dtrs((sem_head> Head,DtrsAfter),Head,empty,empty,empty,DtrsAfter) :- !. split_dtrs((sem_head> Head),Head,empty,empty,empty,empty) :- !. split_dtrs((Dtr,RestDtrs),Head,SemGoalBefore,SemGoalAfter, (Dtr,DtrsBefore),DtrsAfter) :- !,split_dtrs(RestDtrs,Head,SemGoalBefore,SemGoalAfter,DtrsBefore,DtrsAfter). % ------------------------------------------------------------------------------ % Run-time generation support % [User's Manual] % ------------------------------------------------------------------------------ % ------------------------------------------------------------------------------ % gen(+Cat:desc) % gen(+Tag:tag, +SVs:svs, +Iqs:ineq) % ------------------------------------------------------------------------------ % top-level user calls to generate a sentence from a descriptor Cat % or a FS specified by Tag, SVs, Iqs % ------------------------------------------------------------------------------ gen(Cat) :- call_residue((add_to(Cat,Tag,bot), frozen_term(Tag,Frozen), ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(_,Cat,Tag,bot,Frozen)) -> true ; nl, write('INITIAL CATEGORY: '), nl, ttyflush, pp_fs_res(Tag,bot,Frozen), nl ), gen(Tag,bot,Words)),Residue), ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(Words,Cat,Tag,bot,Residue)) -> true ; nl, write('STRING: '), nl, write_list(Words), \+ \+ (nl, write('FINAL CATEGORY: '),nl, ttyflush, pp_fs_res(Tag,bot,Residue)), nl ), query_proceed. gen(Tag,SVs) :- % secret_noadderrs, frozen_term([Tag|SVs],Frozen), ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(_,bot,Tag,SVs,Frozen)) -> true ; nl, write('INITIAL CATEGORY: '), nl, ttyflush, pp_fs_res(Tag,SVs,Frozen), nl ), call_residue(gen(Tag,SVs,Words),Residue), ((current_predicate(portray_cat,portray_cat(_,_,_,_,_)), portray_cat(Words,bot,Tag,SVs,Residue)) -> true ; nl, write('STRING: '), nl, write_list(Words), \+ \+ (nl, write('FINAL CATEGORY: '),nl, ttyflush, pp_fs_res(Tag,SVs,Residue)), nl ), query_proceed. %, % secret_adderrs % ------------------------------------------------------------------------------ % gen/4 % gen(+Tag:tag, +SVs:svs, +IqsIn:ineqs, -Words:words) % [User's Manual] % ------------------------------------------------------------------------------ % top-level functional interface for the generator % generates the list of Words from the semantic specification of Tag-SVs,Iqs % ------------------------------------------------------------------------------ gen(Tag,SVs,Words) :- % fully_deref_prune(Tag,SVs,NewTag,NewSVs,IqsIn,IqsPrunned), generate(Tag,SVs,Words,[]), deref(Tag,SVs,TagOut,SVsOut), extensionalise(TagOut,SVsOut). % ------------------------------------------------------------------------------ % generate(+Tag:tag, +SVs:svs, +IqsIn:ineqs, -IqsOut:ineqs, % +Words:words, +RestWords:words) % ------------------------------------------------------------------------------ % recursively generates the difference list Words-RestWords from the root % Tag-SVs,IqsIn % ------------------------------------------------------------------------------ generate(Tag,SVs,Words,RestWords) if_h [GoalIndex,GoalPivot, non_chain_rule(PivotTag,bot,Tag,SVs,Words,RestWords)] :- semantics(Pred), cat_atoms('fs_',Pred,CompiledPred), functor(GoalIndex,CompiledPred,2), arg(1,GoalIndex,Tag-SVs), arg(2,GoalIndex,IndexTag-bot), functor(GoalPivot,CompiledPred,2), arg(1,GoalPivot,PivotTag-bot), arg(2,GoalPivot,IndexTag-bot). % ------------------------------------------------------------------------------ % generate_list(+Sort:sort, +Vs:vs, +IqsIn:ineqs, -IqsOut:ineqs, % -Words:words, +RestWords:words) % ------------------------------------------------------------------------------ % generates a list of words Words-RestWords from a variable list of descriptions % Sort(Vs) % ------------------------------------------------------------------------------ generate_list(e_list,_,Words,Words) :- !. generate_list(Sort,[HdFS,TlFS],Words,RestWords) :- sub_type(ne_list,Sort), !,deref(HdFS,DtrTag,DtrSVs), generate(DtrTag,DtrSVs,Words,MidWords), deref(TlFS,_,TlSVs), TlSVs =.. [TlSort|TlVs], generate_list(TlSort,TlVs,MidWords,RestWords). generate_list(Sort,_,_,_) :- error_msg((nl,write('error: cats> value with sort, '),write(Sort), write(' is not a valid argument (e_list or ne_list)'))). % ------------------------------------------------------------------------------ % Compiler % ------------------------------------------------------------------------------ :- dynamic current_chain_length/1. current_chain_length(4). % ------------------------------------------------------------------------------ % chain_length(N:int) % ------------------------------------------------------------------------------ % asserts chain_length/1 to N -- controls depth of chain rules application % ------------------------------------------------------------------------------ chain_length(N):- retractall(current_chain_length(_)), assert(current_chain_length(N)). % ------------------------------------------------------------------------------ % non_chain_rule(+PivotTag:tag, % +PivotSVs:svs, +RootTag:tag, +RootSVs:svs, % +IqsIn:ineqs, -IqsOut:ineqs, % -Words:words, -RestWords:words) % ------------------------------------------------------------------------------ % compiles nonheaded grammar rules, lexical entries and empty categories into % non_chain_rule predicates which unifies the mother against the % PivotTag-PivotSVs FS, generates top-down the RHS, and connects the mother FS % to the next chain rule % the result Words-RestWords is the final list of words which includes the list % NewWords-RestNewWords corresponding to the expansion of the current rule % ------------------------------------------------------------------------------ non_chain_rule(_,_,_,_,_,_) if_b [fail] :- (current_predicate(empty,empty(_)) -> \+ empty(_) ; true), (current_predicate('--->',(_ ---> _)) -> \+ (_ ---> _) ; true), (current_predicate(rule,(_ rule _)) -> \+ (_ rule _) ; true). non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs, Words,RestWords) if_b SubGoals :- current_predicate(empty,empty(_)), empty_assoc(VarsIn), empty_assoc(NVs), empty(Desc), compile_desc(Desc,PivotTag,PivotSVs,SubGoals, [current_chain_length(Max), \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs), chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs, Words,Words,Words,RestWords)],true,VarsIn,_, _FSPal,[],FSsOut,NVs), FSsOut = []. % build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsMid,non_chain_rule). non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs, Words,RestWords) if_b SubGoals :- (secret_noadderrs,fail % turn off adderrs for lexical compilation ; current_predicate('--->', (_ ---> _)), empty_assoc(VarsIn), empty_assoc(NVs), (WordStart ---> DescOrGoalStart), ( var(DescOrGoalStart) -> DescStart = DescOrGoalStart, GoalStart = true ; functor(DescOrGoalStart,goal,2) -> arg(1,DescOrGoalStart,DescStart), arg(2,DescOrGoalStart,GoalStart) ; DescStart = DescOrGoalStart, GoalStart = true ), curr_lex_rule_depth(LRMax), gen_lex_close(0,LRMax,WordStart,DescStart,GoalStart,WordOut,DescOut,GoalOut), % SubGoalsMid = [lex_goal(_-(a_ WordOut),PivotTag-PivotSVs)|SubGoalsMid2], compile_desc(DescOut,PivotTag,PivotSVs,SubGoals, [current_chain_length(Max), \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs), chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs, [WordOut|NewWords],NewWords,Words, RestWords) |SubGoalsMid],true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs), compile_body(GoalOut,SubGoalsMid,[],true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs), FSsOut = [] % build_fs_palette(FSsOut,FSPal,SubGoals,SubGoalsFinal,non_chain_rule) ; secret_adderrs,fail). % turn on again non_chain_rule(PivotTag,PivotSVs,RootTag,RootSVs, Words,RestWords) if_b PGoals :- current_predicate(rule, (_ rule _)), empty_assoc(VarsIn), empty_assoc(NVs), (_RuleName rule Mother ===> Dtrs), \+ split_dtrs(Dtrs,_,_,_,_,_), % i.e., not a chain rule compile_desc(Mother,PivotTag,PivotSVs, PGoals,[current_chain_length(Max), \+ \+ chained(0,Max,PivotTag,PivotSVs,RootTag,RootSVs) |PGoalsDtrs],true,VarsIn,VarsMid,FSPal,[],FSsMid,NVs), compile_gen_dtrs(Dtrs,HeadWords,RestHeadWords,PGoalsDtrs, [chain_rule(0,Max,PivotTag,PivotSVs,RootTag,RootSVs, HeadWords,RestHeadWords,Words, RestWords)],true,VarsMid,_,FSPal,FSsMid,FSsOut), FSsOut = []. % build_fs_palette(FSsOut,FSPal,PGoals,PGoalsMid,non_chain_rule). % ------------------------------------------------------------------------------ % chain_rule(+PivotTag:tag, +PivotSVs:svs, +RootTag:tag, +RootSVs:svs, % +IqsIn:ineqs, -IqsOut:ineqs, +HeadWords:words, % +RestHeadWords:words, -Words:words, RestWords:words) % ------------------------------------------------------------------------------ % compiles headed grammar rules into chain_rule predicates which unify the head % agains the PivotTag-PivotSVS FS, generates top-down the rest of the RHS, % and connects the mother FS to the next chain rule % the result is the list Words-RestWords which includes the sublist % HeadWords-RestHeadWords corresponding to the head % ------------------------------------------------------------------------------ chain_rule(_,_,PivotTag,PivotSVs,RootTag,RootSVs, % keep this clause Words,RestWords,Words,RestWords) if_b % first after multi-hashing [ud(PivotTag,PivotSVs,RootTag,RootSVs)]. chain_rule(N,Max,PivotTag,PivotSVs,RootTag,RootSVs, HeadWords,RestHeadWords,Words,RestWords) if_b [N < Max|PGoalsSG] :- current_predicate(rule,(_ rule _)), empty_assoc(VarsIn), empty_assoc(NVs), (_RuleName rule Mother ===> Dtrs), split_dtrs(Dtrs,Head,SGBefore,SGAfter,DtrsBefore,DtrsAfter), (SGBefore == empty -> PGoalsHead = PGoalsSG, VarsMid = VarsIn, FSsMid = [] ; compile_body(SGBefore,PGoalsSG,PGoalsHead,true, VarsIn,VarsMid,FSPal,[],FSsMid,NVs)), compile_desc(Head,PivotTag,PivotSVs,PGoalsHead,PGoalsMother,true,VarsMid, VarsMid2,FSPal,FSsMid,FSsMid2,NVs), (SGAfter == empty -> PGoalsSGAfter = PGoalsMother, VarsMid3=VarsMid2, FSsMid3 = FSsMid2 ; compile_body(SGAfter,PGoalsMother,PGoalsSGAfter, true,VarsMid2,VarsMid3,FSPal,FSsMid2,FSsMid3,NVs)), compile_desc(Mother,MotherTag,bot,PGoalsSGAfter, [SN is N + 1, \+ \+ chained(SN,Max,MotherTag,bot,RootTag,RootSVs) |PGoalsLeft],true,VarsMid3,VarsMid4,FSPal,FSsMid3,FSsMid4,NVs), compile_gen_dtrs(DtrsBefore,NewWords,HeadWords, PGoalsLeft,PGoalsRight,true,VarsMid4,VarsMid5,FSPal,FSsMid4, FSsMid5), compile_gen_dtrs(DtrsAfter,RestHeadWords,RestNewWords,PGoalsRight, [chain_rule(SN,Max,MotherTag,bot,RootTag,RootSVs, NewWords,RestNewWords,Words, RestWords)],true,VarsMid5,_,FSPal,FSsMid5,FSsOut), FSsOut = []. % build_fs_palette(FSsOut,FSPal,PGoalsSG,PGoalsSGBefore,chain_rule). % ------------------------------------------------------------------------------ % compile_gen_dtrs(+Dtrs:desc, +IqsIn:ineqs, -IqsOut:ineqs, % -Words:words, -RestWords:words, % -Goals:goals, -GoalsRest:goals, +VarsIn:avl, % -VarsOut:avl, +FSPal:var, +FSsIn:fss, -FSsOut:fss) % ------------------------------------------------------------------------------ % compiles the top-down expansion of a sequence Dtrs of RHS items % (daughters or goals) % ------------------------------------------------------------------------------ compile_gen_dtrs(empty,Words,Words,PGoals,PGoals,_,Vars,Vars,_,FSs, FSs) :- !. compile_gen_dtrs((cat> Dtr),Words,RestWords, PGoalsDtr,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, empty_assoc(NVs), compile_desc(Dtr,Tag,bot,PGoalsDtr, [generate(Tag,bot,Words,RestWords) |PGoalsRest],CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs). compile_gen_dtrs((cat> Dtr,RestDtrs),Words,RestWords, PGoalsDtr,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, empty_assoc(NVs), compile_desc(Dtr,Tag,bot,PGoalsDtr, [generate(Tag,bot,Words,WordsMid) |PGoalsDtrs],CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs), compile_gen_dtrs(RestDtrs,WordsMid,RestWords, PGoalsDtrs,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,FSsMid, FSsOut). compile_gen_dtrs((goal> Goal),Words,Words, PGoalsBody,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, empty_assoc(NVs), compile_body(Goal,PGoalsBody,PGoalsRest,CBSafe,VarsIn, VarsOut,FSPal,FSsIn,FSsOut,NVs). compile_gen_dtrs((goal> Goal,RestDtrs),Words,RestWords, PGoalsBody,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, empty_assoc(NVs), compile_body(Goal,PGoalsBody,PGoalsDtrs,CBSafe,VarsIn, VarsMid,FSPal,FSsIn,FSsMid,NVs), compile_gen_dtrs(RestDtrs,Words,RestWords, PGoalsDtrs,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,FSsMid, FSsOut). compile_gen_dtrs((cats> Dtrs),Words,RestWords, PGoalsDtrs,PGoalsRest,CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, empty_assoc(NVs), compile_desc(Dtrs,Tag,bot,PGoalsDtrs, [deref(Tag,bot,_,SVs), SVs =.. [Sort|Vs], generate_list(Sort,Vs,Words,RestWords) |PGoalsRest],CBSafe,VarsIn,VarsOut,FSPal,FSsIn,FSsOut,NVs). compile_gen_dtrs((cats> Dtrs,RestDtrs),Words,RestWords, PGoalsDtrs,PGoalsRest,VarsIn,VarsOut,FSPal,FSsIn,FSsOut) :- !, empty_assoc(NVs), compile_desc(Dtrs,Tag,bot,PGoalsDtrs, [deref(Tag,bot,_,SVs), SVs =.. [Sort|Vs], generate_list(Sort,Vs,Words,NewWords) |PGoalsRestDtrs],CBSafe,VarsIn,VarsMid,FSPal,FSsIn,FSsMid,NVs), compile_gen_dtrs(RestDtrs,NewWords,RestWords, PGoalsRestDtrs,PGoalsRest,CBSafe,VarsMid,VarsOut,FSPal,FSsMid, FSsOut). % ------------------------------------------------------------------------------ % chained(+PivotTag:tag, +PivotSVs:svs, +RootTag:tag, % +RootSVs:svs, +IqsIn:ineqs, -IqsOut:ineqs) % ------------------------------------------------------------------------------ % checks whether PivotTag-PivotSVs and RootTag-RootSVs can be connected through % a chain of grammar rules % ------------------------------------------------------------------------------ chained(_,_,PivotTag,PivotSVs,RootTag,RootSVs) if_b % keep this clause [ud(PivotTag,PivotSVs,RootTag,RootSVs)]. % first after multi-hashing chained(N,Max,PivotTag,PivotSVs,RootTag,RootSVs) if_b [N<Max|PGoals] :- current_predicate(rule,(_ rule _)), empty_assoc(VarsIn), empty_assoc(NVs), (_Rule rule Mother ===> Body), split_dtrs(Body,HeadIn,_,_,_,_), compile_desc(HeadIn,PivotTag,PivotSVs,PGoals,PGoalsPivot,true,VarsIn, VarsMid,FSPal,[],FSsMid,NVs), compile_desc(Mother,NewPTag,bot,PGoalsPivot, [SN is N + 1, chained(SN,Max,NewPTag,bot,RootTag,RootSVs)], true,VarsMid,_,FSPal,FSsMid,FSsOut,NVs), FSsOut = []. % build_fs_palette(FSsOut,FSPal,PGoals,PGoalsMid,chained). % ------------------------------------------------------------------------------ % gen_lex_close(+N:int, +Max:int, +WordIn:word, +MotherIn:desc, % -WordOutword, -MotherOut:desc, % +IqsIn:ineqs, -IqsOut:ineqs) % ------------------------------------------------------------------------------ % computes the closure of lexical entries under lexical rules to get additional % lexical grammar rules MotherOut ===> DtrsOut % ------------------------------------------------------------------------------ gen_lex_close(_,_,Word,Desc,Goal,Word,Desc,Goal). gen_lex_close(N,Max,WordStart,DescStart,GoalStart,WordEnd,DescEnd,GoalEnd) :- current_predicate(lex_rule,(_ lex_rule _)), N < Max, add_to(DescStart,TagIn,bot), ( (_RuleName lex_rule DescOrGoalIn **> DescOrGoalOut morphs Morphs), Cond = true ; (_RuleName lex_rule DescOrGoalIn **> DescOrGoalOut if Cond morphs Morphs) ), ( var(DescOrGoalIn) -> DescIn = DescOrGoalIn ; functor(DescOrGoalIn,goal,2) -> arg(1,DescOrGoalIn,DescIn), arg(2,DescOrGoalIn,GoalStart) ; DescIn = DescOrGoalIn ), ( var(DescOrGoalOut) -> DescOut = DescOrGoalOut, GoalOut = true ; functor(DescOrGoalOut,goal,2) -> arg(1,DescOrGoalOut,DescOut), arg(2,DescOrGoalOut,GoalOut) ; DescOut = DescOrGoalOut, GoalOut = true ), deref(TagIn,bot,DTagIn,DSVs), add_to(DescIn,DTagIn,DSVs), query_goal(Cond), % call(Goal), --- query_goal/1 now calls its Goal morph(Morphs,WordStart,WordOut), SN is N + 1, gen_lex_close(SN,Max,WordOut,DescOut,GoalOut,WordEnd,DescEnd,GoalEnd). % ------------------------------------------------------------------------------ % 5/15/96 - Octav -- changed to display the new version and add the banner to % the version/0 message :- nl,write(' ALE Version 3.3 alpha; December, 2001 Copyright (C) 1992-1995, Bob Carpenter and Gerald Penn Copyright (C) 1998,1999,2001,2002,2003 Gerald Penn All rights reserved'),nl, nointerp, nosubtest, parse, hide_residue, assert(lexicon_consult). %to_file(File) :- % bagof(e(I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName), % edge(I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName), % Es), % tell(File), % to_file_act(Es), % nl,told. %to_file_act([]). %to_file_act([e(I,Left,Right,Tag,SVs,Iqs,Dtrs,RuleName)|Es]) :- % write('edge('),write(I),comma,write(Left),comma,write(Right),comma, % write(Tag),comma,write(SVs),comma,write(Iqs),comma,write(Dtrs),comma, % write(RuleName),write(').'), % nl,to_file_act(Es). %comma :- write(','). %same(A, B) :- % edge(A, C, D, E, F, G, _,_), % edge(B, C, D, E, F, G, _,_). %subfind(I,J,LReln,RReln) :- % edge(I,Left,Right,Tag,SVs,Iqs,_,_), % edge(J,Left,Right,STag,SSVs,SIqs,_,_), % subsume([s(Tag,SVs,STag,SSVs)],Iqs,SIqs,<,>,LReln,RReln,[],[]), % comparable(LReln,RReln). %comparable(LReln,RReln) :- % (LReln \== #,! ; RReln \== #). % [269,266,263,260,220,214,177,171] subsume(Desc1,Desc2,LReln,RReln) :- call_residue((add_to(Desc1,Tag1,bot), fully_deref(Tag1,bot,DTag1,DSVs1)),Residue1), call_residue((add_to(Desc2,Tag2,bot), fully_deref(Tag2,bot,DTag2,DSVs2)),Residue2), empty_assoc(H), empty_assoc(K), build_iqs(Residue1,Iqs1,_), build_iqs(Residue2,Iqs2,_), subsume(s(DTag1,DSVs1,DTag2,DSVs2,sdone),<,>,LReln,RReln,H,K,Iqs1,Iqs2).