Source file ccalgo.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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
open CErrors
open Pp
open Names
open Sorts
open Constr
open Context
open Vars
open Util
open Lazy
let init_size=5
let debug_congruence = CDebug.create ~name:"congruence" ()
module ST=struct
module IntTable = Hashtbl.Make(Int)
module IntPair =
struct
type t = int * int
let equal (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2
let hash (i, j) = Hashset.Combine.combine (Int.hash i) (Int.hash j)
end
module IntPairTable = Hashtbl.Make(IntPair)
type t = {toterm: int IntPairTable.t;
tosign: (int * int) IntTable.t}
let empty () =
{toterm=IntPairTable.create init_size;
tosign=IntTable.create init_size}
let enter t sign st=
if IntPairTable.mem st.toterm sign then
anomaly ~label:"enter" (Pp.str "signature already entered.")
else
IntPairTable.replace st.toterm sign t;
IntTable.replace st.tosign t sign
let query sign st=IntPairTable.find st.toterm sign
let delete st t=
try let sign=IntTable.find st.tosign t in
IntPairTable.remove st.toterm sign;
IntTable.remove st.tosign t
with
Not_found -> ()
let delete_set st s = Int.Set.iter (delete st) s
end
type pa_constructor=
{ cnode : int;
arity : int;
args : int list}
type pa_fun=
{fsym:int;
fnargs:int}
type pa_mark=
Fmark of pa_fun
| Cmark of pa_constructor
module PacOrd =
struct
type t = pa_constructor
let compare { cnode = cnode0; arity = arity0; args = args0 }
{ cnode = cnode1; arity = arity1; args = args1 } =
let cmp = Int.compare cnode0 cnode1 in
if cmp = 0 then
let cmp' = Int.compare arity0 arity1 in
if cmp' = 0 then
List.compare Int.compare args0 args1
else
cmp'
else
cmp
end
module PafOrd =
struct
type t = pa_fun
let compare { fsym = fsym0; fnargs = fnargs0 } { fsym = fsym1; fnargs = fnargs1 } =
let cmp = Int.compare fsym0 fsym1 in
if cmp = 0 then
Int.compare fnargs0 fnargs1
else
cmp
end
module PacMap=Map.Make(PacOrd)
module PafMap=Map.Make(PafOrd)
type cinfo=
{ci_constr: pconstructor;
ci_arity: int;
ci_nhyps: int}
let family_eq f1 f2 = match f1, f2 with
| Set, Set
| Prop, Prop
| Type _, Type _ -> true
| _ -> false
type 'a term =
Symb of constr * int
| Product of Sorts.t * Sorts.t
| Eps of Id.t
| Appli of 'a * 'a
| Constructor of cinfo
module ATerm :
sig
type t
val proj : t -> t term
val mkSymb : constr -> t
val mkProduct : (Sorts.t * Sorts.t) -> t
val mkEps : Id.t -> t
val mkAppli : (t * t) -> t
val mkConstructor : Environ.env -> cinfo -> t
val equal : t -> t -> bool
val constr : t -> constr
val hash : t -> int
val nth_arg : t -> int -> t
end =
struct
type t = {
term : t term;
constr : constr lazy_t;
hash : int }
let proj t = t.term
let rec term_equal t1 t2 =
match t1, t2 with
| Symb (c1,_), Symb (c2,_) -> eq_constr_nounivs c1 c2
| Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2
| Eps i1, Eps i2 -> Id.equal i1 i2
| Appli (t1', u1'), Appli (t2', u2') -> term_equal t1'.term t2'.term && term_equal u1'.term u2'.term
| Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1},
Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} ->
Int.equal i1 i2 && Int.equal j1 j2 && Construct.UserOrd.equal c1 c2
| _ -> false
let equal t1 t2 = term_equal t1.term t2.term
open Hashset.Combine
let hash_term t =
match t with
| Symb (_,hash_c) -> combine 1 hash_c
| Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2)
| Eps i -> combine 3 (Id.hash i)
| Appli (t1', t2') -> combine3 4 (t1'.hash) (t2'.hash)
| Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (Construct.UserOrd.hash c) i j
let hash t = t.hash
let _A_ = Name (Id.of_string "A")
let _B_ = Name (Id.of_string "A")
let _body_ = mkProd(make_annot Anonymous Sorts.Relevant,mkRel 2,mkRel 2)
let cc_product s1 s2 =
mkLambda(make_annot _A_ Sorts.Relevant,mkSort(s1),
mkLambda(make_annot _B_ Sorts.Relevant,mkSort(s2),_body_))
let rec constr_of_term = function
Symb (s,_) -> s
| Product(s1,s2) -> cc_product s1 s2
| Eps id -> mkVar id
| Constructor cinfo -> mkConstructU cinfo.ci_constr
| Appli (s1',s2') -> make_app [force s2'.constr] s1'
and make_app l t' =
match t'.term with
Appli (s1',s2')->make_app ((force s2'.constr)::l) s1'
| _ -> Term.applist (force t'.constr, l)
let constr t = force t.constr
let make t = {
term = t;
constr = lazy (constr_of_term t);
hash = hash_term t }
let rec drop_univ c =
match kind c with
| Const (c,_u) -> mkConstU (c,UVars.Instance.empty)
| Ind (c,_u) -> mkIndU (c,UVars.Instance.empty)
| Construct (c,_u) -> mkConstructU (c,UVars.Instance.empty)
| Sort (Type _u) -> mkSort (type1)
| _ -> Constr.map drop_univ c
let mkSymb s = make (Symb (s, Constr.hash (drop_univ s)))
let mkProduct (s1, s2) = make (Product (s1, s2))
let mkEps id = make (Eps id)
let mkAppli (t1', t2') = make (Appli (t1', t2'))
let mkConstructor env info =
let canon i = Environ.QConstruct.canonize env i in
let info = { info with ci_constr = on_fst canon info.ci_constr } in
make (Constructor info)
let rec nth_arg t n =
match t.term with
Appli (t1',t2')->
if n>0 then nth_arg t1' (n-1)
else t2'
| _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args.")
end
type ccpattern =
PApp of ATerm.t * ccpattern list
| PVar of int * ccpattern list
type axiom = constr
let constr_of_axiom c = c
type rule=
Congruence
| Axiom of axiom * bool
| Injection of int * pa_constructor * int * pa_constructor * int
type from=
Goal
| Hyp of constr
| HeqG of Id.t
| HeqnH of Id.t * Id.t
type 'a eq = {lhs:int;rhs:int;rule:'a}
type equality = rule eq
type disequality = from eq
type patt_kind =
Normal
| Trivial of types
| Creates_variables
type quant_eq =
{
qe_hyp_id: Id.t;
qe_pol: bool;
qe_nvars:int;
qe_lhs: ccpattern;
qe_lhs_valid:patt_kind;
qe_rhs: ccpattern;
qe_rhs_valid:patt_kind
}
let swap eq : equality =
let swap_rule=match eq.rule with
Congruence -> Congruence
| Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k)
| Axiom (id,reversed) -> Axiom (id,not reversed)
in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule}
type inductive_status =
Unknown
| Partial of pa_constructor
| Partial_applied
| Total of (int * pa_constructor)
type representative=
{mutable weight:int;
mutable lfathers:Int.Set.t;
mutable fathers:Int.Set.t;
mutable inductive_status: inductive_status;
class_type : types;
mutable functions: Int.Set.t PafMap.t}
type cl = Rep of representative| Eqto of int*equality
type vertex = Leaf| Node of (int*int)
type node =
{mutable clas:cl;
mutable cpath: int;
mutable constructors: int PacMap.t;
vertex:vertex;
aterm:ATerm.t}
module Constrhash = Hashtbl.Make
(struct type t = constr
let equal = eq_constr_nounivs
let hash = Constr.hash
end)
module Typehash = Constrhash
module Termhash = Hashtbl.Make
(struct type t = ATerm.t
let equal = ATerm.equal
let hash = ATerm.hash
end)
module Identhash = Hashtbl.Make
(struct type t = Id.t
let equal = Id.equal
let hash = Id.hash
end)
type forest=
{mutable max_size:int;
mutable size:int;
mutable map: node array;
axioms: (ATerm.t * ATerm.t) Constrhash.t;
mutable epsilons: pa_constructor list;
syms: int Termhash.t}
type state =
{uf: forest;
sigtable:ST.t;
mutable terms: Int.Set.t;
combine: equality Queue.t;
marks: (int * pa_mark) Queue.t;
mutable diseq: disequality list;
mutable quant: quant_eq list;
mutable pa_classes: Int.Set.t;
q_history: (int array) Identhash.t;
mutable rew_depth:int;
mutable changed:bool;
by_type: Int.Set.t Typehash.t;
mutable env:Environ.env;
sigma:Evd.evar_map}
let dummy_node =
{
clas=Eqto (min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
cpath=min_int;
constructors=PacMap.empty;
vertex=Leaf;
aterm= ATerm.mkSymb (mkRel min_int)
}
let empty_forest() =
{
max_size=init_size;
size=0;
map=Array.make init_size dummy_node;
epsilons=[];
axioms=Constrhash.create init_size;
syms=Termhash.create init_size
}
let empty env sigma depth : state =
{
uf= empty_forest ();
terms=Int.Set.empty;
combine=Queue.create ();
marks=Queue.create ();
sigtable=ST.empty ();
diseq=[];
quant=[];
pa_classes=Int.Set.empty;
q_history=Identhash.create init_size;
rew_depth=depth;
by_type=Constrhash.create init_size;
changed=false;
env;
sigma;
}
let forest state = state.uf
let compress_path uf i j = uf.map.(j).cpath<-i
let rec find_aux uf visited i=
let j = uf.map.(i).cpath in
if j<0 then let () = List.iter (compress_path uf i) visited in i else
find_aux uf (i::visited) j
let find uf i= find_aux uf [] i
let get_representative uf i=
match uf.map.(i).clas with
Rep r -> r
| _ -> anomaly ~label:"get_representative" (Pp.str "not a representative.")
let get_constructors uf i= uf.map.(i).constructors
let rec find_oldest_pac uf i pac=
try PacMap.find pac (get_constructors uf i) with
Not_found ->
match uf.map.(i).clas with
Eqto (j,_) -> find_oldest_pac uf j pac
| Rep _ -> raise Not_found
let get_constructor_info uf i=
match ATerm.proj uf.map.(i).aterm with
Constructor cinfo->cinfo
| _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor.")
let size uf i=
(get_representative uf i).weight
let axioms uf c = Constrhash.find uf.axioms c
let epsilons uf = uf.epsilons
let add_lfather uf i t=
let r=get_representative uf i in
r.weight<-r.weight+1;
r.lfathers<-Int.Set.add t r.lfathers;
r.fathers <-Int.Set.add t r.fathers
let add_rfather uf i t=
let r=get_representative uf i in
r.weight<-r.weight+1;
r.fathers <-Int.Set.add t r.fathers
exception Discriminable of int * pa_constructor * int * pa_constructor
let append_pac t p =
{p with arity=pred p.arity;args=t::p.args}
let tail_pac p=
{p with arity=succ p.arity;args=List.tl p.args}
let fsucc paf =
{paf with fnargs=succ paf.fnargs}
let add_pac node pac t =
if not (PacMap.mem pac node.constructors) then
node.constructors<-PacMap.add pac t node.constructors
let add_paf rep paf t =
let already =
try PafMap.find paf rep.functions with Not_found -> Int.Set.empty in
rep.functions<- PafMap.add paf (Int.Set.add t already) rep.functions
let aterm uf i=uf.map.(i).aterm
let subterms uf i=
match uf.map.(i).vertex with
Node(j,k) -> (j,k)
| _ -> anomaly ~label:"subterms" (Pp.str "not a node.")
let signature uf i=
let j,k=subterms uf i in (find uf j,find uf k)
let next uf=
let size=uf.size in
let nsize= succ size in
if Int.equal nsize uf.max_size then
let newmax=uf.max_size * 3 / 2 + 1 in
let newmap=Array.make newmax dummy_node in
begin
uf.max_size<-newmax;
Array.blit uf.map 0 newmap 0 size;
uf.map<-newmap
end
else ();
uf.size<-nsize;
size
let new_representative typ =
{weight=0;
lfathers=Int.Set.empty;
fathers=Int.Set.empty;
inductive_status=Unknown;
class_type=typ;
functions=PafMap.empty}
let rec canonize_name c =
let c = EConstr.Unsafe.to_constr c in
let func c = canonize_name (EConstr.of_constr c) in
match Constr.kind c with
| Const (kn,u) ->
let canon_const = Constant.make1 (Constant.canonical kn) in
(mkConstU (canon_const,u))
| Ind ((kn,i),u) ->
let canon_mind = MutInd.make1 (MutInd.canonical kn) in
(mkIndU ((canon_mind,i),u))
| Construct (((kn,i),j),u) ->
let canon_mind = MutInd.make1 (MutInd.canonical kn) in
mkConstructU (((canon_mind,i),j),u)
| Prod (na,t,ct) ->
mkProd (na,func t, func ct)
| Lambda (na,t,ct) ->
mkLambda (na, func t,func ct)
| LetIn (na,b,t,ct) ->
mkLetIn (na, func b,func t,func ct)
| App (ct,l) ->
mkApp (func ct,Array.Smart.map func l)
| Proj(p,r,c) ->
let p' = Projection.map (fun kn ->
MutInd.make1 (MutInd.canonical kn)) p in
(mkProj (p', r, func c))
| _ -> c
let build_subst uf subst =
Array.map
(fun i ->
try aterm uf i
with e when CErrors.noncritical e ->
anomaly (Pp.str "incomplete matching."))
subst
let rec inst_pattern subst = function
PVar (i, args) ->
List.fold_right
(fun spat f -> ATerm.mkAppli (f,inst_pattern subst spat))
args subst.(pred i)
| PApp (t', args) ->
List.fold_right
(fun spat f -> ATerm.mkAppli (f,inst_pattern subst spat))
args t'
let pr_idx_term env sigma uf i = str "[" ++ int i ++ str ":=" ++
Printer.pr_econstr_env env sigma (EConstr.of_constr (ATerm.constr (aterm uf i))) ++ str "]"
let pr_term env sigma t' = str "[" ++
Printer.pr_econstr_env env sigma (EConstr.of_constr (ATerm.constr t')) ++ str "]"
let rec add_aterm state t' =
let uf=state.uf in
try Termhash.find uf.syms t' with
Not_found ->
let b=next uf in
let trm = ATerm.constr t' in
let typ = Retyping.get_type_of state.env state.sigma (EConstr.of_constr trm) in
let typ = canonize_name typ in
let new_node=
match ATerm.proj t' with
Symb _ | Product (_,_) ->
let paf =
{fsym=b;
fnargs=0} in
Queue.add (b,Fmark paf) state.marks;
{clas= Rep (new_representative typ);
cpath= -1;
constructors=PacMap.empty;
vertex= Leaf;
aterm= t'}
| Eps id ->
{clas= Rep (new_representative typ);
cpath= -1;
constructors=PacMap.empty;
vertex= Leaf;
aterm= t'}
| Appli (t1',t2') ->
let i1=add_aterm state t1' and i2=add_aterm state t2' in
add_lfather uf (find uf i1) b;
add_rfather uf (find uf i2) b;
state.terms<-Int.Set.add b state.terms;
{clas= Rep (new_representative typ);
cpath= -1;
constructors=PacMap.empty;
vertex= Node(i1,i2);
aterm= t'}
| Constructor cinfo ->
let paf =
{fsym=b;
fnargs=0} in
Queue.add (b,Fmark paf) state.marks;
let pac =
{cnode= b;
arity= cinfo.ci_arity;
args=[]} in
Queue.add (b,Cmark pac) state.marks;
{clas=Rep (new_representative typ);
cpath= -1;
constructors=PacMap.empty;
vertex=Leaf;
aterm=t'}
in
uf.map.(b)<-new_node;
Termhash.add uf.syms t' b;
Typehash.replace state.by_type typ
(Int.Set.add b
(try Typehash.find state.by_type typ with
Not_found -> Int.Set.empty));
b
let add_equality0 state c s' t' =
let i = add_aterm state s' in
let j = add_aterm state t' in
Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine;
Constrhash.add state.uf.axioms c (s',t')
let add_equality state id s t =
add_equality0 state (mkVar id) s t
let add_disequality state from s' t' =
let i = add_aterm state s' in
let j = add_aterm state t' in
state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq
let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
state.quant<-
{qe_hyp_id= id;
qe_pol= pol;
qe_nvars=nvars;
qe_lhs= patt1;
qe_lhs_valid=valid1;
qe_rhs= patt2;
qe_rhs_valid=valid2}::state.quant
let is_redundant state id args =
try
let norm_args = Array.map (find state.uf) args in
let prev_args = Identhash.find_all state.q_history id in
List.exists
(fun old_args ->
Util.Array.for_all2 (fun i j -> Int.equal i (find state.uf j))
norm_args old_args)
prev_args
with Not_found -> false
let add_inst state (inst,int_subst) =
Control.check_for_interrupt ();
if state.rew_depth > 0 then
if is_redundant state inst.qe_hyp_id int_subst then
debug_congruence (fun () -> str "discarding redundant (dis)equality")
else
begin
Identhash.add state.q_history inst.qe_hyp_id int_subst;
let subst = build_subst (forest state) int_subst in
let prfhead= mkVar inst.qe_hyp_id in
let args = Array.map ATerm.constr subst in
let _ = Array.rev args in
let prf= mkApp(prfhead,args) in
let s = inst_pattern subst inst.qe_lhs
and t = inst_pattern subst inst.qe_rhs in
state.changed<-true;
state.rew_depth<-pred state.rew_depth;
if inst.qe_pol then
begin
debug_congruence (fun () ->
(str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++
(str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++
pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]"));
add_equality0 state prf s t
end
else
begin
debug_congruence (fun () ->
(str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++
(str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++
pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]"));
add_disequality state (Hyp prf) s t
end
end
let link uf i j eq =
let node=uf.map.(i) in
node.clas<-Eqto (j,eq);
node.cpath<-j
let rec down_path uf i l=
match uf.map.(i).clas with
Eqto (j,eq) ->down_path uf j (((i,j),eq)::l)
| Rep _ ->l
let eq_pair (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2
let rec min_path=function
([],l2)->([],l2)
| (l1,[])->(l1,[])
| (((c1,t1)::q1),((c2,t2)::q2)) when eq_pair c1 c2 -> min_path (q1,q2)
| cpl -> cpl
let join_path uf i j=
assert (Int.equal (find uf i) (find uf j));
min_path (down_path uf i [],down_path uf j [])
let union state i1 i2 eq=
debug_congruence (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++
str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str ".");
let r1= get_representative state.uf i1
and r2= get_representative state.uf i2 in
link state.uf i1 i2 eq;
Constrhash.replace state.by_type r1.class_type
(Int.Set.remove i1
(try Constrhash.find state.by_type r1.class_type with
Not_found -> Int.Set.empty));
let f= Int.Set.union r1.fathers r2.fathers in
r2.weight<-Int.Set.cardinal f;
r2.fathers<-f;
r2.lfathers<-Int.Set.union r1.lfathers r2.lfathers;
ST.delete_set state.sigtable r1.fathers;
state.terms<-Int.Set.union state.terms r1.fathers;
PacMap.iter
(fun pac b -> Queue.add (b,Cmark pac) state.marks)
state.uf.map.(i1).constructors;
PafMap.iter
(fun paf -> Int.Set.iter
(fun b -> Queue.add (b,Fmark paf) state.marks))
r1.functions;
match r1.inductive_status,r2.inductive_status with
Unknown,_ -> ()
| Partial pac,Unknown ->
r2.inductive_status<-Partial pac;
state.pa_classes<-Int.Set.remove i1 state.pa_classes;
state.pa_classes<-Int.Set.add i2 state.pa_classes
| Partial _ ,(Partial _ |Partial_applied) ->
state.pa_classes<-Int.Set.remove i1 state.pa_classes
| Partial_applied,Unknown ->
r2.inductive_status<-Partial_applied
| Partial_applied,Partial _ ->
state.pa_classes<-Int.Set.remove i2 state.pa_classes;
r2.inductive_status<-Partial_applied
| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks
| _,_ -> ()
let merge eq state =
debug_congruence
(fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++
str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str ".");
let uf=state.uf in
let i=find uf eq.lhs
and j=find uf eq.rhs in
if not (Int.equal i j) then
if (size uf i)<(size uf j) then
union state i j eq
else
union state j i (swap eq)
let update t state =
debug_congruence
(fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str ".");
let (i,j) as sign = signature state.uf t in
let (u,v) = subterms state.uf t in
let rep = get_representative state.uf i in
begin
match rep.inductive_status with
Partial _ ->
rep.inductive_status <- Partial_applied;
state.pa_classes <- Int.Set.remove i state.pa_classes
| _ -> ()
end;
PacMap.iter
(fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks)
(get_constructors state.uf i);
PafMap.iter
(fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks)
rep.functions;
try
let s = ST.query sign state.sigtable in
Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine
with
Not_found -> ST.enter t sign state.sigtable
let process_function_mark t rep paf state =
add_paf rep paf t;
state.terms<-Int.Set.union rep.lfathers state.terms
let process_constructor_mark t i rep pac state =
add_pac state.uf.map.(i) pac t;
match rep.inductive_status with
Total (s,opac) ->
if not (Int.equal pac.cnode opac.cnode) then
raise (Discriminable (s,opac,t,pac))
else
let cinfo = get_constructor_info state.uf pac.cnode in
let rec f n oargs args=
if n > 0 then
match (oargs,args) with
s1::q1,s2::q2->
Queue.add
{lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
state.combine;
f (n-1) q1 q2
| _-> anomaly ~label:"add_pacs"
(Pp.str "weird error in injection subterms merge.")
in f cinfo.ci_nhyps opac.args pac.args
| Partial_applied | Partial _ ->
state.terms<-Int.Set.union rep.lfathers state.terms
| Unknown ->
if Int.equal pac.arity 0 then
rep.inductive_status <- Total (t,pac)
else
begin
state.terms<-Int.Set.union rep.lfathers state.terms;
rep.inductive_status <- Partial pac;
state.pa_classes<- Int.Set.add i state.pa_classes
end
let process_mark t m state =
debug_congruence
(fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str ".");
let i=find state.uf t in
let rep=get_representative state.uf i in
match m with
Fmark paf -> process_function_mark t rep paf state
| Cmark pac -> process_constructor_mark t i rep pac state
type explanation =
Discrimination of (int*pa_constructor*int*pa_constructor)
| Contradiction of disequality
| Incomplete of (EConstr.t * int) list
let check_disequalities state =
let uf=state.uf in
let rec check_aux = function
| dis::q ->
let (info, ans) =
if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis)
else (str "No", check_aux q)
in
let _ = debug_congruence
(fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++
pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in
ans
| [] -> None
in
check_aux state.diseq
let one_step state =
try
let eq = Queue.take state.combine in
merge eq state;
true
with Queue.Empty ->
try
let (t,m) = Queue.take state.marks in
process_mark t m state;
true
with Queue.Empty ->
try
let t = Int.Set.choose state.terms in
state.terms<-Int.Set.remove t state.terms;
update t state;
true
with Not_found -> false
let __eps__ = Id.of_string "_eps_"
let new_state_var typ state =
let ids = Environ.ids_of_named_context_val (Environ.named_context_val state.env) in
let id = Namegen.next_ident_away __eps__ ids in
let r = EConstr.ERelevance.relevant in
state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot id r,typ)) state.env;
id
let complete_one_class state i=
match (get_representative state.uf i).inductive_status with
| Partial pac ->
let rec app t' typ n =
if n<=0 then t' else
let _,etyp,rest= destProd typ in
let id = new_state_var (EConstr.of_constr etyp) state in
app (ATerm.mkAppli (t',ATerm.mkEps id)) (substl [mkVar id] rest) (n-1) in
let c = Retyping.get_type_of state.env state.sigma
(EConstr.of_constr (ATerm.constr (aterm state.uf pac.cnode))) in
let c = EConstr.Unsafe.to_constr c in
let args =
List.map (fun i -> ATerm.constr (aterm state.uf i))
pac.args in
let typ = Term.prod_applist c (List.rev args) in
let ct = app (aterm state.uf i) typ pac.arity in
state.uf.epsilons <- pac :: state.uf.epsilons;
ignore (add_aterm state ct)
| _ -> anomaly (Pp.str "wrong incomplete class.")
let complete state =
Int.Set.iter (complete_one_class state) state.pa_classes
type matching_problem =
{mp_subst : int array;
mp_inst : quant_eq;
mp_stack : (ccpattern*int) list }
let make_fun_table state =
let uf= state.uf in
let funtab=ref PafMap.empty in
Array.iteri
(fun i inode -> if i < uf.size then
match inode.clas with
Rep rep ->
PafMap.iter
(fun paf _ ->
let elem =
try PafMap.find paf !funtab
with Not_found -> Int.Set.empty in
funtab:= PafMap.add paf (Int.Set.add i elem) !funtab)
rep.functions
| _ -> ()) state.uf.map;
!funtab
let do_match state res pb_stack =
let mp=Stack.pop pb_stack in
match mp.mp_stack with
[] ->
res:= (mp.mp_inst,mp.mp_subst) :: !res
| (patt,cl)::remains ->
let uf=state.uf in
match patt with
PVar (i, []) ->
if mp.mp_subst.(pred i)<0 then
begin
mp.mp_subst.(pred i)<- cl;
Stack.push {mp with mp_stack=remains} pb_stack
end
else
if Int.equal mp.mp_subst.(pred i) cl then
Stack.push {mp with mp_stack=remains} pb_stack
else ()
| PVar _ -> ()
| PApp (f,[]) ->
begin
try let j=Termhash.find uf.syms f in
if Int.equal (find uf j) cl then
Stack.push {mp with mp_stack=remains} pb_stack
with Not_found -> ()
end
| PApp(f, ((last_arg::rem_args) as args)) ->
try
let j=Termhash.find uf.syms f in
let paf={fsym=j;fnargs=List.length args} in
let rep=get_representative uf cl in
let good_terms = PafMap.find paf rep.functions in
let aux i =
let (s,t) = signature state.uf i in
Stack.push
{mp with
mp_subst=Array.copy mp.mp_subst;
mp_stack=
(PApp(f,rem_args),s) ::
(last_arg,t) :: remains} pb_stack in
Int.Set.iter aux good_terms
with Not_found -> ()
let paf_of_patt syms = function
PVar _ -> invalid_arg "paf_of_patt: pattern with variable head"
| PApp (f,args) ->
{fsym=Termhash.find syms f;
fnargs=List.length args}
let init_pb_stack state =
let syms= state.uf.syms in
let pb_stack = Stack.create () in
let funtab = make_fun_table state in
let aux inst =
begin
let good_classes =
match inst.qe_lhs_valid with
Creates_variables -> Int.Set.empty
| Normal ->
begin
try
let paf= paf_of_patt syms inst.qe_lhs in
PafMap.find paf funtab
with Not_found -> Int.Set.empty
end
| Trivial typ ->
begin
try
Typehash.find state.by_type typ
with Not_found -> Int.Set.empty
end in
Int.Set.iter (fun i ->
Stack.push
{mp_subst = Array.make inst.qe_nvars (-1);
mp_inst=inst;
mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
end;
begin
let good_classes =
match inst.qe_rhs_valid with
Creates_variables -> Int.Set.empty
| Normal ->
begin
try
let paf= paf_of_patt syms inst.qe_rhs in
PafMap.find paf funtab
with Not_found -> Int.Set.empty
end
| Trivial typ ->
begin
try
Typehash.find state.by_type typ
with Not_found -> Int.Set.empty
end in
Int.Set.iter (fun i ->
Stack.push
{mp_subst = Array.make inst.qe_nvars (-1);
mp_inst=inst;
mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
end in
List.iter aux state.quant;
pb_stack
let find_instances state =
let pb_stack= init_pb_stack state in
let res =ref [] in
let _ =
debug_congruence (fun () -> str "Running E-matching algorithm ... ");
try
while true do
Control.check_for_interrupt ();
do_match state res pb_stack
done;
anomaly (Pp.str "get out of here!")
with Stack.Empty -> () in
!res
let build_term_to_complete uf pac =
let open EConstr in
let cinfo = get_constructor_info uf pac.cnode in
let real_args = List.rev_map (fun i -> EConstr.of_constr (ATerm.constr (aterm uf i))) pac.args in
let (kn, u) = cinfo.ci_constr in
(applist (mkConstructU (kn, EInstance.make u), real_args), pac.arity)
let terms_to_complete state =
let uf = forest state in
List.map (build_term_to_complete uf) (epsilons uf)
let rec execute first_run state =
debug_congruence (fun () -> str "Executing ... ");
try
while
Control.check_for_interrupt ();
one_step state do ()
done;
match check_disequalities state with
None ->
if not(Int.Set.is_empty state.pa_classes) then
begin
debug_congruence (fun () -> str "First run was incomplete, completing ... ");
complete state;
execute false state
end
else
if state.rew_depth>0 then
let l=find_instances state in
List.iter (add_inst state) l;
if state.changed then
begin
state.changed <- false;
execute true state
end
else
begin
debug_congruence (fun () -> str "Out of instances ... ");
None
end
else
begin
debug_congruence (fun () -> str "Out of depth ... ");
None
end
| Some dis -> Some
begin
if first_run then Contradiction dis
else Incomplete (terms_to_complete state)
end
with Discriminable(s,spac,t,tpac) -> Some
begin
if first_run then Discrimination (s,spac,t,tpac)
else Incomplete (terms_to_complete state)
end