% -*- Mode: Prolog -*- % File GULP3.PL % Michael A. Covington % Artificial Intelligence Center % The University of Georgia % Athens, Georgia 30602-7415 % July 28, 1994 % GULP -- Graph Unification and Logic Programming % Version 4 % CONDITIONS OF DISTRIBUTION: % Copyright (C) 1994 Michael A. Covington. % GULP is distributed with no warranty. % For documentation see "GULP 3.1: An Extension of Prolog % for Unification-Based Grammar," available as a research % report from the above address. % HOW TO RUN GULP: % The simplest way is to simply consult gulp4.pl into Prolog. % However, you can also build executable versions of Prolog % (including the compiler) in which GULP is built-in. :- use_module(library(lists),[append/3,remove_duplicates/2,memberchk/2]). /************************************************** * Remove eventually existing gulp term_expansion * **************************************************/ :- retract((user:term_expansion(T,R):-portable_expand_term(T,_),g_tf(_,R))) ; true. /********************** * Version identifier * **********************/ g_version('GULP 4 for SICStus Prolog, 15-MAY-2001\n(Adaption by Simon Clematide)'). :- g_version(X), version(X). /************************* * Operator declarations * *************************/ :- op(600,xfy,'::'). % feature-value separator :- op(602,xfy,'..'). % feature-value structure unificator /****************************************************************** * Translation of feature structures to value lists or vice versa * ******************************************************************/ :- dynamic g_features_aux/1. g_translate(X,X) :- var(X), !. /* Rare case, but not covered by other clauses */ g_translate(Structure,List) :- var(List), !, nonvar(Structure), g_tf(Structure,List). g_translate(Structure,List) :- nonvar(List), g_tb(Structure,List). /************************************************************* * Translation backward -- value lists to feature structures * *************************************************************/ /* * g_tb(FeatureStructure,ValueList) "Translate Backward" * * Translates backward using g_backward_schema. */ /* Variables and atomic terms do not need any conversion. */ g_tb(Value,Value) :- var(Value),!. g_tb(Value,Value) :- atomic(Value),!. g_tb(FS,Term) :- \+ functor(Term,g__,_), !, Term =.. [Functor | Args], g_tb_list(NewArgs,Args), FS =.. [Functor | NewArgs]. /* Term is a structure, but not a value list. Recursively convert all its arguments, which may be, or contain, value lists. */ g_tb(FS,Term) :- % functor(Term,g__,_), % implicit unvar(Term,Term2),% write_canonical(Term2), g_backward_schema(RawFS,Term2),%write_canonical((RawFS,Term2)), g_tb_fixup(RawFS,FS). /* * g_tb_fixup(RawFeatureStructure,FeatureStructure) * * Reverses the order of the feature:value pairs. * Recursively backtranslates the values. * Also discards pairs with uninstantiated value. */ g_tb_fixup(F::V,Result) :- /* Singleton case */ g_tb_fixup_rest(F::V,_,Result). g_tb_fixup(F::V..Rest,Result) :- g_tb(BTV,V), g_tb_add(F::BTV,_,FV), g_tb_fixup_rest(Rest,FV,Result). /* Start the recursion */ g_tb_fixup_rest(F::V..Rest,ResultSoFar,Result) :- g_tb(BTV,V), g_tb_add(F::BTV,ResultSoFar,FVR), g_tb_fixup_rest(Rest,FVR,Result). /* Continue the recursion */ g_tb_fixup_rest(F::V,ResultSoFar,FVR) :- g_tb(BTV,V), g_tb_add(F::BTV,ResultSoFar,FVR). /* End the recursion */ g_tb_add(_::V,R,R) :- var(V), !. /* Unmentioned variable */ g_tb_add(F::g_(V),R,F::V) :- var(R). /* First contributionto empty R */ g_tb_add(F::g_(V),R,F::V..R) :- nonvar(R). /* Ordinary case */ /* * g_tb_list(FeatureStructureList,ValueListList) * * Applies g_tb to ValueListList giving FeatureStructureList. */ g_tb_list([],[]). g_tb_list([FH|FT],[VH|VT]) :- g_tb(FH,VH), g_tb_list(FT,VT). /************************************************************ * Translation forward -- feature structures to value lists * ************************************************************/ /* * This is more complicated than translation backward because any * feature can occur anywhere in the feature structure. If several * features are specified, separate value lists are constructed * for them and then unified. Recursion is performed because the * the value of a feature structure may itself be a feature structure. */ /* * g_tf(FeatureStructure,ValueList) "Translate Forward" * * Recursively examines FeatureStructure and replaces all * feature structures with equivalent value lists. */ /* Simplest and most frequent case: Term is atomic. */ g_tf(Term,Term) :- atomic(Term),!. g_tf(Term,Term) :- var(Term),!. g_tf(Term,_) :- g_not_fs(Term), functor(Term,X,2), ( X = '..' ; X = '::'), !, g_error(['Invalid GULP punctuation: ' ,Term]). /* If Term is a structure with a colon as its functor, but is not a valid feature structure, then we have a syntax error. */ g_tf(Term,NewTerm) :- g_not_fs(Term), !, Term =.. [Functor|Args], g_tf_list(Args,NewArgs), NewTerm =.. [Functor|NewArgs]. /* Term is a structure, but not a feature structure. Recurse on all its arguments, which may be, or contain, feature structures. */ g_tf(Feature::Value,ValueList) :- !, g_tf(Value,NewValue), g_tfsf(Feature,g_(NewValue),ValueList). /* We have a Feature:Value pair. Recursively translate the value, which may itself be or contain a feature structure, and then convert Feature:NewValue into a value list in which only one value is specified. */ /* In Version >=2, this adds g_/1 in front of every value actually mentioned in the program. */ g_tf(FeatureStructure .. Rest,ValueList) :- !, g_tf(FeatureStructure,VL1), g_tf(Rest,VL2), g_unify(FeatureStructure..Rest,VL1,VL2,ValueList). /* A compound feature structure is handled by translating all the feature structures individually and then unifying the resulting value lists. */ /* * g_tf_list(ListOfTerms,ListOfResults) "Translate Forward List" * * Applies g_tf to a list of arguments giving a list of results. */ g_tf_list([],[]). g_tf_list([H|T],[NewH|NewT]) :- g_tf(H,NewH), g_tf_list(T,NewT). :- multifile g_forward_schema/3. :- dynamic g_forward_schema/3. g_tfsf(Keyword,Value,ValueList) :- g_forward_schema(Keyword,Value,ValueList), !. g_tfsf(Keyword,Value,ValueList) :- write(user_error,'GULP: Generating declaration for feature: '), write(user_error,Keyword), nl(user_error), ( retract(g_features_aux(List)) -> true ; List = [] ), append(List,[Keyword],NewList), remove_duplicates(NewList,Features), asserta(g_features_aux(Features)), g_add_another_feature(Keyword), !, g_tfsf(Keyword,Value,ValueList). /* Try again, and this time succeed! */ /******************************** * Output of feature structures * ********************************/ /* * g_display(X) * * Equivalent to display_feature_structure(X). * Retained for compatibility. * */ g_display(X) :- display_feature_structure(X). /* * display_feature_structure(X) * * Writes out a feature structure in a neat indented format. * Feature structure can be in either Feature:Value notation * or internal representation. */ display_feature_structure(Term) :- g_tb(FS,Term), /* Convert value lists into feature structures */ g_di(0,0,FS). /* Display them */ /* * g_di(CurPos,Indent,FS) "Display Indented" * * CurPos is the current position on the line; * Indent is the indentation at which this item should be printed. */ % This could be made more efficient by changing the order of % arguments so that indexing on the first argument would work. g_di(CurPos,Indent,Variable) :- var(Variable), !, tab(Indent - CurPos), write(Variable), nl. g_di(CurPos,Indent,F::V..Rest) :- !, g_di(CurPos,Indent,F::V), g_di(0,Indent,Rest). g_di(CurPos,Indent,F::V) :- !, tab(Indent - CurPos), write(F), write(' :: '), g_printlength(F,PL), NewIndent is Indent+PL+2, g_di(NewIndent,NewIndent,V). g_di(CurPos,Indent,OrdinaryTerm) :- !, tab(Indent - CurPos), write(OrdinaryTerm), nl. /************************************** * Maintenance of translation schemas * **************************************/ /* * g_make_backward_schema * * Makes a backtranslation schema containing all * possible features in both external and internal notation, * e.g., g_backward_schema(c::Z..b::Y..a::X,g__(..etc..)). */ :- multifile g_backward_schema/2. :- dynamic g_backward_schema/2. g_backward_schema('no_features declared',g__(_)). g_make_backward_schema :- retractall(g_backward_schema(_,_)), bagof((Feature::Value)/Schema, g_forward_schema(Feature,Value,Schema), [((F::V)/S)|Rest]), g_make_whole_aux(Rest,F::V,S). g_make_whole_aux([],FSSoFar,SchemaSoFar) :- assert(g_backward_schema(FSSoFar,SchemaSoFar)). g_make_whole_aux([((F::V)/S)|Rest],FSSoFar,SchemaSoFar) :- NewFS = (F::V .. FSSoFar), SchemaSoFar = S, /* unify SchemaSoFar with S */ g_make_whole_aux(Rest,NewFS,SchemaSoFar). /* * Defaults, in case the user never declares any features */ /* * g_make_forward_schemas(List) * * Given a list of feature names, makes and stores a * set of forward translation schemas for them. */ g_make_forward_schemas(List) :- length(List,L), L1 is L+1, g_make_forward_schemas_aux(List,2,L1). g_make_forward_schemas_aux([Feature|Rest],N,L) :- functor(Schema,g__,L), arg(N,Schema,Value), assertz(g_forward_schema(Feature,Value,Schema)), write(user_error,'GULP: Explicit declaration for feature:'), write(user_error,Feature),write(user_error,'...'), nl(user_error), N1 is N+1, g_make_forward_schemas_aux(Rest,N1,L). g_make_forward_schemas_aux([],_,_). /* * g_add_another_feature(Feature) * adds a feature by further instantiating the first element * of the schema, which is an open list (initially _); * creates a forward schema, and updates the backward schema. */ g_add_another_feature(Feature) :- g_backward_schema(_,Schema), arg(1,Schema,Hook), % further instantiate Hook, g_add_another_feature_aux(Hook,Value), assertz(g_forward_schema(Feature,Value,Schema)), %Test write('[asserting g_forward_schema('),write(Feature),write(']'),nl, g_make_backward_schema. g_add_another_feature_aux(Hook,Value) :- var(Hook), !, Hook = [Value|_]. g_add_another_feature_aux([_|Hook],Value) :- g_add_another_feature_aux(Hook,Value). /**************************** * Miscellaneous predicates * ****************************/ /* * g_fs(X) "Feature Structure" * * Succeeds if X is a feature structure. */ g_fs(X::_) :- atom(X). g_fs(X..Y) :- g_fs(X), g_fs(Y). /* * g_not_fs(X) "Not a Feature Structure" */ g_not_fs(X) :- g_fs(X), !, fail. g_not_fs(_). /* * g_vl(X) "Value List" * * Succeeds if X is a value list. */ g_vl(Term) :- functor(Term,g__,_). %% SC /* * g_unify(Text,X,Y,Z) * Unifies X and Y giving Z. * If this cannot be done, Text is used in an * error message. */ g_unify(_,X,X,X) :- !. g_unify(Text,X,Y,_) :- \+ (X = Y), g_error(['Inconsistency in ',Text]). /* * g_printlength(Term,N) * * N is the length of the printed representation of Term. */ g_printlength(Term,N) :- name(Term,List), !, length(List,N). g_printlength(_,0). /* if not easily computable, we probably don't need an accurate value anyhow */ /* * g_error(List) * Ensures that i/o is not redirected, * then displays a message and aborts program. */ g_error(List) :- repeat, seen, seeing(user), !, repeat, told, telling(user), !, writeln(['GULP ERROR: '|List]), abort. /************************************** * I/O utilities * **************************************/ /* * writeln(List) * writes the elements of List on a line, then * starts a new line. If the argument is not a list, * it is written on a line and then a new line is started. * Any feature structures found in List are converted * to Feature:Value notation. */ /*Q*/ :- public writeln/1. writeln(X) :- g_tb(TranslatedX,X), writeln_aux(TranslatedX). writeln_aux(X) :- var(X), !, write(X), nl. writeln_aux([]) :- !, nl. writeln_aux([H|T]) :- !, write(H), writeln(T). writeln_aux(X) :- write(X), nl. /********** * Herald * **********/ g_herald :- g_version(X), write(user_error,X),nl(user_error), write(user_error,'Copyright 1994 Michael A. Covington'),nl(user_error). :- g_herald. g_features(_) :- g_features_aux(_), !, g_error(['Explicit declaration must preceed any mentioning of features!']). g_features(List):- remove_duplicates(List,Set), g_declare_features(Set). g_declare_features(List):- assert(g_features_aux(List)), retractall(g_forward_schema(_,_,_)), g_make_forward_schemas(List), g_make_backward_schema. /*********************** * DCG rule translator * ***********************/ /* From... */ % File : DCG.PL % Author : Richard A. OKeefe % Updated: Tuesday July 26th, 1988. % Purpose: Definite Clause Grammar rule to Prolog clause translator. %%% Portions commented out by Michael Covington, 1994, %%% for compatibility with LPA 386-Prolog and Quintus Prolog. %%% Modified not to use 'C'. %%% No other alterations have been made. /* This file is written in the ISO 8859/1 character set. The "Copyright" line contains after the right parenthesis a character which when transmitted was character 169, the international copyright symbol. Copyright (C) 1988, Quintus Computer Systems, Inc. This file is distributed in the hope that it will be useful, but without any warrantee. You are expressly warned that it is meant to serve as a model, not for direct use: all error checking and reporting has been omitted, and mistakes are almost surely present. Permission is granted to anyone to distribute verbatim copies of this source code as received, in any medium, provided that the copyright notice, the nonwarrantee warning, and this permission notice are preserved. Permission is granted to distribute modified versions of this source code, or of portions of it, under the above conditions, plus the conditions that all changed files carry prominent notices stating who last changed them and that the derived material is subject to this same permission notice. Permission is granted to include this material in products for which money is charged, provided that the customer is given written notice that the code is (or is derived from) material provided by Quintus Computer Systems, Inc., and that the customer is given this source code on request. ---------------------------------------------------------------- Now that weve got that (adapted from the GNU copyright notice) out of the way, here are the technical comments. The predicates are all named dcg_/ in order to keep out of the way, with the exception of phrase/2 and phrase/3 which bear their proper names. Only phrase/[2,3] and dcg_rule/2 are meant to be called directly, and dcg_rule/2 is meant to be called from expand_term/2. You need to keep dcg_body/4 and its dependents around at run time so that variables as nonterminals in DCG rule bodies will work correctly. So that Quintus have _something_ left to sell, this code has been rewritten from scratch with no error checking or reporting code at all, and a couple of places accept general grammar rule bodies where they are really supposed to demand lists of terminals. However, any rule which is valid according to the Quintus Prolog manual will be translated correctly, except that this code makes no attempt to handle module: prefixes. (The change is trivial.) Note that dcg_rule/2 and phrase/[2,3] are steadfast. */ % dcg rule(+Grammar Rule, -Equivalent Clause) dcg_rule(-->(Head0,Body0), Clause) :- dcg_head(Head0, Head, PushBack, S0, S), dcg_body(Body0, Body1, S0, S), dcg_conj(Body1, PushBack, Body), Clause = :-(Head,Body). % dcg head(+Head0, -Head, -PushBack, -S0, -S) % recognises both % NonTerminal, [PushBackList] --> % and % NonTerminal --> % It returns the difference pair S0\S which the body is to parse. % To avoid error checking, it will accept an arbitrary body in place % of a pushback list, but it should demand a proper list. dcg_head((Head0,PushBack0), Head, PushBack, S0, S1) :- !, dcg_goal(Head0, Head, S0, S), dcg_body(PushBack0, PushBack, S, S1). dcg_head(Head0, Head, true, S0, S) :- dcg_goal(Head0, Head, S0, S). % dcg goal(+Goal0, -Goal, +S0, +S) % adds the arguments S0, S at the end of Goal0, giving Goal. % It should check that Goal0 is a callable term. dcg_goal(Goal0, Goal, S0, S) :- functor(Goal0, F, N), N1 is N+1, N2 is N+2, functor(Goal, F, N2), arg(N2, Goal, S), arg(N1, Goal, S0), dcg_args(N, Goal0, Goal). % dcg args(+N, +Goal0, +Goal) % copies the first N arguments of Goal0 to Goal. dcg_args(N, Goal0, Goal) :- ( N =:= 0 -> true ; arg(N, Goal0, Arg), arg(N, Goal, Arg), M is N-1, dcg_args(M, Goal0, Goal) ). % dcg_body(+Body0, -Body, +S0, +S) % translates Body0 to Body, adding arguments as needed to parse S0\S. % It should complain about bodies (such as 2) which are not callable % terms, and about lists of terminals which are not proper lists. % To avoid error checking, [a|foo] is accepted as [a],foo, but it % really should complain. ONLY the forms lists here should be treated; % other non-terminals which look like calls to built-ins could well be % commented on (no error reporting here) but should be expanded even % so. Thus X=Y as a nonterminal is to be rewritten as =(X,Y,S0,S), % perhaps with a warning. If you want the translation X=Y, use {X=Y}. dcg_body(Var, Body, S0, S) :- var(Var), !, Body = phrase(Var,S0,S). dcg_body((A0,B0), Body, S0, S) :- !, dcg_body(A0, A, S0, S1), dcg_body(B0, B, S1, S), dcg_conj(A, B, Body). dcg_body((A0->B0), (A->B), S0, S) :- !, dcg_body(A0, A, S0, S1), dcg_body(B0, B, S1, S). dcg_body((A0;B0), (A;B), S0, S) :- !, dcg_disj(A0, A, S0, S), dcg_disj(B0, B, S0, S). dcg_body({A}, A, S, S) :- !. dcg_body(!, !, S, S) :- !. dcg_body([], true, S, S) :- !. dcg_body([H0|T0], Body, S0, S) :- !, dcg_term(H0, H, S0, S1), dcg_body(T0, T, S1, S), dcg_conj(H, T, Body). dcg_body(NT0, NT, S0, S) :- dcg_goal(NT0, NT, S0, S). % dcg_term(+T0, -T, +S0, +S) % generates code (T) which succeeds when there is a terminal T0 % between S0 and S. This version uses the DEC-10 Prolog predicate % C/3 for compatibility with DEC-10 Prolog, C Prolog, Quintus Prolog. % This is the only place that knows how terminals are translated, so % you could supply instead the definition % dcg_term(T0, S0=[T0|S], S0, S). % and reap the same benefits. The one thing you must not do is % NO! dcg_term(T0, true, [T0|S], S). DONT DO THAT! %%% dcg_term(T0, 'C'(S0,T0,S), S0, S). dcg_term(T0, S0=[T0|S], S0, S). %% M. Covington 1994 % To see why dcg disj/4 is needed, consider the translation of % ( [] | [a] ). We have to insert S1=S0 somewhere, but we do it at % "compile"-time if we can. dcg_disj(Body0, Body, S0, S) :- dcg_body(Body0, Body1, S1, S), ( S1==S -> dcg_conj(S1=S0, Body1, Body) ; S1 = S0, Body = Body1 ). % dcg_conj(+A, +B, -C) % combines two conjunctions A, B, giving C. Basically, we want to % ensure that there arent any excess trues kicking around (in a % compiled system, that shouldnt matter). There is room for some % leeway here: I have chosen to flatten A completely. dcg_conj(A, true, A) :- !. dcg_conj(A, B, C) :- dcg_CONJ(A, B, C). dcg_CONJ(true, C, C) :- !. dcg_CONJ((A,As), C0, (A,C)) :- !, dcg_CONJ(As, C0, C). dcg_CONJ(A, C, (A,C)). %%% phrase/2, phrase/3, 'C'/3 are nowadays already built in. %%% - M. Covington 1994 % 'C'(S0, T, S) % is true when the terminal T "Connects" the "string positions" S0 and S. %%% 'C'([T|S], T, S). % phrase(+NT0, ?S0) % is true when the list S0 is in the language defined by the % grammar rule body NT0. E.g. phrase(([a],[b]), [a,b]). %%% phrase(NT0, S0) :- %%% phrase(NT0, S0, []). % phrase(+NT0, ?S0, ?S) % is true when the list S0\S is in the language defined by the % grammar rule body NT0. E.g. phrase(([a],[b]), [a,b|X], X). %%% phrase(NT0, S0, S) :- %%% dcg_body(NT0, NT, T0, T), %%% T0 = S0, T = S, %%% NT. portable_expand_term(-->(H,B),Clause):-!, ( dcg_rule(-->(H,B),Clause)->true ; write('dcg_expansion_error->'),write(H),nl,fail ). portable_expand_term(C,C). /******************************** * SICSTUS PROLOG HOOKS * ********************************/ % Display feature structures as such in interactive debugging: :- multifile user:portray/1. :- dynamic user:portray/1. %%%user:portray(X) :- %%% g_vl(X), %%% g_tb(Y,X), %%% print(Y). user:portray(X) :- g_vl(X), g_tb(Y, X), write(Y). % Translate feature structures to internal form automatically % during consult and reconsult: :- multifile user:term_expansion/2. :- dynamic user:term_expansion/2. %term_expansion(Term,_Lay1,Result,Lay2) :- % portable_expand_term(Term,X), % g_tf(X,Result), % g_tb(Result,Lay2). term_expansion(Term,Result) :- portable_expand_term(Term,X), g_tf(X,Result). % SICSTUS PROLOG: % Remove numbervared Variables in Pretty Printing, such % that feature structures in variable bindings are rendered % correctly % SC: Broken in newer SICStus Prolog Variants. unvar(X,X):-!. /*unvar(X,Y) :- unvar(X,[0|_],Y). unvar('$VAR'(Name), Env, Var) :- !, ( memberchk(Name-Var,Env) ; true ). unvar(Term, Env, NewTerm) :- Term =.. [F|Args], unvar_list(Args, Env, NewArgs), NewTerm =.. [F|NewArgs]. unvar_list([],_,[]). unvar_list([X|Tail],Env,[UnvarX|UnvarTail]) :- unvar(X,Env,UnvarX), unvar_list(Tail, Env, UnvarTail). */