1/* logic compilation of Definite Clause Translation Grammar rules */
    2
    3:- op(650,yfx,^^).    4:- op(601,xfy,:).    5:- op(1150,xfx,::=).    6:- op(1175,xfx,<:>).    7:- op(1150,xfx,::-).    8
    9
   10/*
   11   The form of a rule is:
   12
   13   LP ::= RP <:> Args ::- Sem
   14
   15*/
   16
   17translate_rule((LP::=[]<:>Sem),H) :- !, 
   18   t_lp(LP,[],S,S,Sem,H).
   19
   20translate_rule((LP::=[]),H) :- !, t_lp(LP,[],S,S,[],H).
   21
   22translate_rule((LP::=RP<:>Sem),(H:-B)):- !,
   23   t_rp(RP,[],StL,S,SR,B1),
   24   reverse(StL,RStL),
   25   t_lp(LP,RStL,S,SR,Sem,H),
   26   tidy(B1,B).
   27
   28translate_rule((LP::=RP),(H:-B)):-
   29   translate_rule((LP::=RP<:>[]),(H:-B)).
   30
   31t_lp((LP,List),StL,S,SR,Sem,H) :-
   32   append(List,SR,List2),
   33   prod_number(Number),
   34   assert_semantic_rule(Number,LP,StL,Sem),
   35   add_extra_args([node(LP,StL,Number),S,List2],LP,H).
   36
   37t_lp(LP,StL,S,SR,Sem,H) :- 
   38   prod_number(Number),
   39   assert_semantic_rule(Number,LP,StL,Sem),
   40   add_extra_args([node(LP,StL,Number),S,SR],LP,H).
   41
   42t_rp(!,St,St,S,S,!) :- !.
   43
   44t_rp([],St,[[]|St],S,S1,S=S1) :- !.
   45
   46t_rp([X],St,[[NX]|St],S,SR,c(S,X,SR)) :-
   47   char(X,NX).
   48
   49t_rp([X],St,[[X]|St],S,SR,c(S,X,SR)) :- !.
   50
   51t_rp([X|R],St,[[NX|NR]|St],S,SR,(c(S,X,SR1),RB)) :- 
   52   char(X,NX),
   53   t_rp(R,St,[NR|St],SR1,SR,RB).
   54
   55t_rp([X|R],St,[[X|R]|St],S,SR,(c(S,X,SR1),RB)) :- !, 
   56   t_rp(R,St,[R|St],SR1,SR,RB).
   57
   58t_rp({T},St,St,S,S,T) :- !.
   59
   60t_rp((T,R),St,StR,S,SR,(Tt,Rt)) :- !,
   61   t_rp(T,St,St1,S,SR1,Tt),
   62   t_rp(R,St1,StR,SR1,SR,Rt).
   63
   64t_rp(T^^N,St,[N|St],S,SR,Tt) :- add_extra_args([N,S,SR],T,Tt).
   65
   66t_rp(T,St,[St1|St],S,SR,Tt) :- add_extra_args([St1,S,SR],T,Tt).
   67
   68add_extra_args(L,T,T1) :-
   69   T=..Tl,
   70   append(Tl,L,Tl1),
   71   T1=..Tl1.
   72 
   73% append([],L,L) :- !.
   74% append([X|R],L,[X|R1]) :- append(R,L,R1).
   75
   76% reverse(X,RX) :- rev1(X,[],RX).
   77% 
   78% rev1([],R,R) :- !.
   79% 
   80% rev1([X|Y],Z,R) :- rev1(Y,[X|Z],R).
   81
   82tidy(((P1,P2),P3),Q) :- 
   83   tidy((P1,(P2,P3)),Q).
   84
   85tidy((P1,P2),(Q1,Q2)) :- !,
   86   tidy(P1,Q1),
   87   tidy(P2,Q2).
   88
   89tidy(A,A) :- !.
   90
   91char(X,NX) :-
   92   integer(X), X < 256, !, name(NX,[X]).
   93
   94c([X|S],X,S). /* defined as a system predicate */
   95
   96 
   97% :- asserta(( term_expansion(T,E) :- translate_rule(T,E) , ! )).
   98% :- asserta(( term_expansion(T,E) :- process_rule(T,E) , ! )).
   99
  100grammar(File) :-
  101   seeing(Old),
  102   see(File),
  103   consume,
  104   seen,
  105   see(Old).
  106
  107consume :-
  108   repeat,
  109      read(X),
  110      check_it(X).
  111
  112check_it(X) :- X = end_of_file, !. 
  113check_it(X) :- process(X), fail.
  114
  115process(Grammar) :- (Grammar = (H<:>T); Grammar = (H::=T)), !,
  116   translate_rule(Grammar,Clause),
  117   assertz(Clause), !.
  118
  119process(( :- G)) :- !,         % Execute a command
  120   G.
  121
  122process((P :- Q)) :-  !,       % Store a normal clause
  123   assertz((P :- Q)).
  124
  125process(P) :-                  % Store a unit clause
  126   assertz(P).
  127
  128/*
  129process_rule(T,E) :-
  130   translate_rule(T,E),
  131   !,
  132   assert(T).
  133*/
  134
  135node(NonTerminal,Trees,Index)^^Args :-
  136   semantic_rule(Index,Args,NonTerminal,Trees). % fast?
  137
  138/*
  139get_sem(NonTerminal,Trees,Index,Head) :-
  140   semantic_rule(Index,NonTerminal,Trees,Head).
  141*/
  142
  143prod_number(X) :-
  144   retract(rule_number(X)),
  145   X1 is X + 1,
  146   assert(rule_number(X1)).
  147
  148:- dynamic rule_number/1.  149
  150rule_number(0).
  151
  152assert_semantic_rule(Number,LP,StL,(Rule,Rules)) :- !, 
  153   (Rule = (Head ::- Body); Head = Rule, Body = true),
  154   assert((semantic_rule(Number,Head,LP,StL) :- !,Body)),
  155   assert_semantic_rule(Number,LP,StL,Rules).
  156
  157assert_semantic_rule(Number,LP,StL,Rule) :-
  158   (Rule = (Head ::- Body); Head = Rule, Body = true),
  159   assert((semantic_rule(Number,Head,LP,StL) :- !,Body))