code.delx.au - gnu-emacs/blob - test/etags/prol-src/natded.prolog

   1 % $Id: natded.pl,v 1.7 2001/04/26 12:22:56 geertk Exp geertk $
   2 % NATURAL DEDUCTION CG PARSER WITH SEMANTICS
   3 % =========================================================================
   4 % Bob CARPENTER
   5 % Computational Linguistics Program, Department of Philosophy
   6 % Carnegie Mellon University, Pittsburgh, PA  15213
   7 % Net: carp+@cmu.edu
   8 % Voice: (412) 268-8043      Fax: (412) 268-1440
   9
  10 % Copyright 1995, Bob Carpenter
  11
  12 % Written: 12 March 1993
  13 % Revised: 4 February 1994
  14 % Further Revised: 2 May 1994
  15 % Revised for CGI: 16 November 1995
  16 % Revised for Lambek notation: ? Novemeber 1995
  17 % Revised again: 30 November 1995
  18
  19
  20 % Library Includes
  21 % =========================================================================
  22
  23 :- use_module(library(system)).
  24 % :- use_module(library(random)).
  25
  26
  27 % Data Types
  28 % =========================================================================
  29
  30 % <lambda_term> ::=  <lambda_var>
  31 %                 |  <lambda_con>
  32 %                 |  <lambda_term>@<lambda_term>
  33 %                 |  <lambda_var>^<lambda_term>
  34
  35 % <lambda_var> ::= var(<prolog_var>)
  36
  37 % <lambda_con> ::= con(<prolog_atom>)
  38
  39 % <tree> ::= tree(<rule>,<cat>,<list(<tree>)>)
  40 %          | ass(<syn>,<var>,<index>)
  41 %          | leaf(<word>)
  42
  43 % <rule> ::= <prolog_atom>
  44
  45 % <cat> ::= <syn> : <lambda_term>
  46
  47 % <syn> ::= <basic_syn>
  48 %         | <syn> / <syn>  |  <syn> \ <syn>
  49 %         | scop(<syn>,<syn>)
  50 %         | <syn> - <syn>
  51
  52 % <basic_syn> ::= bas(<prolog_term>)
  53
  54 % <grammar> ::= <sequence(<lex_entry>)>
  55 %               <sequence(<empty_category>)>
  56 %               <sequence(<grammar_rule>)>
  57
  58 % <lex_entry> ::=  <word> ==> <cat>.
  59
  60 % <empty_category> ::= empty <cat>.
  61
  62 % <grammar_rule> ::= <cat> ===> <list(<cat>)> if <prolog_goal>.
  63
  64 % <index> ::= <integer>
  65
  66 % <word> ::= <prolog_atom>
  67
  68 % <chart_edge> ::= edge(<int>, <int>, <cat>)
  69
  70 % Operator Declarations
  71 % =========================================================================
  72
  73   :-op(150,yfx,@).      % function application
  74 % :-op(200,xfy,^).      % lambda abstraction
  75 % :-op(400,yfx,/).      % forward slash
  76   :-op(350,yfx,\).      % backward slash
  77   :-op(500,xfx,:).      % category constructor
  78   :-op(600,xfx,==>).    % lexical rewriting
  79   :-op(600,xfx,===>).   % grammar rule
  80   :-op(600,fx,empty).   % empty categories
  81   :- op(600,xfx,macro). % lexical macros
  82   :- op(600,xfx,means). % meaning postulates
  83   :-op(1200,xfx,if).    % conditions on rule schemes
  84
  85 :- dynamic edge/3.
  86 :- dynamic emptyedge/1.
  87 :- dynamic active/3.
  88
  89
  90
  91
  92 % Lambda Calculus
  93 % =========================================================================
  94
  95 % expandmng(+M:<term>, -MExp:<term>)
  96 % ----------------------------------------------------------------------
  97 % MExp is the result of recursively replacing constants with their
  98 % definitions in M; disallows non-determinism
  99 % ----------------------------------------------------------------------
 100 expandmng(var(V),var(V)).
 101 expandmng(con(C),MExp):-
 102   con(C) means M, !,
 103   expandmng(M,MExp).
 104 expandmng(con(C),con(C)).
 105 expandmng(V^M,V^MExp):-
 106   expandmng(M,MExp).
 107 expandmng(M@N,MExp@NExp):-
 108   expandmng(M,MExp),
 109   expandmng(N,NExp).
 110
 111
 112 % normalize(+M:<term>, -MNorm:<term>)
 113 % ----------------------------------------------------------------------
 114 % MNorm is the normal form of M; all bound variables renamed
 115 % ----------------------------------------------------------------------
 116 normalize(M,MNorm):-
 117   fresh_vars(M,MFr),
 118   normalize_fresh(MFr,MNorm).
 119
 120 % fresh_vars(+M:<term>, -MFr:<term>)
 121 % ----------------------------------------------------------------------
 122 % MFr is the result of renaming all bound variables
 123 % in M to fresh instances, using alpha-reduction
 124 % ----------------------------------------------------------------------
 125 fresh_vars(var(V),var(V)).
 126 fresh_vars(con(C),con(C)).
 127 fresh_vars(M@N,MFr@NFr):-
 128   fresh_vars(M,MFr),
 129   fresh_vars(N,NFr).
 130 fresh_vars(X^M,var(Y)^MFr):-
 131   subst(M,X,var(Y),M2),
 132   fresh_vars(M2,MFr).
 133
 134 % substitute(+M:<term>, +X:<var>, +N:<term>, -L:<term>)
 135 % ----------------------------------------------------------------------
 136 % L = M[X |--> N]
 137 % ----------------------------------------------------------------------
 138 subst(var(Y),var(X),M,N):-
 139   ( X == Y
 140     -> N=M
 141   ; N = var(Y)
 142   ).
 143 subst(con(C),_,_,con(C)).
 144 subst(M@L,X,N,M2@L2):-
 145   subst(M,X,N,M2),
 146   subst(L,X,N,L2).
 147 subst(Y^M,X,N,Y^M2):-
 148   ( Y == X
 149     -> M2 = M
 150   ; subst(M,X,N,M2)
 151   ).
 152
 153 % normalize_fresh(+M:<term>, -N:<term>)
 154 % ----------------------------------------------------------------------
 155 % M is normalized to N
 156 % -- all bound variables are made fresh
 157 % -- cut corresponds to leftmost normalization
 158 % ----------------------------------------------------------------------
 159 normalize_fresh(M,N):-
 160   reduce_subterm(M,L),
 161   !, normalize_fresh(L,N).
 162 normalize_fresh(M,M).
 163
 164 % reduce_subterm(+M:<term>, -N:<term>)
 165 % ----------------------------------------------------------------------
 166 % N is the result of performing one beta- or
 167 % eta-reduction on some subterm of M;
 168 % -- reduces leftmost subterm first, but provides
 169 %    all reductions on backtracking
 170 % ----------------------------------------------------------------------
 171 reduce_subterm(M,M2):-
 172   reduce(M,M2).
 173 reduce_subterm(M@N,M2@N):-
 174   reduce_subterm(M,M2).
 175 reduce_subterm(M@N,M@N2):-
 176   reduce_subterm(N,N2).
 177 reduce_subterm(X^M,X^N):-
 178   reduce_subterm(M,N).
 179
 180 % reduce(+M:<term>, -N:<term>)
 181 % ----------------------------------------------------------------------
 182 % reduces M to N using beta- or eta-reduction
 183 % -- assumes no variable clashes
 184 % ----------------------------------------------------------------------
 185 reduce((X^M)@N,L):-     % beta reduction
 186   subst(M,X,N,L).
 187 reduce(X^(M@Y),M):-     % eta reduction
 188   X == Y,
 189   \+ ( free_var(M,Z),
 190        Z == X ).
 191
 192 % free_var(+M:<term>, -X:<var>)
 193 % ----------------------------------------------------------------------
 194 % X is free in M
 195 % ----------------------------------------------------------------------
 196 free_var(var(V),var(V)).
 197 free_var(M@N,X):-
 198   ( free_var(M,X)
 199   ; free_var(N,X)
 200   ).
 201 free_var(X^M,Y):-
 202   free_var(M,Y),
 203   Y \== X.
 204
 205 % free_for(+N:<term>, +X:<var>, +M:<term>)
 206 % ----------------------------------------------------------------------
 207 % M is free for X in N
 208 % ----------------------------------------------------------------------
 209 free_for(var(_),_,_).
 210 free_for(con(_),_,_).
 211 free_for(L@K,X,M):-
 212   free_for(L,X,M),
 213   free_for(K,X,M).
 214 free_for(Y^L,X,M):-
 215   free_for(L,X,M),
 216   ( \+ free_var(L,X)
 217   ; \+ free_var(M,Y)
 218   ).
 219
 220
 221 % Right-Left, Bottom-Up Dynamic Chart Parser (after ALE)
 222 % =========================================================================
 223
 224 % Lexical Compiler
 225 % ----------------------------------------------------------------------
 226
 227 % compile_lex(+File:<file>)
 228 % ----------------------------------------------------------------------
 229 % compiles lexical entries into file
 230 % ----------------------------------------------------------------------
 231 compile_lex(File):-
 232   tell(File),
 233   write('% Lexical Entries'), nl,
 234   write('% ---------------'), nl, nl,
 235   lex(W,Syn,Sem),
 236   numbervars(lexentry(W,Syn,Sem),0,_),
 237   write('lexentry(\''), write(W), write('\','),
 238   write(Syn),write(','), write(Sem), write(').'), nl,
 239   fail.
 240 compile_lex(File):-
 241   told,
 242   compile(File).
 243
 244 % consult_lex
 245 % ----------------------------------------------------------------------
 246 % consults lexicon in place
 247 % ----------------------------------------------------------------------
 248 consult_lex:-
 249   retractall(lexentry(_,_,_)),
 250   lex(W,Syn,Sem),
 251   assert(lexentry(W,Syn,Sem)),
 252   fail.
 253 consult_lex.
 254
 255 % lex(?W:<word>, ?Syn:<syn>, ?Sem:<lambda_term>)
 256 % ----------------------------------------------------------------------
 257 % word W has syntactic category Syn and smenantic term Sem
 258 % ----------------------------------------------------------------------
 259 lex(W,SynOut,Sem):-
 260   W ==> Syn : Sem,
 261   expandsyn(Syn,SynOut).
 262
 263 % expandsyn(+SynIn:<syn>, ?SynOut:<syn>)
 264 % ----------------------------------------------------------------------
 265 % the category SynIn is macro expanded recursively to SynOut
 266 % ----------------------------------------------------------------------
 267 expandsyn(Syn,Syn):-
 268   var(Syn), !.
 269 expandsyn(SynIn,SynOut):-
 270   macro(SynIn,SynMid),   % cut means unique macro expansion
 271   !, expandsyn(SynMid,SynOut).
 272 expandsyn(Syn1/Syn2,Syn1Out/Syn2Out):-
 273   !, expandsyn(Syn1,Syn1Out),
 274   expandsyn(Syn2,Syn2Out).
 275 expandsyn(Syn1\Syn2,Syn1Out\Syn2Out):-
 276   !, expandsyn(Syn1,Syn1Out),
 277   expandsyn(Syn2,Syn2Out).
 278 expandsyn(Syn1-Syn2,Syn1Out-Syn2Out):-
 279   !, expandsyn(Syn1,Syn1Out),
 280   expandsyn(Syn2,Syn2Out).
 281 expandsyn(q(Syn1,Syn2,Syn3),q(Syn1Out,Syn2Out,Syn3Out)):-
 282   !, expandsyn(Syn1,Syn1Out),
 283   expandsyn(Syn2,Syn2Out),
 284   expandsyn(Syn3,Syn3Out).
 285 expandsyn(Syn,Syn):-
 286   bas_syn(Syn).
 287
 288 % bas_syn(?Syn:<syn>)
 289 % ----------------------------------------------------------------------
 290 % Syn is a basic syntactic category
 291 % ----------------------------------------------------------------------
 292 bas_syn(n(_)).
 293 bas_syn(np(_,_)).
 294 bas_syn(s(_)).
 295 bas_syn(coor).
 296 bas_syn(sc(_)).
 297 bas_syn(ex(_)).
 298
 299
 300
 301
 302 % Empty Edge Compilation
 303 % ----------------------------------------------------------------------
 304
 305 % compile_empty
 306 % ----------------------------------------------------------------------
 307 % compiles empty categories, asserting all active and inactive edges
 308 % they can produce by themselves; always succeeds
 309 % ----------------------------------------------------------------------
 310 compile_empty:-
 311   retractall(emptyedge(_)), retractall(active(_,_,_)),
 312   empty SynIn:Sem,
 313   expandsyn(SynIn,Syn),
 314   complete(cat(Syn,Sem,[],[],empty(Syn,Sem))).
 315 compile_empty:-
 316   bagof(C,emptyedge(C),Cs),
 317   length(Cs,N),
 318   nl, write(N), write(' complete empty edges'), nl,
 319   bagof(D-Ds,G^active(Ds,D,G),Es),
 320   length(Es,M),
 321   write(M), write(' active rules with empty starts'), nl.
 322
 323 % complete_cat(Cat:+<cat>)
 324 % ----------------------------------------------------------------------
 325 % Cat is asserted as empty, and all current active edges are tested to
 326 % see if Cat can extend them; fails for looping
 327 % ----------------------------------------------------------------------
 328 complete(Cat):-
 329   assert(emptyedge(Cat)),
 330   ( (CatM ===> [Cat|Cats] if Goal)
 331   ; active(CatM,[Cat|Cats],Goal)
 332   ),
 333   add_active(Cats,CatM,Goal).
 334
 335 % add_active(Cats:+<list(<cat>)>, +Cat:<cat>, +Goal:<goal>)
 336 % ----------------------------------------------------------------------
 337 % the active edge Cat --> . Cats is asserted, and any extensions
 338 % computed and themselves asserted;  fails for looping
 339 % ----------------------------------------------------------------------
 340 add_active([],Cat,Goal):-
 341   call(Goal),
 342   assert(emptyedge(Cat)),
 343   complete(Cat).
 344 add_active([Cat|Cats],CatM,Goal):-
 345   assert(active([Cat|Cats],CatM,Goal)),
 346   emptyedge(Cat),
 347   add_active(Cats,CatM,Goal).
 348
 349 % parse(Ws:+<list(<word>)>, Cat:?<cat>)
 350 % ----------------------------------------------------------------------
 351 % Cat can be derived from Ws
 352 % ----------------------------------------------------------------------
 353 parse(Ws,Cat):-
 354   derived_analyses(Ws,WsMid),
 355   retractall(edge(_,_,_)),
 356   reverse(WsMid,[],WsRev),
 357   build(WsRev,0,Length),
 358   edge(Length,0,Cat).
 359
 360 % derived_analyses(WsIn:+<list(<word>)>, WsOut:-<list(<word>)>)
 361 % ----------------------------------------------------------------------
 362 % computes subderivations of WsIn
 363 % ----------------------------------------------------------------------
 364 derived_analyses([],[]).
 365 derived_analyses([der(Ws)|Ws2],[der(Ws,Ass,Syn,Sem)|DerWs2]):-
 366   !, parse(Ws,cat(Syn,Sem,Ass,[],_)),
 367   \+ member(abs(_,_,_),Ass),
 368   derived_analyses(Ws2,DerWs2).
 369 derived_analyses([W|Ws],[W|DerWs]):-
 370   derived_analyses(Ws,DerWs).
 371
 372 % build(Ws:+<list(<word>)>, Right:+<int>, Left:-<int>)
 373 % ----------------------------------------------------------------------
 374 % finishes building chart with Ws as remaing word, starting from
 375 % right position Right and finishing on left position Left
 376 %      -- counts backwards, so Left > Right
 377 % ----------------------------------------------------------------------
 378 build([],Left,Left).
 379 build([W|Ws],Right,FinalLeft):-
 380   RightPlus1 is Right+1,
 381   ( buildact(W,Right,RightPlus1)
 382   ; build(Ws,RightPlus1,FinalLeft)
 383   ).
 384
 385 % build_act(+W:<inputword>, +Left:<int>, +Right:<int>)
 386 % ----------------------------------------------------------------------
 387 % take action basedon whether input W is:
 388 %       [SynCat]     assume hypothetical category with syntax SynCat
 389 %       der(WsSub,Ass,Syn,Sem)  add derived result
 390 %       W            treat as input word
 391 % ----------------------------------------------------------------------
 392 buildact([SynIn],Right,RightPlus1):-
 393   mapsyn(SynIn,Syn),   % add unspecified features
 394   !,     add_edge(RightPlus1,Right,cat(Syn,var(X),[abs(Syn,var(X),N)],[],
 395                                   ass(Syn,var(X),N))).
 396 buildact(der(WsSub,Ass,Syn,Sem),Right,RightPlus1):-
 397   !,  add_edge(RightPlus1,Right,cat(Syn,Sem,Ass,[],
 398                                   tree(der,Syn:Sem,[ders(WsSub)]))).
 399 buildact(W,Right,RightPlus1):-
 400   lexentry(W,Syn,Sem),
 401   add_edge(RightPlus1,Right,cat(Syn,Sem,[l],[],tree(lex,Syn:Sem,[leaf(W)]))).
 402 buildact(W,_,_):-
 403     \+ (W ==> _),
 404     nl, write('Input not recognized: '), write(W), write('<br>').
 405
 406 % mapsyn(+SynCat:<syncat>, -SynCatOut:<syncat)
 407 % ----------------------------------------------------------------------
 408 % SynCatOut is result of adding default features to subcategories of
 409 % SynCat if any are missing;  allows [SynCat] to specify cats without
 410 % features for input;  ones with features will be passed along
 411 % ----------------------------------------------------------------------
 412 mapsyn(A/B,AM/BM):-
 413   mapsyn(A,AM), mapsyn(B,BM).
 414 mapsyn(A\B,AM\BM):-
 415   mapsyn(A,AM), mapsyn(B,BM).
 416 mapsyn(A-B,AM-BM):-
 417   mapsyn(A,AM), mapsyn(B,BM).
 418 mapsyn(scop(A,B),scop(AM,BM)):-
 419   mapsyn(A,AM), mapsyn(B,BM).
 420 mapsyn(q(A,B,C),q(AM,BM,CM)):-
 421   mapsyn(A,AM), mapsyn(B,BM), mapsyn(C,CM).
 422 mapsyn(s,s(_)).
 423 mapsyn(n,n(ind(sng))).
 424 mapsyn(np,np(ind(sng),nm(_))).
 425 mapsyn(np(X,Y),np(X,Y)).
 426 mapsyn(n(X),n(X)).
 427 mapsyn(s(X),s(X)).
 428
 429 % add_edge(Left:+<int>, Right:+<int>, Cat:+<cat>)
 430 % ----------------------------------------------------------------------
 431 % asserts edge into chart and then tries to extend it in all possible ways
 432 %     -- always fails to force backgracking
 433 % ----------------------------------------------------------------------
 434 add_edge(Left,Right,Cat):-
 435   asserta(edge(Left,Right,Cat)),
 436   ( (MotherCat ===> [Cat|Cats] if Goal)
 437   ; active([Cat|Cats],MotherCat,Goal)
 438   ),
 439   findcats(Cats,Right,NewRight),
 440   call(Goal),
 441   add_edge(Left,NewRight,MotherCat).
 442
 443 % findcats(Left:+<int>, Cats:+<cats>, Right:-<int>)
 444 % ----------------------------------------------------------------------
 445 % Cats is a list of categories spanning Left to Right
 446 % ----------------------------------------------------------------------
 447 findcats([],Left,Left).
 448 findcats([Cat|Cats],Left,Right):-
 449   ( edge(Left,Mid,Cat),
 450     findcats(Cats,Mid,Right)
 451   ; emptyedge(Cat),
 452     findcats(Cats,Left,Right)
 453   ).
 454
 455 % edge(Left:?<nat>, Right:?<nat>, Cat:?<cat>)                     (dynamic)
 456 % ----------------------------------------------------------------------
 457 % There is an edge with category Cat from Left to Right;
 458 % ----------------------------------------------------------------------
 459
 460 % normalize_tree(+TreeIn:<tree>, -TreeOut:<tree>)
 461 % ----------------------------------------------------------------------
 462 % TreeOut is isomorphic to TreeIn, with normalized semantics at
 463 % every node
 464 % ----------------------------------------------------------------------
 465 normalize_tree(tree(Rule,Syn:Sem,Trees),
 466                tree(Rule,Syn:SemNorm,TreesNorm)):-
 467   normalize_fresh(Sem,SemNorm),
 468   normalize_trees(Trees,TreesNorm).
 469 normalize_tree(ass(Syn,Var,Index),ass(Syn,Var,Index)).
 470 normalize_tree(leaf(Word),leaf(Word)).
 471 normalize_tree(ders(Word),ders(Word)).
 472 normalize_tree(empty(Syn,Sem),empty(Syn,SemNorm)):-
 473   normalize_fresh(Sem,SemNorm).
 474
 475 normalize_trees([],[]).
 476 normalize_trees([T|Ts],[TNorm|TsNorm]):-
 477   normalize_tree(T,TNorm),
 478   normalize_trees(Ts,TsNorm).
 479
 480
 481 % expandmng_tree(+TreeIn:<tree>, -TreeOut:<tree>)
 482 % ----------------------------------------------------------------------
 483 % TreeOut is isomorphic to TreeIn, with expanded semantics
 484 % every node
 485 % ----------------------------------------------------------------------
 486 expandmng_tree(tree(Rule,Syn:Sem,Trees),
 487                tree(Rule,Syn:SemNorm,TreesNorm)):-
 488   expandmng(Sem,SemNorm),
 489   expandmng_trees(Trees,TreesNorm).
 490 expandmng_tree(ass(Syn,Var,Index),ass(Syn,Var,Index)).
 491 expandmng_tree(leaf(Word),leaf(Word)).
 492 expandmng_tree(ders(Word),ders(Word)).
 493 expandmng_tree(empty(Syn,Sem),empty(Syn,SemNorm)):-
 494   expandmng(Sem,SemNorm).
 495
 496 expandmng_trees([],[]).
 497 expandmng_trees([T|Ts],[TExp|TsExp]):-
 498   expandmng_tree(T,TExp),
 499   expandmng_trees(Ts,TsExp).
 500
 501
 502 % Grammar Rules
 503 % =========================================================================
 504
 505 % C:<-cat> ===> Cs:<+list(<cat>)>
 506 % ----------------------------------------------------------------------
 507 % C can be composed of Cs; may be conditions
 508
 509 % / elimination
 510 % -------------
 511 cat(A, Alpha@Beta, Ass3, Qs3, tree(fe,A:Alpha@Beta,[T1,T2]))
 512 ===>
 513 [ cat(A/B, Alpha, Ass1, Qs1, T1),
 514   cat(B, Beta, Ass2, Qs2, T2)
 515 ] if
 516      append(Ass1,Ass2,Ass3),
 517      append(Qs1,Qs2,Qs3).
 518
 519 % \ elimination
 520 % -------------
 521 cat(A, Alpha@Beta, Ass3, Qs3, tree(be,A:Alpha@Beta,[T1,T2]))
 522 ===>
 523 [ cat(B, Beta, Ass1, Qs1, T1),
 524   cat(B\A, Alpha, Ass2, Qs2, T2)
 525 ] if
 526      append(Ass1,Ass2,Ass3),
 527      append(Qs1,Qs2,Qs3).
 528
 529 % \ introduction
 530 % --------------
 531 cat(B\A, X^Alpha, Ass, Qs, tree(bi(N),B\A:X^Alpha,[T1]))
 532 ===>
 533 [  cat(A, Alpha, [abs(B,X,N)|Ass], Qs, T1)
 534 ] if
 535     \+ T1 = tree(be,_,[_,ass(_,_,N)]),   % normal
 536     at_least_one_member(l,Ass),  % non-empty condition
 537      \+ ( subtree(tree(AssumeM,_,Ts),T1),      % properly nested
 538           member(TMid,Ts),
 539           subtree(ass(_,_,'$VAR'(J)),TMid),
 540           J == N,
 541           hypothetical_mem(AssumeM,Ass,Qs) ).
 542
 543 % / introduction
 544 % --------------
 545 cat(A/B, X^Alpha, Ass2, Qs, tree(fi(N),A/B:X^Alpha,[T1]))
 546 ===>
 547 [ cat(A,Alpha,Ass1,Qs,T1)
 548 ] if
 549      \+ T1 = tree(fe,_,[_,ass(_,_,N)]),    % normal
 550      at_least_one_member(l,Ass1), % non-empty condition
 551      select_last(Ass1,abs(B,X,N),Ass2),
 552      \+ ( subtree(tree(AssumeM,_,Ts),T1),   % properly nested
 553           member(TMid,Ts),
 554           subtree(ass(_,_,'$VAR'(J)),TMid),
 555           J == N,
 556           hypothetical_mem(AssumeM,Ass1,Qs) ).
 557
 558 % - introduction
 559 % --------------
 560 cat(A-B, X^Alpha, Ass2, Qs, tree(gi(N),(A-B):X^Alpha,[T1]))
 561 ===>
 562 [ cat(A, Alpha, Ass1, Qs, T1)
 563 ] if
 564      at_least_one_member(l,Ass1),  % non-empty condition
 565      select(abs(B,X,N),Ass1,Ass2),
 566      \+ ( subtree(tree(AssumeM,_,Ts),T1),  % normalized?
 567           member(TMid,Ts),
 568           subtree(ass(_,_,'$VAR'(J)),TMid),
 569           J == N,
 570           hypothetical_mem(AssumeM,Ass1,Qs) ).
 571
 572
 573 % q quantifier pushing (q-elimination part 1)
 574 % ----------------------------------------------------------------------
 575 cat(C, var(X), Ass, [gq(B,A,Q,var(X),N)|Qs],
 576           tree(qqpush(N),C:var(X),[T1]))
 577 ===>
 578 [ cat(q(C,B,A), Q, Ass, Qs, T1)
 579 ] if
 580   \+ T1 = tree(qqi,_,_).     % normal
 581
 582 % q quantifier popping (q-elimination part 2)
 583 % ----------------------------------------------------------------------
 584 cat(A, Q@(X^Alpha), Ass, Qs2, tree(qqpop(N),A:Q@(X^Alpha),[T1]))
 585 ===>
 586 [ cat(B,Alpha,Ass,Qs1,T1)
 587 ] if
 588      select(gq(B,A,Q,X,N),Qs1,Qs2),
 589      \+ ( subtree(tree(AssumeM,_,Ts),T1),
 590           member(TMid,Ts),
 591           subtree(tree(qqpush(J),_,_),TMid),
 592           J == N,
 593           hypothetical_mem(AssumeM,Ass,Qs1) ).
 594
 595 % q quantifier introduction [restricted to q(np,s,s)]
 596 % ----------------------------------------------------------------------
 597 % restricted to A = s(_), B=np case for termination
 598 cat(q(np(ind(Num),Case),s(VF),s(VF)), var(P)^(var(P)@Alpha), Ass, Qs1,
 599     tree(qqi,q(np(ind(Num),Case),s(VF),s(VF)):var(P)^var(P)@Alpha,[T1]))
 600 ===>
 601 [ cat(np(ind(Num),Case),Alpha,Ass,Qs1,T1)
 602 ] if
 603   true.
 604
 605 % coordination elimination
 606 % ----------------------------------------------------------------------
 607 cat(C, Sem, [], [], tree(coel,C:Sem,[T1,T2,T3]))
 608 ===>
 609 [ cat(C, Sem1, Ass1, [], T1),
 610   cat(coor, Alpha, Ass2, [],T2),
 611   cat(C, Sem2, Ass3, [], T3)
 612 ] if
 613      \+ member(abs(_,_,_),Ass1),        % coordination condition
 614      \+ member(abs(_,_,_),Ass2),
 615      \+ member(abs(_,_,_),Ass3),
 616      \+ T1 = tree(coel,_,_),
 617      \+ T2 = tree(coel,_,_),
 618      make_coor(C,Alpha,Sem1,Sem2,Sem).
 619
 620 % non-boolean coordination
 621 % ----------------------------------------------------------------------
 622 %cat(np(pl,-), con(union)@Alpha1P@Alpha3P, [], [],
 623 %    tree(nbc,np(pl,-):con(union)@Alpha1P@Alpha3P,[T1,T2,T3]))
 624 %===>
 625 %[ cat(NP1, Alpha1, Ass1, [], T1),
 626 %  cat(coor, nbc, Ass2, [],T2),
 627 %  cat(NP3, Alpha3, Ass3, [], T3)
 628 % ]:-
 629 %      \+ member(abs(_,_,_),Ass1),        % coordination condition
 630 %      \+ member(abs(_,_,_),Ass2),
 631 %      \+ member(abs(_,_,_),Ass3),
 632 %      make_nb_coor(NP1,Alpha1,Alpha1P),
 633 %      make_nb_coor(NP3,Alpha3,Alpha3P).
 634 %
 635 % make_nb_coor(np,Alpha,con(singleton)@Alpha).
 636 % make_nb_coor(np(pl,+),Alpha,con(singleton)@Alpha).
 637 % make_nb_coor(np(pl,-),Alpha,Alpha).
 638
 639
 640 % subtree(-TSub:<tree>, +T:<tree>)
 641 % ----------------------------------------------------------------------
 642 % TSub is a subtree of T
 643 % ----------------------------------------------------------------------
 644 subtree(T,T).
 645 subtree(T,tree(_,_,Ts)):-
 646   member(T2,Ts),
 647   subtree(T,T2).
 648
 649 % hypothetical_mem(Rule,Assumptions,Qs)
 650 % ----------------------------------------------------------------------
 651 % Rule is a member of the assumptions
 652 % ----------------------------------------------------------------------
 653 hypothetical_mem(fi(N),Ass,_):-
 654   member(abs(_,_,M),Ass), N == M.
 655 hypothetical_mem(bi(N),Ass,_):-
 656   member(abs(_,_,M),Ass), N == M.
 657 hypothetical_mem(gi(N),Ass,_):-
 658   member(abs(_,_,M),Ass), N == M.
 659 hypothetical_mem(qqpush(N),_,Qs):-
 660   member(gq(_,_,_,_,M),Qs), N == M.
 661
 662 % make_coor(Cat,CoorSem,Sem1,Sem2,SemOut)
 663 % ----------------------------------------------------------------------
 664 % generalized coordination semantics CoorSem is applied to
 665 % Sem1 and Sem2 of type Cat, with result SemOut
 666 % ----------------------------------------------------------------------
 667 make_coor(s(_),Alpha,Sem1,Sem2,Alpha@Sem1@Sem2).
 668 make_coor(n(_),Alpha,Sem1,Sem2,var(X)^Alpha@(Sem1@var(X))@(Sem2@var(X))).
 669 make_coor(A/_,Alpha,Sem1,Sem2,var(X)^Sem):-
 670   make_coor(A,Alpha,Sem1@var(X),Sem2@var(X),Sem).
 671 make_coor(_\A,Alpha,Sem1,Sem2,var(X)^Sem):-
 672   make_coor(A,Alpha,Sem1@var(X),Sem2@var(X),Sem).
 673 make_coor(A-_,Alpha,Sem1,Sem2,var(X)^Sem):-
 674   make_coor(A,Alpha,Sem1@var(X),Sem2@var(X),Sem).
 675 make_coor(q(_,_,A),Alpha,Sem1,Sem2,var(X)^Sem):-
 676   make_coor(A,Alpha,Sem1@var(X),Sem2@var(X),Sem).
 677
 678
 679 % General CGI Handling
 680 % =========================================================================
 681
 682 % start_up
 683 % ----------------------------------------------------------------------
 684 % executed when saved state is restarted;
 685 % tokenizes, parses and sends off input for handling;
 686 % halts on termination
 687 % ----------------------------------------------------------------------
 688 start_up:-
 689 %    getenv('QUERY_STRING', Arg),
 690     prolog_flag(argv,[Arg]),
 691
 692                             %           write('<p>'), write(Arg), nl, ttyflush,
 693   ( tokenizeatom(Arg,TokenList)
 694         %                               ,write('<p>'), write(TokenList), ttyflush
 695   ; write('Input '), write(Arg), write(' could not be tokenized'), ttyflush, halt
 696   ),
 697   ( parse_cgi(TokenList,KeyVals)
 698          %                              , write('<p>'), write(KeyVals), ttyflush
 699   ; write('Tokens '), write(TokenList), write(' could not be parsed'), halt
 700   ),
 701   ( action(KeyVals)
 702   ; told, write('Action '), write(KeyVals), write(' could not be executed')
 703   ),
 704   halt.
 705
 706 % tokenizeatom(+Input:<atom>, -Tokens:<list(<token>)>)
 707 % ----------------------------------------------------------------------
 708 % breaks input Input into list of tokens;
 709 % ----------------------------------------------------------------------
 710 tokenizeatom(Atom,Ws):-
 711   name(Atom,Cs),
 712   tokenize(Cs,Xs-Xs,Ws).
 713
 714 % tokenize(+Chars:<list(<char>)>, +CharsSoFar:<d_list(<char>)>,
 715 %          -Tokens:<list(<token>)>)
 716 % ----------------------------------------------------------------------
 717 % Tokens is the list of tokens retrieved from Chars; ChrsSoFar
 718 % accumulates prefixes of atoms being recognized
 719 % ----------------------------------------------------------------------
 720 tokenize([C1,C2,C3|Cs],Xs-Ys,TsResult):-     % special symbol
 721   name('%',[C1]),
 722   specialsymbol(C2,C3,SpecialSymbol),
 723   !,
 724   ( Xs = []
 725     -> TsResult = [SpecialSymbol|TsOut]
 726   ; Ys = [],
 727     name(CsAtom,Xs),
 728     TsResult = [CsAtom,SpecialSymbol|TsOut]
 729   ),
 730   tokenize(Cs,Zs-Zs,TsOut).
 731 tokenize([C|Cs],Xs-Ys,TsResult):-           % one-character operator
 732   isoperator(C),
 733   !, name(OpToken,[C]),
 734   ( Xs = []
 735     -> TsResult = [OpToken|Ts]
 736   ; Ys = [],
 737     name(CsAtom,Xs),
 738     TsResult = [CsAtom,OpToken|Ts]
 739   ),
 740   tokenize(Cs,Zs-Zs,Ts).
 741 tokenize([C|Cs],Xs-[C|Ys],Ts):-             % more of string
 742   tokenize(Cs,Xs-Ys,Ts).
 743 tokenize([],Xs-_,[]):-                      % no more input; nothing accum.
 744   Xs = [], !.
 745 tokenize([],Xs-[],[CsAtom]):-               % no more input; stringg accum.
 746   name(CsAtom,Xs).
 747
 748 % isoperator(+Char:<char>)
 749 % ----------------------------------------------------------------------
 750 % Char is the name of an operator character
 751 % ----------------------------------------------------------------------
 752 isoperator(Char):-
 753   name(Op,[Char]),
 754   isoptab(Op).
 755
 756 isoptab('%').
 757 isoptab('+').
 758 isoptab('&').
 759 isoptab('=').
 760
 761 % specialsymbol(+C1:<char>, +C2:<char>, -S:<token>)
 762 % ----------------------------------------------------------------------
 763 % C1 and C2 are the names of characters completing a % special symbol
 764 % ----------------------------------------------------------------------
 765 specialsymbol(C1,C2,S):-
 766   name(N1,[C1]), name(N2,[C2]),
 767   ( sstab(N1,N2,S), !
 768   ; S = spec(N1,N2)
 769   ).
 770
 771 sstab(2,'C',',').
 772 sstab(2,'F','/').
 773 sstab(2,8,'(').
 774 sstab(2,9,')').
 775 sstab(5,'B','[').
 776 sstab(5,'C','\\').
 777 sstab(5,'D',']').
 778 sstab(3,'D','=').
 779 sstab(3,'E','>').
 780
 781
 782 % parse_cgi(+TokenList:<list(<token>)>, -KeyVals:<list(<keyval>)>)
 783 % ----------------------------------------------------------------------
 784 % KeyVals is Key/Val list resulting from parsing TokenList using
 785 % the compiled DCG to perform a top-down parse
 786 % ----------------------------------------------------------------------
 787 parse_cgi(TokenList,KeyVals):-
 788     keyvalseq(KeyVals,TokenList,[]).
 789
 790 % Grammar for Parser
 791 % ----------------------------------------------------------------------
 792 keyvalseq([KeyVal|KeyVals]) -->
 793    keyval(KeyVal), andkeyvalseq(KeyVals).
 794 keyvalseq([]) --> [].
 795
 796 andkeyvalseq(KeyVals) --> ['&'], keyvalseq(KeyVals).
 797 andkeyvalseq([]) --> [].
 798
 799 keyval(key(Key,Val)) --> [Key,'='], valseq(Val).
 800
 801 % valseq(rec(Ws,Cat)) --> valseq(Ws), as(Cat).
 802
 803 % as('$ANY') --> [].
 804 % as(Cat) --> optplus, ['=','>'], optplus, val(Cat).
 805
 806 % valseq([]) --> [].   % subsumed by plusvalseq([]) --> []
 807 valseq([Val|Vals]) --> val(Val), plusvalseq(Vals).
 808 valseq(Vals) --> plusvalseq(Vals).
 809
 810 plusvalseq([]) --> [].
 811 plusvalseq(Vals) --> ['+'], valseq(Vals).
 812
 813 optplus --> [].
 814 optplus --> ['+'].
 815
 816 val(X) --> ['['], valseq(X), [']'].
 817 val(der(X)) --> [der,'('], valseq(X), [')'].
 818 val(X) --> atomval(X).
 819 val(X/Y) --> atomval(X), ['/'], atomval(Y).
 820 val(Y\X) --> atomval(Y), ['\\'], atomval(X).
 821 val(X-Y) --> atomval(Y), ['-'], atomval(X).
 822 val(Term) --> atom(Fun), ['('], argvals(Args), [')'],   {Term =.. [Fun|Args]}.
 823
 824 argvals([]) --> [].
 825 argvals([Arg|Args]) -->
 826   val(Arg), commaargvals(Args).
 827
 828 commaargvals(Args) -->
 829   [','], argvals(Args).
 830 commaargvals([]) -->
 831   [].
 832
 833 atomval(X) --> atom(X).
 834 atomval(X) --> ['('], val(X), [')'].
 835
 836 atom(X) --> [X], {atomic(X)}.
 837
 838
 839 % Specific CGI Query Handling
 840 % =========================================================================
 841
 842 % action(+KeyVals:<list(<keyval>)>)
 843 % ----------------------------------------------------------------------
 844 % take an action based on list of KeyVals
 845 % ----------------------------------------------------------------------
 846 action(KeyVals):-
 847     retractall(keyvalscgi(_)),
 848     assert(keyvalscgi(KeyVals)),
 849     member(key(inputfrom,[InputFrom]),KeyVals),
 850     ( InputFrom = 'Typing'
 851       -> member(key(parsestringone,Ws),KeyVals)
 852     ; InputFrom = 'Corpus'
 853       -> member(key(parsestringtwo,Ws),KeyVals)
 854     ),
 855 %                                 write('<p>'), write(Ws), nl,
 856     nl, write('P<font size=-1>ARSE</font> R<font size=-1>ESULTS FOR:</font> <cite>'),
 857     writelist(Ws),
 858     write('</cite><br><br>'), nl,
 859     member(key(outputform,[OutForm]),KeyVals),
 860     member(key(outputsyn,OutSynSym),KeyVals),
 861     outsyn(OutSynSym,OutSyn),
 862     act(OutForm,OutSyn,Ws).
 863
 864 keyvalcgi(Key,Val):-
 865 keyvalscgi(KeyVals),
 866   member(key(Key,Val),KeyVals).
 867
 868 outsyn(['Any'],_).
 869 outsyn(['Finite','S'],s(fin)).
 870 outsyn(['Noun','Phrase'],np(_,_)).
 871
 872 % act(+Form:<form>, ?Syn:<syn>, +Ws:<list(<word>)>)
 873 % ----------------------------------------------------------------------
 874 % the input Ws is parsed and output in form Form;
 875 % ----------------------------------------------------------------------
 876 act(OutForm,OutSyn,Ws):-
 877     findall(Tree, ( parse(Ws,cat(OutSyn,_,Ass,[],Tree)),
 878                    \+ member(abs(_,_,_),Ass) ),     Trees),  % all parses
 879     ( Trees = [],
 880       !, write('<BR> No Parses Found')                       % none found
 881     ; ( keyvalcgi(expandmng,['Yes']),
 882         !, expandmng_trees(Trees,Trees2)
 883       ; Trees2 = Trees
 884       ),
 885       ( keyvalcgi(normalize,['Yes']),
 886         !, normalize_trees(Trees2,Trees3)
 887       ; Trees3 = Trees2
 888       ),
 889         write('parse('),
 890         write_term(Ws,[quoted(true)]),
 891         write(',Cat).<br>'), nl,
 892       actout(OutForm,Trees3)
 893    ).
 894
 895
 896
 897 % actout(+Form:<form>, +Ts:<list(<tree>)>)
 898 % ----------------------------------------------------------------------
 899 % return output for list of trees Ts in form Form
 900 % ----------------------------------------------------------------------
 901 actout('Text',Trees):-
 902   write('<PRE>'), nl,
 903   texttreelist(Trees),
 904   nl, write('</PRE>').
 905 actout('Prawitz',Ts):-
 906   htmltreelist(Ts).
 907 actout('Fitch',Ts):-
 908   fitchtreelist(Ts).
 909
 910
 911
 912 texttreelist([]).
 913 texttreelist([T|Ts]):-
 914   pp_tree(T),
 915   nl, write('<BR>'), nl,
 916   texttreelist(Ts).
 917
 918 htmltreelist([]).
 919 htmltreelist([T|Ts]):-
 920   pp_html_table_tree(T),
 921   nl, write('<BR>'), nl,
 922   htmltreelist(Ts).
 923
 924 fitchtreelist([]).
 925 fitchtreelist([T|Ts]):-
 926   pp_html_table_fitch_tree(T),
 927   nl, write('<BR>'), nl,
 928   fitchtreelist(Ts).
 929
 930
 931 % PRETTY PRINTING ROUTINES
 932 % ======================================================================
 933
 934 % pp_html_table_tree(+Tree:<tree>)
 935 % ----------------------------------------------------------------------
 936 % Tree is output as an HTML table;  first numbered
 937 % ----------------------------------------------------------------------
 938 pp_html_table_tree(T):-
 939   numbervars(T),
 940 %   nl,
 941 %   write_term(T,[quoted(true)]),
 942 %   nl, write('<P>'),
 943   pp_html_tree(T).
 944
 945 % pp_html_tree(+Tree:<tree>)
 946 % ----------------------------------------------------------------------
 947 % Tree is output as an HTML table;  assume numbered
 948 % ----------------------------------------------------------------------
 949 pp_html_tree(ass(Syn,V,'$VAR'(N))):-
 950   write('['), pp_cat(Syn:V), write(']<sup>'), write(N), write('</sup>').
 951 pp_html_tree(leaf(Word)):-
 952   pp_word(Word).
 953 pp_html_tree(ders(Words)):-
 954   pp_word_list(Words).
 955 pp_html_tree(empty(Syn,Sem)):-
 956   nl, write('<TABLE BORDER=1>'), nl,
 957   write('<TR VALIGN=bottom>
 958          <TD ALIGN=CENTER>-</TD>
 959          <TD ROWSPAN=2 ALIGN=CENTER>Nil</TD>
 960          </TR>'),
 961   nl,
 962   write('<TR VALIGN=bottom>
 963          <TD ALIGN=CENTER>'),
 964   pp_cat(Syn:Sem),
 965   write('</TD></TR>'),
 966   nl,
 967   write('</TABLE>').
 968 pp_html_tree(tree(Rule,Root,SubTrees)):-
 969   nl, write('<TABLE BORDER=1>'), nl,
 970   write('<TR VALIGN=bottom>'), nl,
 971   pp_html_trees(SubTrees,0,N),
 972   nl,
 973   ( Rule = lex
 974     -> true
 975   ; write('<TD ROWSPAN=2 ALIGN=CENTER>'), pp_rule(Rule), write('</TD>')
 976   ),
 977   write('</TR>'),
 978   write('<TR VALIGN=bottom><TD ALIGN=CENTER COLSPAN='), write(N), write('>'),
 979   pp_cat(Root),
 980   write('</TD></TR>'),
 981   nl, write('</TABLE>').
 982
 983 % pp_html_trees(+Trees: <list(<tree>)>,+N:<int>,-M:<int>)
 984 % ----------------------------------------------------------------------
 985 % prints the trees in Trees, where (M-N) is the length of the list (N
 986 % acts as an accumulator, initialized to 0
 987 % ----------------------------------------------------------------------
 988 pp_html_trees([T|Ts],N,M):-
 989   write('<TD ALIGN=center>'), pp_html_tree(T),
 990   write('</TD>'),
 991   K is N+1,
 992   pp_html_trees(Ts,K,M).
 993 pp_html_trees([],N,N).
 994
 995 % pp_html_table_fitch_tree(+T:<tree>)
 996 % ----------------------------------------------------------------------
 997 % T is numbered and output as a table Fitch-style
 998 % ----------------------------------------------------------------------
 999 pp_html_table_fitch_tree(T):-
1000   numbervars(T),
1001   nl, write('<TABLE BORDER=1>'),
1002   pp_html_fitch_tree(T,1,_,_,_,[],_),
1003   nl, write('</TABLE>').
1004
1005 % pp_html_fitch_tree(+Tree:<tree>, +Start:<int>, -Next:<int>, -Me:<int>,
1006 %                    +Exp:<exp>,
1007 %                    +AssIn:<list(<assgn>)>, -AssOut:<list(<assgn>)>)
1008 % ----------------------------------------------------------------------
1009 % the rows of the table for Tree are printed;
1010 % Start is where the numbering begins; Next is the next available number
1011 % after last one used; Me is the row representing the output of the
1012 % derivation;  Exp is the expression corresponding to Tree;
1013 % AssIn are existing assignments coming in and AssOut are assignments
1014 % going out (an <assgn> is a pair ass(M,X) where M is a row number on the
1015 % table and X is the abstracted variable)
1016 % ----------------------------------------------------------------------
1017 pp_html_fitch_tree(tree(der,Root,[ders(Words)]),M,N,M,Exp,Ass,Ass):-
1018   !, nl, write('<TR><TD>'),
1019   write(M), write('</TD><TD>'),
1020   map_word(Words,Exp), pp_exp(Exp),
1021   write('-'), pp_cat(Root),
1022   write('</TD><TD>'), write('Der'), write('</TD></TR>'), nl,
1023   N is M+1.
1024 pp_html_fitch_tree(tree(lex,Root,[leaf(Word)]),M,N,M,Word,Ass,Ass):-
1025   !, nl, write('<TR><TD>'),
1026   write(M), write('</TD><TD>'), pp_exp(Word), write('-'), pp_cat(Root),
1027   write('</TD><TD>'), write('Lex'), write('</TD></TR>'), nl,
1028   N is M+1.
1029 pp_html_fitch_tree(tree(fe,Root,[T1,T2]),M,N,L,Exp1+Exp2,AssIn,AssOut):-
1030   !, pp_html_fitch_tree(T1,M,K,Source1,Exp1,AssIn,AssMid),
1031   pp_html_fitch_tree(T2,K,L,Source2,Exp2,AssMid,AssOut),
1032   nl, write('<TR><TD>'),
1033   write(L), write('</TD><TD>'), pp_exp(Exp1+Exp2), write('-'), pp_cat(Root),
1034   write('</TD><TD>'), write('E/ '), write((Source1,Source2)), write('</TD></TR>'), nl,
1035   N is L + 1.
1036 pp_html_fitch_tree(tree(be,Root,[T1,T2]),M,N,L,Exp1+Exp2,AssIn,AssOut):-
1037   !, pp_html_fitch_tree(T1,M,K,Source1,Exp1,AssIn,AssMid),
1038   pp_html_fitch_tree(T2,K,L,Source2,Exp2,AssMid,AssOut),
1039   nl, write('<TR><TD>'),
1040   write(L), write('</TD><TD>'), pp_exp(Exp1+Exp2), write('-'), pp_cat(Root),
1041   write('</TD><TD>'), write('E\\ '), write((Source1,Source2)), write('</TD></TR>'), nl,
1042   N is L + 1.
1043 pp_html_fitch_tree(tree(qqi,Root,[T]),M,Next,Me,Exp,AssIn,AssOut):-
1044   !, pp_html_fitch_tree(T,M,Me,Source,Exp,AssIn,AssOut),
1045   nl, write('<TR><TD>'),
1046   write(Me), write('</TD><TD>'), pp_exp(Exp), write('-'), pp_cat(Root),
1047   write('</TD><TD>'), write('q I '), write(Source), write('</TD></TR>'), nl,
1048   Next is Me+1.
1049 pp_html_fitch_tree(tree(coel,Root,[T1,T2,T3]),M,N,L,Exp1+Exp2+Exp3,AssIn,AssOut):-
1050   !, pp_html_fitch_tree(T1,M,K,Source1,Exp1,AssIn,AssMid),
1051   pp_html_fitch_tree(T2,K,L1,Source2,Exp2,AssMid,AssMid2),
1052   pp_html_fitch_tree(T3,L1,L,Source3,Exp3,AssMid2,AssOut),
1053   nl, write('<TR><TD>'),
1054   write(L), write('</TD><TD>'), pp_exp(Exp1+Exp2+Exp3), write('-'), pp_cat(Root),
1055   write('</TD><TD>'), write('E co '), write((Source1,Source2,Source3)), write('</TD></TR>'), nl,
1056   N is L + 1.
1057 pp_html_fitch_tree(tree(fi(_),(C1/C2):(var(X)^Sem),[T]),M,Q,N,ExpNew,AssIn,AssOut):-
1058     K is M+1,
1059     write('<TR><TD COLSPAN=3><TABLE BORDER=1>'),
1060     write('<TR><TD>'), write(M), write('</TD><TD>'),
1061     X = '$VAR'(Num),
1062   cat_atoms(Num,'</sub>',ExpMid),
1063   cat_atoms('e<sub>',ExpMid,ExpNum),
1064     pp_exp(ExpNum),  write(' - '),
1065     pp_cat(C2:var(X)), write('</TD><TD>'), write('Assume</TD></TR>'),
1066     pp_html_fitch_tree(T,K,N,L, Exp, [ass(M,X)|AssIn],AssOut),
1067     write('<TR><TD>'), write(N), write('</TD><TD>'),
1068     removeexp(ExpNum,Exp,ExpNew),
1069     pp_exp(ExpNew), write(' - '), pp_cat(C1/C2:var(X)^Sem), write('</TD><TD>'),
1070     write('/I '), write((M,L)), write('</TD></TR>'),
1071     write('</TD></TR></TABLE>'),
1072     Q is N+1.
1073 pp_html_fitch_tree(tree(bi(_),(C2\C1):(var(X)^Sem),[T]),M,Q,N,ExpNew,AssIn,AssOut):-
1074     K is M+1,
1075     write('<TR><TD COLSPAN=3><TABLE BORDER=1>'),
1076     write('<TR><TD>'), write(M), write('</TD><TD>'),
1077     X = '$VAR'(Num),
1078   cat_atoms(Num,'</sub>',ExpMid),
1079   cat_atoms('e<sub>',ExpMid,ExpNum),
1080     pp_exp(ExpNum),  write(' - '),
1081     pp_cat(C2:var(X)), write('</TD><TD>'), write('Assume</TD></TR>'),
1082     pp_html_fitch_tree(T,K,N,L, Exp, [ass(M,X)|AssIn],AssOut),
1083     write('<TR><TD>'), write(N), write('</TD><TD>'),
1084     removeexp(ExpNum,Exp,ExpNew),
1085     pp_exp(ExpNew), write(' - '), pp_cat(C2\C1:var(X)^Sem), write('</TD><TD>'),
1086     write('/I '), write((M,L)), write('</TD></TR>'),
1087     write('</TD></TR></TABLE>'),
1088     Q is N+1.
1089 pp_html_fitch_tree(tree(gi(_),(C1-C2):var(X)^Sem,[T]),M,Q,N,ExpNew,AssIn,AssOut):-
1090   K is M+1,
1091     write('<TR><TD COLSPAN=3><TABLE BORDER=1>'),
1092     write('<TR><TD>'), write(M), write('</TD><TD>'),
1093     X = '$VAR'(Num),
1094   cat_atoms(Num,'</sub>',ExpMid),
1095   cat_atoms('e<sub>',ExpMid,ExpNum),
1096     pp_exp(ExpNum),  write(' - '),
1097     pp_cat(C2:var(X)), write('</TD><TD>'), write('Assume</TD></TR>'),
1098     pp_html_fitch_tree(T,K,N,L,Exp, [ass(M,X)|AssIn],AssOut),
1099     write('<TR><TD>'), write(N), write('</TD><TD>'),
1100     splitexp(ExpNum,Exp,ExpNew),
1101     pp_exp(ExpNew), write(' - '),
1102     pp_cat((C1-C2):var(X)^Sem), write('</TD><TD>'),
1103     write('I- '), write((M,L)), write('</TD></TR>'),
1104     write('</TD></TR></TABLE>'),
1105     Q is N+1.
1106 % pp_html_fitch_tree(tree(qqpop(N),A:(Q@(X^Alpha)),[T1]),M,N,K,Exp,Ass,Ass):-
1107 %   !, replace_qtree(qqpush(N),T1,T1Mid,T1Extract),
1108 %   pp_html_fitch_tree(T1Extract,M,L,J,_,_,_),
1109 %   pp_html_fitch_tree(T1Mid,L,P,I,_,_,_),
1110 %   write('<TR><TD>'), write(P), write('</TD><TD>'),
1111 %   pp_exp(Exp), write(' - '),
1112 %   pp_cat(A:(Q@(X^Alpha))), write('</TD><TD>'),
1113 %   write(' ').
1114 pp_html_fitch_tree(empty(Syn,Sem),M,N,M,[],Ass,Ass):-
1115   !, nl, write('<TR><TD>'),
1116   write(M), write('</TD><TD>'), write('NIL'), write(' '), pp_cat(Syn:Sem),
1117   write('</TD><TD>'), write('Empty'), write('</TD></TR>'), nl,
1118   N is M+1.
1119 pp_html_fitch_tree(ass(_Syn,var(Var),_),N,N,M,Exp,Ass,Ass):-
1120   member(ass(M,Var),Ass),
1121   Var = '$VAR'(Num),
1122   cat_atoms(Num,'</sub>',ExpMid),
1123   cat_atoms('e<sub>',ExpMid,Exp).
1124
1125 % removexp(+ExpRem:<exp>,+Exp:<exp>,-ExpOut:<exp>)
1126 % ----------------------------------------------------------------------
1127 % he expression ExpRem is removed from Exp with result ExpOut
1128 % ----------------------------------------------------------------------
1129 removeexp(E,E,'NIL'):-!.
1130 removeexp(E,E+E2,E2):-!.
1131 removeexp(E,E2+E,E2):-!.
1132 removeexp(E,E2+E3,E2New+E3New):-
1133   !, removeexp(E,E2,E2New),
1134   removeexp(E,E3,E3New).
1135 removeexp(_,E2,E2).
1136
1137 % splitexp(+ExpRem:<exp>, +Exp:<exp>, -ExpOut:<exp>)
1138 % ----------------------------------------------------------------------
1139 % ExpRem is removed from Exp with ExpOut left over;  the extraction
1140 % site is represented as a split point
1141 % ----------------------------------------------------------------------
1142 splitexp(E,E,('NIL','NIL')):-!.
1143 splitexp(E,E+E2,('NIL',E2)):-!.
1144 splitexp(E,E2+E,(E2,'NIL')):-!.
1145 splitexp(E,E1+E2,(E3,E4+E2)):-
1146   splitexp(E,E1,(E3,E4)), !.
1147 splitexp(E,E1+E2,(E1+E3,E4)):-
1148   splitexp(E,E2,(E3,E4)).
1149
1150 % pp_exp(+Exp:<exp>)
1151 % ----------------------------------------------------------------------
1152 % the expression Exp is output;  concatenations are represented as
1153 % spaces and split points by (_,_) and empty by '0'
1154 % ----------------------------------------------------------------------
1155 pp_exp('NIL'):-
1156   !, write(0).
1157 pp_exp(A+'NIL'):-
1158   !, pp_exp(A).
1159 pp_exp(B+'NIL'):-
1160   !, pp_exp(B).
1161 pp_exp(A+B):-
1162   !, pp_exp(A), write(' '), pp_exp(B).
1163 pp_exp((A,B)):-
1164   !, write('('), pp_exp(A), write(', '), pp_exp(B), write(')').
1165 pp_exp(A):-
1166   pp_word(A).
1167
1168 map_word([[_]|Ws],Exp):-
1169   !, map_word(Ws,Exp).
1170 map_word([W|Ws],Exp):-
1171   map_word(Ws,W,Exp).
1172 map_word([],'NIL').
1173
1174 map_word(Ws,[_],W):-
1175  !, map_word(Ws,W).
1176 map_word([],W,W).
1177 map_word([W|Ws],W1,W1+Exp):-
1178   map_word(Ws,W,Exp).
1179
1180 pp_exps([]).
1181 pp_exps([Exp|Exps]):-
1182   pp_exp(Exp), write('+'), pp_exp(Exps).
1183
1184 % pp_tree(+T:<tree>)
1185 % ----------------------------------------------------------------------
1186 % tree T is output in indented list notation; first number
1187 % ----------------------------------------------------------------------
1188 pp_tree(T):-
1189   numbervars(T),
1190   pp_tree(T,0).
1191
1192 % pp_tree(+T:<tree>, +Col:<int>)
1193 % ----------------------------------------------------------------------
1194 % print tree T beginning at column Col
1195 % ----------------------------------------------------------------------
1196 pp_tree(empty(Syn,Sem),Col):-
1197   nl, tab(Col), pp_cat(Syn:Sem), write(' via empty').
1198 pp_tree(ass(Syn,V,'$VAR'(N)),Column):-
1199   nl, tab(Column), write('['), pp_cat(Syn:V), write(']'),
1200   write('<SUP>'), write(N), write('</SUP>').
1201 pp_tree(leaf(Word),Column):-
1202   nl, tab(Column), pp_word(Word).
1203 pp_tree(ders(Words),Column):-
1204   nl, tab(Column), pp_word_list(Words).
1205 pp_tree(tree(Rule,Root,SubTrees),Column):-
1206   nl, tab(Column),
1207   pp_cat(Root),
1208   write(' via '), pp_rule(Rule),
1209   NewColumn is Column + 2,
1210   pp_trees(SubTrees,NewColumn).
1211
1212 % pp_trees(+Ts:<list(<tree>)>, +Col:<int>)
1213 % ----------------------------------------------------------------------
1214 % print tree list Ts beginning at column Col
1215 % ----------------------------------------------------------------------
1216 pp_trees([T|Ts],Column):-
1217   pp_tree(T,Column),
1218   pp_trees(Ts,Column).
1219 pp_trees([],_).
1220
1221 % pp_word_list(+Ws:<list(<word>)>)
1222 % ----------------------------------------------------------------------
1223 % the list of words Ws is output, ignoring non-atoms
1224 % ----------------------------------------------------------------------
1225 pp_word_list([]).
1226 pp_word_list([W|Ws]):-
1227   atom(W), !, pp_word(W), pp_word_list_rest(Ws).
1228 pp_word_list([_|Ws]):-
1229   pp_word_list(Ws).
1230
1231 pp_word(W):-
1232   write('<I>'), write(W), write('</I>').
1233
1234 % pp_word_list_rest(+Ws:<list(<word>)>)
1235 % ----------------------------------------------------------------------
1236 % word list Ws is output with an initial blank if Ws is non-empty
1237 % ----------------------------------------------------------------------
1238 pp_word_list_rest([]).
1239 pp_word_list_rest([W|Ws]):-
1240   atom(W), !, write(' '), pp_word(W), pp_word_list_rest(Ws).
1241 pp_word_list_rest([_|Ws]):-
1242   pp_word_list_rest(Ws).
1243
1244 % pp_cat(Cat:<cat>)
1245 % ----------------------------------------------------------------------
1246 % pretty print category Cat
1247 % ----------------------------------------------------------------------
1248 pp_cat(Syn:Sem):-
1249   pp_lam(Sem), write(' : '), pp_syn(Syn).
1250
1251 % pp_syn(SynCat:<syncat>)
1252 % ----------------------------------------------------------------------
1253 % pretty print syntactic category
1254 % ----------------------------------------------------------------------
1255 pp_syn(A/B):-
1256   !, pp_syn(A), write('/'), pp_syn_paren(B).
1257 pp_syn(A-B):-
1258   !, pp_syn(A), write('-'), pp_syn_paren(B).
1259 pp_syn(B\A):-
1260   !, pp_syn_paren(B), write('\\'), pp_syn_back(A).
1261 pp_syn(q(A,B,B)):-
1262   !, pp_syn(scop(A,B)).
1263 pp_syn(q(A,B,C)):-
1264   !, write('q('), pp_syn(A), write(','), pp_syn(B), write(','),
1265   pp_syn(C), write(')').
1266 pp_syn(scop(A,B)):-
1267   !, pp_syn(A), write('^^'), pp_syn(B).
1268 pp_syn(C):-
1269   pp_bas_cat(C).
1270
1271 % pp_syn_paren(SynCat:<syncat>)
1272 % ----------------------------------------------------------------------
1273 % pretty print syntactic category with enclosing parens if it
1274 % is functional (used for arguments)
1275 % ----------------------------------------------------------------------
1276 pp_syn_paren(A/B):-
1277   !, pp_paren(A/B).
1278 pp_syn_paren(A-B):-
1279   !, pp_paren(A-B).
1280 pp_syn_paren(B\A):-
1281   !, pp_paren(B\A).
1282 pp_syn_paren(q(A,B,B)):-
1283   !, pp_paren(q(A,B,B)).
1284 pp_syn_paren(q(A,B,C)):-
1285   !, pp_syn(q(A,B,C)).
1286 pp_syn_paren(C):-
1287   pp_bas_cat(C).
1288
1289 % pp_paren(+C:<cat>)
1290 % ----------------------------------------------------------------------
1291 % category Cat is pretty printed with surrounding parens
1292 % ----------------------------------------------------------------------
1293 pp_paren(C):-
1294   write('('), pp_syn(C), write(')').
1295
1296 % pp_syn_back(+Cat:<cat>)
1297 % ----------------------------------------------------------------------
1298 % Cat is pretty printed as the result of a backward functor
1299 % ----------------------------------------------------------------------
1300 pp_syn_back(A/B):-
1301   !, pp_syn_paren(A/B).
1302 pp_syn_back(A-B):-
1303   !, pp_syn_paren(A-B).
1304 pp_syn_back(A):-
1305   pp_syn(A).
1306
1307 % pp_bas_cat(+BasCat:<bascat>)
1308 % ----------------------------------------------------------------------
1309 % the basic category BasCat is pretty printed
1310 % ----------------------------------------------------------------------
1311 pp_bas_cat(Cat):-
1312   writecat(Cat,Atom,Subs,Sups),
1313   write(Atom),
1314   writesubs(Subs),
1315   writesups(Sups).
1316
1317 % writecat(+BasCat:<bascat>,-Root:<atom>,-Subs:<list>,-Sups:<list>)
1318 % ----------------------------------------------------------------------
1319 % basic category BasCat is printed as Root with superscripts Sups
1320 % and subscripts Subs
1321 % ----------------------------------------------------------------------
1322 writecat(np(ind(sng),nm(_)),np,[],[]):-!.
1323 writecat(np(ind(sng),pp(C)),np,[C],[]):-!.
1324 writecat(np(ind(plu),nm(_)),np,[p],[]):-!.
1325 writecat(np(ind(plu),pp(C)),np,[p,C],[]):-!.
1326 writecat(np(ind(_),nm(_)),np,[],[]):-!.
1327 writecat(np(set,nm(_)),np,[p],['*']):-!.
1328 writecat(np(set,pp(C)),np,[p,C],['*']):-!.
1329 writecat(np(_,_),np,[],[]):-!.
1330 writecat(s(fin),s,[],[]):-!.
1331 writecat(s('$VAR'(_)),s,[],[]):-!.
1332 writecat(s(V),s,[V],[]):-!.
1333 writecat(n(ind(plu)),n,[p],[]):-!.
1334 writecat(n(set),n,[p],['*']):-!.
1335 writecat(n(ind(sng)),n,[],[]):-!.
1336 writecat(n(_),n,[],[]):-!.
1337 writecat(sc(th(fin)),sc,[th,fin],[]):-!.
1338 writecat(sc(th(bse)),sc,[th,bse],[]):-!.
1339 writecat(sc(wh),sc,[wh],[]):-!.
1340 writecat(sc(if),sc,[if],[]):-!.
1341 writecat(sc(_),sc,[],[]):-!.
1342 writecat(ex(it),ex,[it],[]):-!.
1343 writecat(ex(th(_)),ex,[th],[]):-!.
1344 writecat(ex(_),ex,[],[]):-!.
1345 writecat(C,C,[],[]).
1346
1347 % writesubs(+List:<list>)
1348 % ----------------------------------------------------------------------
1349 % List is output as a subscript
1350 % ----------------------------------------------------------------------
1351 writesubs([]).
1352 writesubs([X|Xs]):-
1353   write('<SUB>'),
1354   writelistsubs(Xs,X),
1355   write('</SUB>').
1356
1357 % writesups(+List:<list>)
1358 % ----------------------------------------------------------------------
1359 % List is output as a superscript
1360 % ----------------------------------------------------------------------
1361 writesups([]).
1362 writesups([X|Xs]):-
1363   write('<SUP>'),
1364   writelistsubs(Xs,X),
1365   write('</SUP>').
1366
1367 % writelistsubs(+Xs:<list>, +X:<term>)
1368 % ----------------------------------------------------------------------
1369 % Xs is written as a list with commas as separators
1370 % ----------------------------------------------------------------------
1371 writelistsubs([],X):-
1372  write(X).
1373 writelistsubs([X|Xs],Y):-
1374   write(Y), write(' ,'), writelistsubs(Xs,X).
1375
1376 % pp_lam(+Term:<lambdaterm>)
1377 % ----------------------------------------------------------------------
1378 % lambda term Term is pretty printed
1379 % ----------------------------------------------------------------------
1380 pp_lam(Var^Alpha):-
1381   !, pp_lam(Var), write('<B>. </B>'), pp_lam(Alpha).
1382 pp_lam(con(and)@Alpha@Beta):-
1383   !, pp_lam_paren(Alpha), write(' &amp '), pp_lam_paren(Beta).
1384 pp_lam(con(or)@Alpha@Beta):-
1385   !, pp_lam_paren(Alpha), write(' <b>or</b> '), pp_lam_paren(Beta).
1386 pp_lam(con(not)@Alpha):-
1387   !, write(' &#172 '), write('('), pp_lam_paren(Alpha), write(')').
1388 pp_lam(Alpha@Beta):-
1389   !, pp_lam_bracket(Alpha),
1390   write('('),
1391   pp_lam(Beta),
1392   write(')').
1393 pp_lam(var('$VAR'(N))):-
1394   !, write('<I>'), write(x), write('<SUB>'), write(N), write('</SUB></I>').
1395 pp_lam(con(Con)):-
1396   write('<B>'), write(Con), write('</B>').
1397
1398 pp_lam_bracket(A^B):-
1399   !, write('('), pp_lam(A^B), write(')').
1400 pp_lam_bracket(A):-
1401   pp_lam(A).
1402
1403 % pp_lam_paren(+Term:<lambdaterm>)
1404 % ----------------------------------------------------------------------
1405 % lambda term Term is pretty printed
1406 % ----------------------------------------------------------------------
1407 pp_lam_paren(Var^Alpha):-
1408   !, pp_lam(Var), write('<B>. </B>'), pp_lam(Alpha).
1409 pp_lam_paren(con(and)@Alpha@Beta):-
1410   !, write('('), pp_lam_paren(Alpha), write(' &amp '), pp_lam_paren(Beta), write(')').
1411 pp_lam_paren(con(or)@Alpha@Beta):-
1412   !, write('('), pp_lam_paren(Alpha), write(' <b>or</b> '), pp_lam_paren(Beta), write(')').
1413 pp_lam_paren(con(not)@Alpha):-
1414   !, write(' &#172 '), write('('), pp_lam_paren(Alpha), write(')').
1415 pp_lam_paren(Alpha@Beta):-
1416   !, pp_lam(Alpha),
1417   write('('),
1418   pp_lam(Beta),
1419   write(')').
1420 pp_lam_paren(var('$VAR'(N))):-
1421   !, write('<I>'), write(x), write('<SUB>'), write(N), write('</SUB></I>').
1422 pp_lam_paren(con(Con)):-
1423   write('<B>'), write(Con), write('</B>').
1424
1425 % pp_rule(+Rule:<rulename>)
1426 % ----------------------------------------------------------------------
1427 % rule Rule is pretty printed
1428 % ----------------------------------------------------------------------
1429 pp_rule(fe):-write('/E').
1430 pp_rule(be):-write('\\E').
1431 pp_rule(fi('$VAR'(N))):-write('/I<sup>'), write(N), write('</sup>').
1432 pp_rule(bi('$VAR'(N))):-write('\\I<sup>'), write(N), write('</sup>').
1433 pp_rule(gi('$VAR'(N))):-write('-I<sup>'), write(N), write('</sup>').
1434 pp_rule(qqpush('$VAR'(N))):-write('qE<sup>'), write(N), write('</sup>').
1435 pp_rule(qqpop('$VAR'(N))):-write(N).
1436 pp_rule(qqi):-write(qI).
1437 pp_rule(coel):-write('coE').
1438 pp_rule(lex):-write('L').
1439 pp_rule(der):-write('D').
1440 pp_rule(nbc):-write('NBC').
1441 pp_rule(qi):-write('qI').
1442
1443
1444 % Standard Utilities
1445 % ======================================================================
1446
1447 member(X,[X|_]).
1448 member(X,[_|Xs]):-
1449   member(X,Xs).
1450
1451 append_list([],[]).
1452 append_list([Xs|Xss],Ys):-
1453   append(Xs,Zs,Ys),
1454   append_list(Xss,Zs).
1455
1456 append([],Xs,Xs).
1457 append([X|Xs],Ys,[X|Zs]):-
1458   append(Xs,Ys,Zs).
1459
1460 at_least_one_member(X,[X|_]):-!.
1461 at_least_one_member(X,[_|Xs]):-
1462   at_least_one_member(X,Xs).
1463
1464 numbervars(X):-
1465   numbervars(X,0,_).
1466
1467 reverse([],Ws,Ws).
1468 reverse([W|Ws],WsAcc,WsRev):-
1469   reverse(Ws,[W|WsAcc],WsRev).
1470
1471 select(X,[X|Xs],Xs).
1472 select(X,[Y|Xs],[Y|Zs]):-
1473   select(X,Xs,Zs).
1474
1475 select_last([X],X,[]).
1476 select_last([X|Xs],Y,[X|Zs]):-
1477   select_last(Xs,Y,Zs).
1478
1479 cat_atoms(A1,A2,A3):-
1480   name(A1,L1),
1481   name(A2,L2),
1482   append(L1,L2,L3),
1483   name(A3,L3).
1484
1485 writelist([der(Ws)|Ws2]):-
1486   !, writelist(Ws), write(' '), writelist(Ws2).
1487 writelist([W|Ws]):-
1488   write(W), write(' '),
1489   writelist(Ws).
1490 writelist([]).
1491
1492 write_lex_cat(File):-
1493   tell(File),
1494   write('<HTML><HEAD><TITLE>Natural Deduction CG Parser</TITLE></HEAD><BODY><b> L<FONT SIZE = -1>EXICON</FONT> </b><br><br><FONT SIZE=-1>'), nl, nl,
1495   setof(lexe(W,Syn:Sem),lexentry(W,Syn,Sem),Ws),
1496   !,   writebreaklex(Ws),
1497   nl, write('</FONT></HEAD></HTML>'), nl,
1498   told.
1499
1500 writebreaklex([]).
1501 writebreaklex([W|Ws]):-
1502   writebreaklex(Ws,W).
1503
1504 writebreaklex([],lexe(W,Cat)):-
1505   write(W), write(' ==> '),
1506   pp_cat(Cat), nl.
1507 writebreaklex([W2|Ws],lexe(W,Cat)):-
1508   write(W), write(' ==> '),
1509   pp_cat(Cat),
1510   write(' <BR> '), nl,
1511   writebreaklex(Ws,W2).
1512
1513 write_lex(File):-
1514   tell(File),
1515   write('<HTML><HEAD><TITLE>Natural Deduction CG Parser</TITLE></HEAD><BODY><b> L<FONT SIZE = -1>EXICON</FONT> </b><br><FONT SIZE=-1><BR>'), nl,
1516   setof(W,C^(W==>C),Ws),
1517   !,   writebreak(Ws),
1518   nl, write('</FONT></HEAD></HTML>'), nl,
1519   told.
1520
1521 writebreak([]).
1522 writebreak([W|Ws]):-
1523   writebreak(Ws,W).
1524
1525 writebreak([],W):-
1526   write(W), nl.
1527 writebreak([W2|Ws],W):-
1528   write(W), write(' <BR> '), nl,
1529   writebreak(Ws,W2).
1530
1531 tt:-
1532   consult(natded), consult(lexicon), consult_lex, compile_empty.
1533
1534 mt:-
1535   consult(natded), consult(lexicon), consult_lex, compile_empty, save(test3), start_up.
1536
1537 cmt:-
1538   compile(natded), compile(lexicon), compile_lex('compilelex.pl'), compile_empty, save(test3), start_up.
1539
1540
1541 %%% Local Variables:
1542 %%% mode: prolog
1543 %%% prolog-indent-width: 2
1544 %%% tab-width: 2
1545 %%% End: