-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathlisql2nl.ml
1671 lines (1585 loc) · 74.8 KB
/
lisql2nl.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
Copyright 2013 Sébastien Ferré, IRISA, Université de Rennes 1, [email protected]
This file is part of Sparklis.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
open Lisql
open Lisql_annot
open Js_of_ocaml
open Js
open Jsutils
exception TODO
(* configuration : language *)
let config_lang =
let key = "lang" in
let select_selector = "#lang-select" in
let default = "en" in
object (self)
inherit Config.select_input ~key ~select_selector ~default ()
method grammar : Grammar.grammar =
match self#value with
| "fr" -> Grammar.french
| "es" -> Grammar.spanish
| "nl" -> Grammar.dutch
| _ -> Grammar.english
end
let config_show_datatypes = new Config.boolean_input ~key:"show_datatypes" ~input_selector:"#input-show-datatypes" ~default:false ()
(* NL generation from focus *)
type word =
[ `Thing
| `Relation
| `Entity of Rdf.uri * string
| `Literal of string
| `TypedLiteral of string * string (* lexical value, datatype/lang *)
| `Blank of string
| `Class of Rdf.uri * string
| `Prop of Rdf.uri * string
| `Nary of Rdf.uri * string
| `Func of string
| `Op of string
| `Undefined
| `FocusName
| `FocusSpan of Lisql.increment (* increment in which is used this FocusSpan word *) ]
let word_text_content grammar : word -> string = function
| `Thing -> grammar#thing
| `Relation -> grammar#relation
| `Entity (uri,s) -> s
| `Literal s -> s
| `TypedLiteral (s, dt) -> if config_show_datatypes#value then s ^ " (" ^ dt ^ ")" else s
| `Blank id -> id
| `Class (uri,s) -> s
| `Prop (uri,s) -> s
| `Nary (uri,s) -> s
| `Func s -> s
| `Op s -> s
| `Undefined -> "?"
| `FocusSpan _ -> "__"
| `FocusName -> "thing"
type ng_label =
[ `Word of word
| `Expr of annot elt_expr
| `Ref of Lisql.id
| `Gen of ng_label * word
| `Of of word * ng_label
| `AggregNoun of word * ng_label
| `AggregAdjective of word * ng_label
| `Hierarchy of ng_label
| `Nth of int * ng_label ]
type s =
[ `Return of np
| `ThereIs of np
| `ThereIs_That of np * s
| `Truth of np * vp
| `PP of pp * s
| `Where of np (* when expr np acts as a sentence *)
| `For of np * s
| `Seq of s list
| `And of s list
| `Or of s list
| `Not of s
| `Maybe of s
| `Focus of annot * s ]
and np =
[ `Void
| `PN of word * rel
| `This
| `TheFactThat of s
| `Label of ng_label * word option
| `Qu of qu * adj * ng
| `QuOneOf of qu * word list
| `Expr of adj * Grammar.func_syntax * np list * rel
| `And of np list
| `Or of np list
| `Choice of adj * np list * rel
| `Maybe of np
| `Not of np
| `Focus of annot * np ]
and ng =
[ `That of word * rel
| `LabelThat of ng_label * rel
| `OfThat of word * np * rel
| `Aggreg of bool * ng_aggreg * ng (* the bool indicates suspension *)
| `Focus of annot * ng ]
and qu = [ `A | `Any of bool | `The | `Every | `Each | `All | `One | `No of bool ]
and adj =
[ `Nil
| `Order of word
| `Optional of bool * adj
| `Adj of adj * word ]
and ng_aggreg =
[ `AdjThat of word * rel
| `NounThatOf of word * rel ]
and rel =
[ `Nil
| `That of vp
| `ThatS of s
| `Whose of ng * vp
| `PrepWhich of word * s
| `AtWhichNoun of word * s
(* | `Of of np *)
| `PP of pp list
| `Ing of word * np * pp list
| `InWhich of s
| `And of rel list
| `Or of rel list
| `Maybe of rel
| `Not of rel
| `In of np * rel
| `Ellipsis
| `Focus of annot * rel ]
and vp =
[ `IsNP of np * pp list
| `IsPP of pp
| `IsTheNounCP of word * cp
| `IsAdjCP of word * cp
| `IsInWhich of s
| `HasProp of word * np * pp list
| `HasPropCP of word * cp
| `Has of np * pp list
| `HasCP of cp
| `VT of word * np * pp list
| `VT_CP of word * cp
| `Subject of np * vp (* np is the subject of vp *)
| `And of vp list
| `Or of vp list (* the optional int indicates that the disjunction is in the context of the i-th element *)
| `Maybe of vp (* the bool indicates whether negation is suspended *)
| `Not of vp (* the bool indicates whether negation is suspended *)
| `EpsilonHead of vp
| `In of np * vp
| `Ellipsis
| `Focus of annot * vp ]
and cp =
[ `Nil
| `Cons of pp * cp
| `And of cp list
| `Or of cp list
| `Not of cp
| `Maybe of cp
| `Focus of annot * cp ]
and pp =
[ `Bare of np
| `Prep of word * np
| `AtNoun of word * np
| `At of np
| `PrepBin of word * np * word * np ]
let top_adj : adj = `Nil
let top_rel : rel = `Nil
let top_np : np = `Qu (`A, `Nil, `That (`Thing, top_rel))
let top_expr : np = `PN (`Undefined, top_rel)
let top_s : s = `Return top_np
let focus_span (incr : Lisql.increment) : word = `FocusSpan incr
let focus_span_np (incr : Lisql.increment) : np = `PN (`FocusSpan incr, top_rel)
let focus_name : word = `FocusName
let focus_name_ng : ng = `That (`FocusName, top_rel)
let undefined_np : np = `PN (`Undefined, top_rel)
let np_of_word w : np = `PN (w, top_rel)
let np_of_literal l : np = np_of_word (`Literal l)
let nl_and = function
| [] -> assert false
| [x] -> x
| l -> `And l
let nl_is : np -> vp = fun np -> `IsNP (np, [])
let nl_something : rel -> np = fun rel -> `Qu (`A, `Nil, `That (`Thing, rel))
let nl_that : vp -> rel = fun vp -> `That vp
let nl_there_is : np -> s = fun np -> `ThereIs np
(* verbalization of terms, classes, properties *)
let word_of_entity uri = `Entity (uri, Lexicon.entity_label uri)
let word_of_class uri = `Class (uri, Lexicon.class_label uri)
let word_syntagm_of_property grammar uri =
let synt, name = Lexicon.property_label uri in
`Prop (uri, name), synt
let word_syntagm_of_pred_uri grammar uri =
let synt, name = Lexicon.property_label uri in
`Nary (uri,name), synt
let word_syntagm_of_arg_uri grammar uri =
let synt, name = Lexicon.arg_label uri in
`Nary (uri,name), synt
let word_syntagm_of_pred grammar (pred : pred) =
match pred with
| Class c -> word_of_class c, `Noun
| Prop p -> word_syntagm_of_property grammar p
| SO (ps,po) -> word_syntagm_of_pred_uri grammar po
| EO (pe,po) -> word_syntagm_of_pred_uri grammar pe
let rec word_of_term = function
| Rdf.URI uri -> word_of_entity uri
| Rdf.Number (f,s,dt) -> word_of_term (if dt="" then Rdf.PlainLiteral (s,"") else Rdf.TypedLiteral (s,dt))
| Rdf.TypedLiteral (s,dt) -> `TypedLiteral (s, Lexicon.class_label dt)
| Rdf.PlainLiteral (s,"") -> `Literal s
| Rdf.PlainLiteral (s,lang) -> `TypedLiteral (s,lang)
| Rdf.Bnode id -> `Blank id (* should not occur *)
| Rdf.Var v -> assert false (*`Id (0, `Var v)*) (* should not occur *)
let string_of_term = function
| Rdf.URI uri -> Lexicon.entity_label uri
| Rdf.Number (f,s,dt) -> s
| Rdf.TypedLiteral (s,dt) -> s
| Rdf.PlainLiteral (s,_) -> s
| Rdf.Bnode id -> id (* should not occur *)
| Rdf.Var v -> assert false
let string_of_input_type grammar = function
| IRIInput -> grammar#uri
| StringInput -> grammar#string
| FloatInput -> grammar#number
| IntegerInput -> grammar#integer
| DateInput -> grammar#date
| TimeInput -> grammar#time
| DateTimeInput -> grammar#date_and_time
| DurationInput -> grammar#duration
let aggreg_syntax grammar g =
let qu, noun, adj_opt = grammar#aggreg_syntax g in
let noun_word = if g=Sample then `Op noun else `Func noun in
let adj_word_opt = match adj_opt with None -> None | Some adj -> Some (if g=Sample then `Op adj else `Func adj) in
qu, noun, adj_opt, noun_word, adj_word_opt
let word_of_aggreg grammar g =
let _, _, _, noun_word, adj_word_opt = aggreg_syntax grammar g in
match adj_word_opt with
| Some adj_word -> adj_word
| _ -> noun_word
let string_of_func grammar func =
match grammar#func_syntax func with
| `Noun s -> s
| `Prefix s -> s
| `Infix s -> s
| `Brackets (s1,s2) -> String.concat " " [s1;s2]
| `Pattern l ->
String.concat " "
(List.map
(function
| `Kwd s -> s
| `Func s -> s
| `Arg i -> "_")
l)
let word_of_order grammar = function
| Unordered -> `Op ""
| Highest _ -> `Op grammar#order_highest
| Lowest _ -> `Op grammar#order_lowest
let word_of_selection_op grammar = function
| AndSel | NAndSel -> `Op grammar#and_
| OrSel | NOrSel -> `Op grammar#or_
| AggregSel -> `Op ""
let word_of_incr grammar = function
| IncrSelection (selop,_) -> word_of_selection_op grammar selop
| IncrInput (s,dt) -> `Op (string_of_input_type grammar dt)
| IncrTerm t -> word_of_term t
| IncrId (id,_) -> `Thing
| IncrPred (arg,pred) -> fst (word_syntagm_of_pred grammar pred)
| IncrArg q -> fst (word_syntagm_of_arg_uri grammar q)
| IncrType c -> word_of_class c
| IncrRel (p,_) -> fst (word_syntagm_of_property grammar p)
| IncrLatLong _ -> `Op grammar#geolocation
| IncrTriple _ -> `Relation
| IncrTriplify -> `Relation
| IncrHierarchy trans_rel -> `Op grammar#in_
| IncrSim (pred,args,argo) -> fst (word_syntagm_of_pred grammar pred)
| IncrSimRankIncr -> `Op grammar#rank
| IncrSimRankDecr -> `Op grammar#rank
| IncrAnything -> `Op grammar#anything
| IncrThatIs -> `Op grammar#is
| IncrSomethingThatIs -> `Op grammar#something
| IncrAnd -> `Op grammar#and_
| IncrDuplicate -> `Op grammar#and_
| IncrOr -> `Op grammar#or_
| IncrChoice -> `Op grammar#choice
| IncrMaybe -> `Op grammar#optionally
| IncrNot -> `Op grammar#not_
| IncrIn -> `Op grammar#according_to
| IncrInWhichThereIs -> `Op grammar#according_to
| IncrUnselect -> `Op grammar#any
| IncrOrder o -> word_of_order grammar o
| IncrForeach -> `Thing
| IncrAggreg g -> word_of_aggreg grammar g
| IncrForeachResult -> `Op grammar#result
| IncrForeachId id -> `Thing
| IncrAggregId (g,id) -> word_of_aggreg grammar g
| IncrFuncArg (is_pred,func,arity,pos,_,_) -> `Op (string_of_func grammar func)
| IncrName name -> `Op "="
(* verbalization of IDs *)
type id_label = Rdf.var * ng_label
type id_labelling_list = (Lisql.id * [`Labels of id_label list | `Alias of Lisql.id]) list
let rec get_id_labelling (id : Lisql.id) (lab : id_labelling_list) : id_label list =
try
match List.assoc id lab with
| `Labels ls -> ls
| `Alias id2 -> get_id_labelling id2 lab
with Not_found -> []
let var_of_uri (uri : Rdf.uri) : string =
match Regexp.search (Regexp.regexp "[A-Za-z0-9_]+$") uri 0 with
| Some (i,res) -> Regexp.matched_string res
| None -> "thing"
let var_of_pred (pred : pred) : string =
match pred with
| Class c -> var_of_uri c
| Prop p -> var_of_uri p
| SO (ps,po) -> var_of_uri po
| EO (pe,po) -> var_of_uri pe
let var_of_aggreg = function
| NumberOf -> "number_of"
| ListOf -> "list_of"
| Sample -> "sample"
| Total _ -> "total"
| Average _ -> "average"
| Maximum _ -> "maximum"
| Minimum _ -> "minimum"
let rec labelling_p1 grammar ~labels : 'a elt_p1 -> id_label list * id_labelling_list = function
| Is (_,np) -> labelling_s1 ~as_p1:true grammar ~labels np
| Pred (_,arg,pred,cp) ->
let v = var_of_pred pred in
let w, synt = word_syntagm_of_pred grammar pred in
let ls_cp =
match arg, synt with
| S, `Noun
| O, `InvNoun -> List.map (fun (_,l) -> (v, `Gen (l,w))) labels @ [(v, `Word w)]
| _ -> [] in
let ls_cp, lab = labelling_sn grammar ~labels:ls_cp cp in
let ls =
match arg, synt with
| S, `InvNoun
| O, `Noun -> List.map (fun (_,l) -> (v, `Of (w,l))) ls_cp @ [(v, `Word w)]
| _ -> [] in
ls, lab
| Type (_,c) ->
let v, w = var_of_uri c, word_of_class c in
[(v, `Word w)], []
| Rel (_, p, ori, np) ->
let v = var_of_uri p in
let w, synt = word_syntagm_of_property grammar p in
let ls_np =
match synt, ori with
| `Noun, Fwd
| `InvNoun, Bwd -> List.map (fun (_,l) -> (v, `Gen (l,w))) labels @ [(v, `Word w)]
| _ -> [] in
let ls_np, lab = labelling_s1 ~as_p1:false grammar ~labels:ls_np np in
let ls =
match synt, ori with
| `Noun, Bwd
| `InvNoun, Fwd -> List.map (fun (_,l) -> (v, `Of (w,l))) ls_np @ [(v, `Word w)]
| _ -> [] in
ls, lab
| Hier (_, id, pred, args, argo, np) ->
(* TODO: how to use pred, args, argo ? *)
let ls_np, lab_np = labelling_s1 ~as_p1:false grammar ~labels:[] np in
let labels_id =
List.map (fun (v,l) -> "hier_"^v, `Hierarchy l) labels in
ls_np, (id, `Labels labels_id) :: lab_np
| Sim (_,np,pred,args,argo,rank) -> (* similar to 'np or a pred' *)
let _ls_np, lab_np = labelling_s1 ~as_p1:false grammar ~labels np in
let v = var_of_pred pred in
let w, synt = word_syntagm_of_pred grammar pred in
[(v, `Word w)], lab_np (* TODO: improve *)
| LatLong (_,_ll,id1,id2) ->
let ls_lat = List.map (fun (v,l) -> (v ^ "_lat", `Gen (l, `Op grammar#latitude))) labels in
let ls_long = List.map (fun (v,l) -> (v ^ "_long", `Gen (l, `Op grammar#longitude))) labels in
[], [(id1, `Labels ls_lat); (id2, `Labels ls_long)]
| Triple (_,arg,np1,np2) ->
let v, w = "relation", `Relation in
let ls_np1 =
match arg with
| S -> List.map (fun (_,l) -> (v, `Gen (l,w))) labels @ [(v, `Word w)]
| _ -> [] in
let ls_np2 =
match arg with
| O -> List.map (fun (_,l) -> (v, `Gen (l,w))) labels @ [(v, `Word w)]
| _ -> [] in
let ls_np1, lab1 = labelling_s1 ~as_p1:false grammar ~labels:ls_np1 np1 in
let ls_np2, lab2 = labelling_s1 ~as_p1:false grammar ~labels:ls_np2 np2 in
let ls =
match arg with
| P -> List.map (fun (_,l) -> (v, `Of (w,l))) ls_np1 @ [(v, `Word w)]
| _ -> [] in
ls, lab1 @ lab2
| Search _ -> [], []
| Filter _ -> [], []
| And (_,lr) ->
let lss, labs = List.split (List.map (labelling_p1 grammar ~labels) lr) in
List.concat lss, List.concat labs
| Or (_,lr) ->
let _lss, labs = List.split (List.map (labelling_p1 grammar ~labels) lr) in
[], List.concat labs
| Maybe (_,elt) ->
let ls, lab = labelling_p1 grammar ~labels elt in
ls, lab
| Not (_,elt) ->
let _ls, lab = labelling_p1 grammar ~labels elt in
[], lab
| In (_,npg,elt) ->
let _, lab1 = labelling_s1 ~as_p1:false grammar ~labels:[] npg in
let ls, lab2 = labelling_p1 grammar ~labels elt in
ls, lab1 @ lab2
| InWhichThereIs (_,np) ->
let _, lab = labelling_s1 ~as_p1:false grammar ~labels:[] np in
[], lab
| IsThere _ -> [], []
and labelling_p1_opt grammar ~labels : 'a elt_p1 option -> id_label list * id_labelling_list = function
| None -> [], []
| Some rel -> labelling_p1 grammar ~labels rel
and labelling_sn grammar ~labels : 'a elt_sn -> id_label list * id_labelling_list = function
| CNil _ -> [], []
| CCons (_,arg,np,cp) ->
let ls_np =
match arg with
| S | O -> labels
| P ->
let v, w = "relation", `Relation in
[(v, `Word w)]
| Q q ->
let v = var_of_uri q in
let w, synt = word_syntagm_of_arg_uri grammar q in
[(v, `Word w)] in
let ls_np, lab_np = labelling_s1 ~as_p1:false grammar ~labels:ls_np np in
let ls_cp, lab_cp = labelling_sn grammar ~labels cp in
let ls =
match arg with
| S | O -> ls_np @ ls_cp
| _ -> ls_cp in
ls, lab_np @ lab_cp
| CAnd (_, lr) ->
let lss, labs = List.split (List.map (labelling_sn grammar ~labels) lr) in
List.concat lss, List.concat labs
| COr (_, lr) ->
let _lss, labs = List.split (List.map (labelling_sn grammar ~labels) lr) in
[], List.concat labs
| CMaybe (_, elt) ->
let ls, lab = labelling_sn grammar ~labels elt in
ls, lab
| CNot (_, elt) ->
let _ls, lab = labelling_sn grammar ~labels elt in
[], lab
and labelling_s1 ~as_p1 grammar ~labels : 'a elt_s1 -> id_label list * id_labelling_list = function
| Det (_, An (id, modif, head), rel_opt) ->
let ls_head = match head with Thing -> [] | Class c -> [(var_of_uri c, `Word (word_of_class c))] in
let labels2 = labels @ ls_head in
let ls_rel, lab_rel = labelling_p1_opt grammar ~labels:labels2 rel_opt in
ls_head @ ls_rel, if as_p1 then lab_rel else (id, `Labels (labels2 @ ls_rel)) :: lab_rel
| Det (_, _, rel_opt) ->
let ls_rel, lab_rel = labelling_p1_opt grammar ~labels rel_opt in
ls_rel, lab_rel
| AnAggreg (_, id, modif, g, rel_opt, np) ->
let ls_np, lab_np = labelling_s1 ~as_p1:false grammar ~labels np in
let id =
match id_of_s1 np with
| Some id -> id
| None -> assert false in
let ls_g = labelling_aggreg_op grammar g id in
ls_np, (id, `Labels ls_g) :: lab_np
| NAnd (_, lr) ->
let lss, labs = List.split (List.map (labelling_s1 ~as_p1 grammar ~labels) lr) in
List.concat lss, List.concat labs
| NOr (_, lr) ->
let _lss, labs = List.split (List.map (labelling_s1 ~as_p1 grammar ~labels) lr) in
[], List.concat labs
| NMaybe (_, elt) ->
let ls, lab = labelling_s1 ~as_p1 grammar ~labels elt in
ls, lab
| NNot (_, elt) ->
let _ls, lab = labelling_s1 ~as_p1 grammar ~labels elt in
[], lab
and labelling_aggreg grammar ~labelling : 'a elt_aggreg -> id_labelling_list = function
| ForEachResult _ -> labelling
| ForEach (_, id, modif, rel_opt, id2) ->
let ls = get_id_labelling id2 labelling in
let ls_rel, lab_rel = labelling_p1_opt grammar ~labels:ls rel_opt in
labelling @ (id, `Alias id2) :: lab_rel
| ForTerm (_, t, id2) -> labelling
| TheAggreg (_, id, modif, g, rel_opt, id2) ->
let ls_g = labelling_aggreg_op grammar g id2 in
let ls_rel, lab_rel = labelling_p1_opt grammar ~labels:ls_g rel_opt in
labelling @ (id, `Labels ls_g) :: lab_rel
and labelling_aggreg_op grammar g id =
let v_g = var_of_aggreg g in
let l_g =
let qu, noun, adj_opt, noun_word, adj_word_opt = aggreg_syntax grammar g in
match adj_word_opt with
| Some adj_word -> `AggregAdjective (adj_word, `Ref id)
| None -> `AggregNoun (noun_word, `Ref id) in
[(v_g, l_g)]
and labelling_s grammar ?(labelling = []) : 'a elt_s -> id_labelling_list = function
| Return (_, np) ->
let _ls, lab = labelling_s1 ~as_p1:false grammar ~labels:[] np in
labelling @ lab
| SAggreg (_,aggregs) ->
let lab1 = labelling in
let lab2 = List.fold_left (fun labelling aggreg -> labelling_aggreg grammar ~labelling aggreg) lab1 aggregs in
lab2
| SExpr (_,name,id,modif,expr,rel_opt) ->
let ls_rel, lab_rel = labelling_p1_opt grammar ~labels:[] rel_opt in
let expr_label = if name="" then `Expr expr else `Word (`Func name) in
labelling @ (id, `Labels [("expr", expr_label)]) :: lab_rel
| SFilter (_,id,expr) ->
labelling @ (id, `Labels [("expr", `Expr expr)]) :: []
| Seq (_, lr) ->
List.fold_left
(fun labelling s -> labelling_s grammar ~labelling s)
labelling lr
let rec size_ng_label ~(size_id_label : Lisql.id -> int) : ng_label -> int = function
| `Word w -> 1
| `Expr _ -> 1
| `Ref id -> size_id_label id
| `Gen (l,w) -> size_ng_label ~size_id_label l + 1
| `Of (w,l) -> 1 + size_ng_label ~size_id_label l
| `AggregNoun (w,l) -> size_ng_label ~size_id_label l
| `AggregAdjective (w,l) -> size_ng_label ~size_id_label l
(* not favoring 'the average' w.r.t. 'the average <prop>' *)
| `Hierarchy l -> 1 + size_ng_label ~size_id_label l
| `Nth (k,l) -> 1 + size_ng_label ~size_id_label l
class ['a ] counter =
object
val mutable key_cpt = []
method rank (key : 'a) : int =
try
let cpt = List.assoc key key_cpt in
key_cpt <- (key,cpt+1)::List.remove_assoc key key_cpt;
cpt+1
with Not_found ->
key_cpt <- (key,1)::key_cpt;
1
method count (key : 'a) : int =
try List.assoc key key_cpt
with Not_found -> 0
end
class id_labelling (lab : id_labelling_list) =
object (self)
val label_counter : ng_label counter = new counter
val mutable id_list : (id * ((Rdf.var * Lisql.id) * ng_label)) list = []
initializer
(* normalizing label lists, and attributing ranks with [label_counter] *)
let lab_rank =
List.map
(function
| (id, `Alias id2) -> (id, `Alias id2)
| (id, `Labels ls) ->
let ls = Common.list_to_set ls in (* removing duplicates *)
let ls = if ls = [] then [("thing", `Word `Thing)] else ls in (* default label *)
let ls_rank =
List.map
(fun (var_prefix, ng) ->
let k = label_counter#rank ng in
var_prefix, (ng, k))
ls in
(id, `Labels ls_rank))
lab in
lab_rank |> List.iter
(function
| (id, `Alias id2) ->
let id2_data =
try List.assoc id2 id_list
with Not_found -> (("",id2), `Word `Undefined) in (* should not happen *)
id_list <- (id, id2_data)::id_list
| (id, `Labels ls_rank) ->
let _, _, best_label =
List.fold_left
(fun (best_count,best_size,best_label) (_,(ng,_) as label) ->
let count = label_counter#count ng in
let size =
let rec size_id_label id =
let ng_id =
try snd (List.assoc id id_list)
with Not_found -> `Word `Undefined (* should not happen *) in
size_ng_label ~size_id_label ng_id
in
size_ng_label ~size_id_label ng in
if count < best_count then (count,size,label)
else if count = best_count && size < best_size then (count,size,label)
else (best_count,best_size,best_label))
(max_int, max_int, (try List.hd ls_rank with _ -> assert false))
ls_rank in
let best_prefix, (best_ng, best_k) = best_label in
let best_ng =
let n = label_counter#count best_ng in
if n = 1
then best_ng
else `Nth (best_k, best_ng) in
id_list <- (id, ((best_prefix,id), best_ng))::id_list)
method get_id_label (id : id) : ng_label =
try snd (List.assoc id id_list)
with Not_found -> `Word `Undefined (* should not happen *)
method get_id_var (id : id) : string =
let prefix, id =
try fst (List.assoc id id_list)
with Not_found -> "thing", id in
prefix ^ "_" ^ string_of_int id
method get_var_id (v : string) : id =
match Regexp.search (Regexp.regexp "[0-9]+$") v 0 with
| Some (i,res) -> (try int_of_string (Regexp.matched_string res) with _ -> assert false)
| None -> assert false
end
let id_labelling_of_s_annot grammar s_annot : id_labelling =
let lab = labelling_s grammar s_annot in
new id_labelling lab
(* verbalization of focus *)
let rec head_of_modif grammar annot_opt nn rel (modif : modif_s2) : np =
let qu, adj =
match modif with
| Select, order -> qu_adj_of_order grammar `A order
| Unselect, order ->
`Any
( match annot_opt with
| None -> false
| Some annot -> annot#is_at_focus),
snd (qu_adj_of_order grammar `A order) in
let nl = `Qu (qu, adj, `That (nn, rel)) in
match annot_opt with
| None -> nl
| Some annot -> `Focus (annot,nl)
and qu_adj_of_modif grammar annot_opt qu modif : qu * adj =
match modif with
| Select, order -> qu_adj_of_order grammar qu order
| Unselect, order -> `Any (match annot_opt with None -> false | Some annot -> annot#is_at_focus), snd (qu_adj_of_order grammar `A order)
and qu_adj_of_order grammar qu : order -> qu * adj = function
| Unordered -> qu, `Nil
| Highest _ -> `The, `Order (`Op grammar#order_highest)
| Lowest _ -> `The, `Order (`Op grammar#order_lowest)
let ng_of_id ~id_labelling id : ng =
`LabelThat (id_labelling#get_id_label id, top_rel)
let vp_of_sim grammar annot_opt (np : np) pred args argo rank : vp =
let w, synt = word_syntagm_of_pred grammar pred in
let nl_rank =
`AtNoun (`Op grammar#rank, `PN (`TypedLiteral (string_of_int rank, Rdf.xsd_integer), `Nil)) in
let nl_sim : vp =
match synt, args, argo with
| `Noun, S, O
| `InvNoun, O, S ->
`IsNP (`Qu (`A, `Nil, `OfThat (w, np, if rank=0 then `Nil else `PP [nl_rank])), [])
| `InvNoun, S, O
| `Noun, O, S ->
`HasProp (w, np, if rank=0 then [] else [nl_rank])
(* `IsNP (X (`Qu (`A, `Nil, X (`That (`Thing, X (`That (X (`Subject (np, X (`IsNP (X (`Qu (`A, `Nil, X (`OfThat (w, X `Void, X `Nil)))), if rank=0 then [] else [nl_rank])))))))))), []) *)
| `TransVerb, S, O ->
`IsNP (`Qu (`A, `Nil, `That (`Thing, `That (`Subject (np, `VT (w, `Void, if rank=0 then [] else [nl_rank]))))), [])
| `TransVerb, O, S ->
`VT (w, np, if rank=0 then [] else [nl_rank])
| `TransAdj, S, O ->
`IsNP (`Qu (`A, `Nil, `That (`Thing, `That (`Subject (np, `IsAdjCP (w, if rank=0 then `Nil else `Cons (nl_rank, `Nil)))))), [])
| `TransAdj, O, S ->
`IsAdjCP (w, `Cons (`Bare np, if rank=0 then `Nil else `Cons (nl_rank, `Nil)))
| _ -> failwith "Lisql2nl.np_of_sim: Invalid args/argo" in
match annot_opt with
| None -> nl_sim
| Some annot -> `Focus (annot, nl_sim)
let np_of_aggreg grammar annot_opt qu (modif : modif_s2) (g : aggreg) (rel : rel) (ng : ng) =
let qu, adj = qu_adj_of_modif grammar annot_opt qu modif in
let qu_aggreg, noun, adj_opt, noun_word, adj_word_opt = aggreg_syntax grammar g in
let ng_aggreg =
match adj_word_opt with
| Some adj_word -> `AdjThat (adj_word, rel)
| None -> `NounThatOf (noun_word, rel) in
let qu = if qu = `The then (qu_aggreg :> qu) else qu in (* the sample of --> a sample of *)
let susp = match annot_opt with None -> false | Some annot -> annot#is_susp_focus in
let nl = `Qu (qu, adj, `Aggreg (susp, ng_aggreg, ng)) in
match annot_opt with
| None -> nl
| Some annot -> `Focus (annot,nl)
(*
let syntax_of_func grammar (func : func)
: [ `Infix of string | `Noun of string | `Const of string ] =
let s = string_of_func grammar func in
match func with
| `Add | `Sub | `Mul | `Div -> `Infix s
| `Strlen -> `Noun s
| `NOW -> `Const s
| _ -> failwith "TODO"
*)
let np_of_apply grammar annot_opt adj func (np_args : np list) (rel : rel) : np =
let nl = `Expr (adj, grammar#func_syntax func, np_args, rel) in
match annot_opt with
| None -> nl
| Some annot -> `Focus (annot, nl)
let rec vp_of_elt_p1 grammar ~id_labelling : annot elt_p1 -> vp = function
| IsThere annot -> `Focus (annot, `Ellipsis)
| Is (annot,np) -> `Focus (annot, `IsNP (np_of_elt_s1 grammar ~id_labelling np, []))
| Pred (annot,arg,pred,cp) -> `Focus (annot, nl_vp_of_arg_pred grammar ~id_labelling arg pred cp)
| Type (annot,c) -> `Focus (annot, `IsNP (`Qu (`A, `Nil, `That (word_of_class c, top_rel)), []))
| Rel (annot,p,Fwd,np) ->
let word, synt = word_syntagm_of_property grammar p in
let np = np_of_elt_s1 grammar ~id_labelling np in
( match synt with
| `Noun -> `Focus (annot, `HasProp (word, np, []))
| `InvNoun -> `Focus (annot, `IsNP (`Qu (`The, `Nil, `OfThat (word, np, top_rel)), []))
| `TransVerb -> `Focus (annot, `VT (word, np, []))
| `TransAdj -> `Focus (annot, `IsPP (`Prep (word, np))) )
| Rel (annot,p,Bwd,np) ->
let word, synt = word_syntagm_of_property grammar p in
let np = np_of_elt_s1 grammar ~id_labelling np in
( match synt with
| `Noun -> `Focus (annot, `IsNP (`Qu (`The, `Nil, `OfThat (word, np, top_rel)), []))
| `InvNoun -> `Focus (annot, `HasProp (word, np, []))
| `TransVerb -> `Focus (annot, `Subject (np, `VT (word, `Void, [])))
| `TransAdj -> `Focus (annot, `Subject (np, `IsPP (`Prep (word, `Void)))) )
| Hier (annot, id, pred, args, argo, np) -> (* TODO: render pred, args, argo *)
`Focus (annot, `IsPP (`Prep (`Op grammar#in_, np_of_elt_s1 grammar ~id_labelling np)))
| Sim (annot,np,pred,args,argo,rank) ->
vp_of_sim grammar (Some annot)
(np_of_elt_s1 grammar ~id_labelling np)
pred args argo rank
| LatLong (annot,_ll,_id1,_id2) ->
`Focus (annot, `Has (`Qu (`A, `Nil, `That (`Op grammar#geolocation, `Nil)), []))
| Triple (annot,arg,np1,np2) ->
let np1 = np_of_elt_s1 grammar ~id_labelling np1 in
let np2 = np_of_elt_s1 grammar ~id_labelling np2 in
( match arg with
| S -> (* has relation npp to npo / has property npp with value npo / has p npo *)
`Focus (annot, `HasProp (`Relation, np1, [`Prep (`Op grammar#rel_to, np2)]))
| O -> (* has relation npp from nps / is the value of npp of nps / is the p of nps *)
`Focus (annot, `HasProp (`Relation, np2, [`Prep (`Op grammar#rel_from, np1)]))
| P -> (* is a relation from nps to npo / is a property of nps with value npo *)
`Focus (annot, `IsNP (`Qu (`A, `Nil, `That (`Relation, top_rel)), [`Prep (`Op grammar#rel_from, np1); `Prep (`Op grammar#rel_to, np2)]))
| _ -> assert false )
| Search (annot,c) -> vp_of_constr grammar annot c
| Filter (annot,c,ft) -> vp_of_constr grammar annot c
| And (annot,lr) -> `Focus (annot, `And (List.map (vp_of_elt_p1 grammar ~id_labelling) lr))
| Or (annot,lr) -> `Focus (annot, `Or (List.map (vp_of_elt_p1 grammar ~id_labelling) lr))
| Maybe (annot,x) -> `Focus (annot, `Maybe (vp_of_elt_p1 grammar ~id_labelling x))
| Not (annot,x) -> `Focus (annot, `Not (vp_of_elt_p1 grammar ~id_labelling x))
| In (annot,npg,x) -> `Focus (annot, `In (np_of_elt_s1 grammar ~id_labelling npg, vp_of_elt_p1 grammar ~id_labelling x))
| InWhichThereIs (annot,np) -> `Focus (annot, `IsInWhich (`ThereIs (np_of_elt_s1 grammar ~id_labelling np)))
and vp_of_constr grammar annot = function
| True -> `Focus (annot, `Ellipsis)
| MatchesAll [pat]
| MatchesAny [pat] -> `Focus (annot, `VT (`Op grammar#matches, `PN (`Literal pat, `Nil), []))
| MatchesAll lpat -> `Focus (annot, `VT (`Op grammar#matches, `QuOneOf (`All, List.map (fun pat -> `Literal pat) lpat), []))
| MatchesAny lpat -> `Focus (annot, `VT (`Op grammar#matches, `QuOneOf (`One, List.map (fun pat -> `Literal pat) lpat), []))
| IsExactly pat -> `Focus (annot, `VT (`Op grammar#is_exactly, `PN (`Literal pat, `Nil), []))
| StartsWith pat -> `Focus (annot, `VT (`Op grammar#starts_with, `PN (`Literal pat, `Nil), []))
| EndsWith pat -> `Focus (annot, `VT (`Op grammar#ends_with, `PN (`Literal pat, `Nil), []))
| After pat -> `Focus (annot, `IsPP (`Prep (`Op grammar#after, np_of_literal pat)))
| Before pat -> `Focus (annot, `IsPP (`Prep (`Op grammar#before, np_of_literal pat)))
| FromTo (pat1,pat2) -> `Focus (annot, `IsPP (`PrepBin (`Op grammar#interval_from, np_of_literal pat1, `Op grammar#interval_to, np_of_literal pat2)))
| HigherThan pat -> `Focus (annot, `IsPP (`Prep (`Op grammar#higher_or_equal_to, np_of_literal pat)))
| LowerThan pat -> `Focus (annot, `IsPP (`Prep (`Op grammar#lower_or_equal_to, np_of_literal pat)))
| Between (pat1,pat2) -> `Focus (annot, `IsPP (`PrepBin (`Op grammar#interval_between, np_of_literal pat1, `Op grammar#interval_and, np_of_literal pat2)))
| HasLang pat -> `Focus (annot, `Has (`Qu (`A, `Nil, `That (`Op grammar#language, `Ing (`Op grammar#matching, `PN (`Literal pat, top_rel), []))), []))
| HasDatatype pat -> `Focus (annot, `Has (`Qu (`A, `Nil, `That (`Op grammar#datatype, `Ing (`Op grammar#matching, `PN (`Literal pat, top_rel), []))), []))
| ExternalSearch (s,_) -> vp_of_search grammar annot s
and vp_of_search grammar annot = function
| WikidataSearch kwds
| TextQuery kwds -> `Focus (annot, `VT (`Op grammar#matches, `PN (`Literal (String.concat " " kwds), `Nil), [])) (* TODO: make search kind explicit *)
and rel_of_elt_p1_opt grammar ~id_labelling = function
| None -> top_rel
| Some (InWhichThereIs (annot,np)) -> `Focus (annot, `InWhich (`ThereIs (np_of_elt_s1 grammar ~id_labelling np)))
| Some rel -> `That (vp_of_elt_p1 grammar ~id_labelling rel)
and np_of_elt_s1 grammar ~id_labelling : annot elt_s1 -> np = function
| Det (annot, det, rel_opt) ->
let nl_rel = rel_of_elt_p1_opt grammar ~id_labelling rel_opt in
det_of_elt_s2 grammar ~id_labelling annot nl_rel det
| AnAggreg (annot,id,modif,g,rel_opt,np) ->
np_of_aggreg grammar (Some annot)
`A modif g
(rel_of_elt_p1_opt grammar ~id_labelling rel_opt)
(ng_of_elt_s1 grammar ~id_labelling np)
| NAnd (annot,lr) -> `Focus (annot, `And (List.map (np_of_elt_s1 grammar ~id_labelling) lr))
| NOr (annot,lr) -> `Focus (annot, `Or (List.map (np_of_elt_s1 grammar ~id_labelling) lr))
| NMaybe (annot,x) -> `Focus (annot, `Maybe (np_of_elt_s1 grammar ~id_labelling x))
| NNot (annot,x) -> `Focus (annot, `Not (np_of_elt_s1 grammar ~id_labelling x))
and ng_of_elt_s1 grammar ~id_labelling : annot elt_s1 -> ng = function
| Det (annot, An (id,modif,head), rel_opt) ->
`Focus (annot, `That (word_of_elt_head head, rel_of_elt_p1_opt grammar ~id_labelling rel_opt))
| AnAggreg (annot,id,modif,g,rel_opt,np) ->
let rel = rel_of_elt_p1_opt grammar ~id_labelling rel_opt in
let ng_aggreg =
let qu, noun, adj_opt, noun_word, adj_word_opt = aggreg_syntax grammar g in
match adj_word_opt with
| Some adj_word -> `AdjThat (adj_word, rel)
| None -> `NounThatOf (noun_word, rel) in
let ng = ng_of_elt_s1 grammar ~id_labelling np in
`Focus (annot, `Aggreg (annot#is_susp_focus, ng_aggreg, ng))
| _ -> assert false
and det_of_elt_s2 grammar ~id_labelling annot rel : elt_s2 -> np = function
| Term t -> `Focus (annot, `PN (word_of_term t, rel))
| An (id, modif, head) -> head_of_modif grammar (Some annot) (word_of_elt_head head) rel modif
| The id -> `Focus (annot, `Qu (`The, `Nil, `LabelThat (id_labelling#get_id_label id, rel)))
(* `Focus (annot, `Ref (id_labelling#get_id_label id, rel)) *)
and word_of_elt_head = function
| Thing -> `Thing
| Class c -> word_of_class c
and np_of_elt_aggreg grammar ~id_labelling : annot elt_aggreg -> np = function
| ForEachResult annot ->
`Focus (annot, `Qu (`Each, `Nil, `That (`Op grammar#result, `Nil)))
| ForEach (annot,id,modif,rel_opt,id2) ->
let qu, adj = qu_adj_of_modif grammar (Some annot) `Each modif in
`Focus (annot, `Qu (qu, adj, `LabelThat (id_labelling#get_id_label id2, rel_of_elt_p1_opt grammar ~id_labelling rel_opt)))
| ForTerm (annot,t,id2) ->
`Focus (annot, `Label (id_labelling#get_id_label id2, Some (word_of_term t)))
| TheAggreg (annot,id,modif,g,rel_opt,id2) ->
np_of_aggreg grammar (Some annot) `The modif g
(rel_of_elt_p1_opt grammar ~id_labelling rel_opt)
(ng_of_id ~id_labelling id2)
and np_of_elt_expr grammar ~id_labelling adj rel : annot elt_expr -> np = function
| Undef annot -> `Focus (annot, `PN (`Undefined, rel))
| Const (annot,t) -> `Focus (annot, `PN (word_of_term t, rel))
| Var (annot,id) ->
if rel = top_rel
then `Focus (annot, `Label (id_labelling#get_id_label id, None))
else det_of_elt_s2 grammar ~id_labelling annot rel (The id)
| Apply (annot,func,args) ->
np_of_apply grammar (Some annot)
adj
func
(List.map (fun (_,arg_expr) -> np_of_elt_expr grammar ~id_labelling top_adj top_rel arg_expr) args)
rel
| Choice (annot,le) ->
let lnp = List.map (fun expr -> np_of_elt_expr grammar ~id_labelling top_adj top_rel expr) le in
`Focus (annot, `Choice (adj, lnp, rel))
and s_of_elt_expr grammar ~id_labelling : annot elt_expr -> s = function
| expr -> `Where (np_of_elt_expr grammar ~id_labelling top_adj top_rel expr)
and s_of_elt_s grammar ~id_labelling : annot elt_s -> s = function
| Return (annot,np) ->
`Focus (annot, `Return (np_of_elt_s1 grammar ~id_labelling np))
| SAggreg (annot,dims_aggregs) ->
let dims, aggregs = List.partition is_dim dims_aggregs in
let nl_s_aggregs =
if aggregs = []
then `Return (`PN (`Undefined, `Nil))
else `Return (nl_and (List.map (np_of_elt_aggreg grammar ~id_labelling) aggregs)) in
if dims = []
then `Focus (annot, nl_s_aggregs)
else
let np_dims = nl_and (List.map (np_of_elt_aggreg grammar ~id_labelling) dims) in
`Focus (annot, `For (np_dims, nl_s_aggregs))
| SExpr (annot,name,id,modif,expr,rel_opt) ->
let _qu, adj = qu_adj_of_modif grammar (Some annot) `The modif in
let rel = rel_of_elt_p1_opt grammar ~id_labelling rel_opt in
let np_expr = np_of_elt_expr grammar ~id_labelling adj rel expr in
let np =
if name=""
then np_expr
else `PN (`Func name, `Ing (`Op "=", np_expr, [])) in
`Focus (annot, `Return np)
| SFilter (annot,id,expr) ->
let s = s_of_elt_expr grammar ~id_labelling expr in
`Focus (annot, s)
| Seq (annot,lr) ->
`Focus (annot, `Seq (List.map (s_of_elt_s grammar ~id_labelling) lr))
and nl_vp_of_arg_pred grammar ~id_labelling arg pred cp =
let word, synt = word_syntagm_of_pred grammar pred in
match arg with
| S -> nl_vp_of_S_pred grammar ~id_labelling ~word ~synt cp
| P -> raise TODO
| O -> nl_vp_of_O_pred grammar ~id_labelling ~word ~synt cp
| Q q -> nl_vp_of_Q_pred grammar ~id_labelling q ~word ~synt cp
and nl_vp_of_S_pred grammar ~id_labelling ~word ~synt cp =
match synt with
| `Noun -> `HasPropCP (word, cp_of_elt_sn grammar ~id_labelling cp)
| `InvNoun -> `IsTheNounCP (word, cp_of_elt_sn grammar ~id_labelling ~inv:true cp)
| `TransVerb -> `VT_CP (word, cp_of_elt_sn grammar ~id_labelling cp)
| `TransAdj -> `IsAdjCP (word, cp_of_elt_sn grammar ~id_labelling cp)
and nl_vp_of_O_pred grammar ~id_labelling ~word ~synt cp =
match synt with
| `Noun -> `IsTheNounCP (word, cp_of_elt_sn grammar ~id_labelling cp)
| `InvNoun -> `HasPropCP (word, cp_of_elt_sn grammar ~id_labelling ~inv:true cp)
| `TransVerb -> nl_is (nl_something (`ThatS (s_of_elt_sn grammar ~id_labelling ~word ~synt cp)))
| `TransAdj -> nl_is (nl_something (`ThatS (s_of_elt_sn grammar ~id_labelling ~word ~synt cp)))
and nl_vp_of_Q_pred grammar ~id_labelling q ~word ~synt cp =
let word_q, synt_q = word_syntagm_of_arg_uri grammar q in
match synt_q with
| `Noun -> nl_is (nl_something (`AtWhichNoun (word_q, s_of_elt_sn grammar ~id_labelling ~word ~synt cp)))
| `TransAdj -> nl_is (nl_something (`PrepWhich (word_q, s_of_elt_sn grammar ~id_labelling ~word ~synt cp)))
(* | `InvNoun -> `HasProp (word_q, X (`TheFactThat (s_of_elt_sn grammar ~id_labelling ~word ~synt cp)), []) *)
(* | `TransVerb -> nl_is (something (X (`ThatS (X (`Truth (X (`TheFactThat (s_of_elt_sn grammar ~id_labelling ~word ~synt cp)), X (`VT_CP (word_q, X `Nil)))))))) *)
and s_of_elt_sn grammar ~id_labelling ~word ~synt : annot elt_sn -> s = function
| CNil annot -> (* missing subject *)
`Truth (nl_something `Nil, nl_vp_of_S_pred grammar ~id_labelling ~word ~synt (CNil annot))
| CCons (annot, arg, np, cp) ->
if arg = S
then `Focus (annot, `Truth (np_of_elt_s1 grammar ~id_labelling np, nl_vp_of_S_pred grammar ~id_labelling ~word ~synt cp))
else `Focus (annot, `PP (pp_of_arg_elt_np grammar ~id_labelling arg np, s_of_elt_sn grammar ~id_labelling ~word ~synt cp))
| CAnd (annot,lr) -> `Focus (annot, `And (List.map (s_of_elt_sn grammar ~id_labelling ~word ~synt) lr))
| COr (annot,lr) -> `Focus (annot, `Or (List.map (s_of_elt_sn grammar ~id_labelling ~word ~synt) lr))
| CMaybe (annot,x) -> `Focus (annot, `Maybe (s_of_elt_sn grammar ~id_labelling ~word ~synt x))
| CNot (annot,x) -> `Focus (annot, `Not (s_of_elt_sn grammar ~id_labelling ~word ~synt x))
and cp_of_elt_sn grammar ~id_labelling ?(inv = false) : annot elt_sn -> cp = function
| CNil annot -> `Focus (annot, `Nil)
| CCons (annot, arg, np, cp) ->
let arg =
if inv
then (match arg with S -> O | O -> S | _ -> arg)
else arg in
`Focus (annot, `Cons (pp_of_arg_elt_np grammar ~id_labelling arg np, cp_of_elt_sn grammar ~id_labelling cp))
| CAnd (annot,lr) -> `Focus (annot, `And (List.map (cp_of_elt_sn grammar ~id_labelling ~inv) lr))
| COr (annot,lr) -> `Focus (annot, `Or (List.map (cp_of_elt_sn grammar ~id_labelling ~inv) lr))
| CMaybe (annot,x) -> `Focus (annot, `Maybe (cp_of_elt_sn grammar ~id_labelling ~inv x))
| CNot (annot,x) -> `Focus (annot, `Not (cp_of_elt_sn grammar ~id_labelling ~inv x))
and pp_of_arg_elt_np grammar ~id_labelling arg np =
let np = np_of_elt_s1 grammar ~id_labelling np in
match arg with
| S -> `Prep (`Op grammar#of_,np)
| O -> `Bare np
| P -> `Bare np (* in 'has relation P from S to O' *)
| Q q ->
let word_q, synt_q = word_syntagm_of_arg_uri grammar q in
( match synt_q with
| `Noun -> `AtNoun (word_q, np)
| `TransAdj -> `Prep (word_q, np) )
(* linguistic transformations *)
class transf =
object
method s : s -> s = fun s -> s
method np : np -> np = fun np -> np
method ng : ng -> ng = fun ng -> ng
method adj : adj -> adj = fun adj -> adj
method ng_aggreg : ng_aggreg -> ng_aggreg = fun ngg -> ngg
method rel : rel -> rel = fun rel -> rel
method vp : vp -> vp = fun vp -> vp
method cp : cp -> cp = fun cp -> cp
method pp : pp -> pp = fun pp -> pp
end
(* top-down recursive transformation using [transf] like a visitor *)
let rec map_s (transf : transf) s =
match transf#s s with
| `Return np -> `Return (map_np transf np)
| `ThereIs np -> `ThereIs (map_np transf np)
| `ThereIs_That (np,s) -> `ThereIs_That (map_np transf np, map_s transf s)