forked from CakeML/cakeml
-
Notifications
You must be signed in to change notification settings - Fork 0
/
unifyScript.sml
3187 lines (2878 loc) · 104 KB
/
unifyScript.sml
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
(*
Defines a unification algorithm for use in the type inferencer.
Based on the triangular unification algorithm in
HOL/examples/unification/triangular/first-order. We encode our
CakeML types into the term structure used there and them bring over
those definitions and theorems.
*)
open preamble;
open unifPropsTheory unifDefTheory walkTheory walkstarTheory collapseTheory;
open substTheory;
open infer_tTheory;
open rmfmapTheory tcallUnifTheory
open transferTheory transferLib
open cpsTheory cpsLib
val _ = patternMatchesLib.ENABLE_PMATCH_CASES();
val _ = new_theory "unify";
val _ = monadsyntax.temp_enable_monadsyntax()
val _ = monadsyntax.temp_enable_monad "option"
val option_map_case = optionTheory.OPTION_MAP_CASE
val option_bind_thm = oneline optionTheory.OPTION_BIND_def
Theorem I_o_f[local,simp]: !m. I o_f m = m
Proof rw [GSYM fmap_EQ_THM]
QED
Datatype:
atom
= TC_tag type_ident
| DB_tag num
| Tapp_tag
| Null_tag
End
Definition encode_infer_t_def:
(encode_infer_t (Infer_Tvar_db n) =
Const (DB_tag n)) ∧
(encode_infer_t (Infer_Tapp ts tc) =
Pair (Const Tapp_tag) (Pair (Const (TC_tag tc)) (encode_infer_ts ts))) ∧
(encode_infer_t (Infer_Tuvar n) =
Var n) ∧
(encode_infer_ts [] =
Const Null_tag) ∧
(encode_infer_ts (t::ts) =
Pair (encode_infer_t t) (encode_infer_ts ts))
End
Theorem encode_infer_t_11[simp]:
(∀it1 it2. encode_infer_t it1 = encode_infer_t it2 ⇔ it1 = it2) ∧
(∀its1 its2. encode_infer_ts its1 = encode_infer_ts its2 ⇔ its1 = its2)
Proof
ho_match_mp_tac (TypeBase.induction_of “:infer_t”) >>
rw[encode_infer_t_def]
>- (Cases_on ‘it2’ >> simp[encode_infer_t_def])
>- (Cases_on ‘it2’ >> simp[encode_infer_t_def] >> metis_tac[])
>- (Cases_on ‘it2’ >> simp[encode_infer_t_def]) >>
Cases_on ‘its2’ >> simp[encode_infer_t_def]
QED
Definition decode_infer_t_def:
(decode_infer_t (Var n) =
Infer_Tuvar n) ∧
(decode_infer_t (Const (DB_tag n)) =
Infer_Tvar_db n) ∧
(decode_infer_t (Pair (Const Tapp_tag) (Pair (Const (TC_tag tc)) s)) =
Infer_Tapp (decode_infer_ts s) tc) ∧
(decode_infer_t _ = Infer_Tuvar 5) ∧
(decode_infer_ts (Const Null_tag) =
[]) ∧
(decode_infer_ts (Pair s1 s2) =
decode_infer_t s1 :: decode_infer_ts s2) ∧
(decode_infer_ts _ = [])
End
Theorem decode_left_inverse[simp]:
(!t. decode_infer_t (encode_infer_t t) = t) ∧
(!ts. decode_infer_ts (encode_infer_ts ts) = ts)
Proof
Induct >>
rw [encode_infer_t_def, decode_infer_t_def]
QED
Theorem decode_left_inverse_I[simp]:
decode_infer_t o encode_infer_t = I
Proof
rw [FUN_EQ_THM]
QED
Theorem encode_eq_var[simp]:
(Var n = encode_infer_t i ⇔ i = Infer_Tuvar n) ∧
(encode_infer_t i = Var n ⇔ i = Infer_Tuvar n)
Proof
rw[EQ_IMP_THM, encode_infer_t_def] >>
pop_assum (mp_tac o Q.AP_TERM ‘decode_infer_t’) >>
simp[decode_infer_t_def]
QED
Theorem decode_right_inverse[local]:
(!t. (?t'. t = encode_infer_t t') ⇒ (encode_infer_t (decode_infer_t t) = t)) ∧
(!ts. (?ts'. ts = encode_infer_ts ts') ⇒ (encode_infer_ts (decode_infer_ts ts) = ts))
Proof
Induct >>
rw [encode_infer_t_def, decode_infer_t_def] >>
rw []
QED
Theorem option_CASE_MAP:
option_CASE (OPTION_MAP f v) n sf =
option_CASE v n (sf o f)
Proof
Cases_on ‘v’ >> simp[]
QED
Theorem list_CASE_MAP:
list_CASE (MAP f l) n cf =
list_CASE l n (λh t. cf (f h) (MAP f t))
Proof
Cases_on ‘l’ >> simp[]
QED
Theorem decode_option_CASE[local]:
decode_infer_t (option_CASE v n sf) =
option_CASE v (decode_infer_t n) (decode_infer_t o sf)
Proof
Cases_on ‘v’ >> simp[]
QED
Theorem decode_infer_t_CASE[local]:
decode_infer_t (infer_t_CASE it dbf appf uvf) =
infer_t_CASE it (decode_infer_t o dbf)
(λl n. decode_infer_t (appf l n))
(decode_infer_t o uvf)
Proof
Cases_on ‘it’ >> simp[]
QED
(* "Ramana Kumar unification type to CakeML type" relation *)
Definition RKC_def:
RKC rkt ct ⇔ encode_infer_t ct = rkt
End
Theorem surj_RKC[transfer_simp]:
surj RKC
Proof
simp[transferTheory.surj_def, RKC_def]
QED
Definition substR_def:
substR fm sp ⇔ wfs fm ∧ wf sp /\ fm = encode_infer_t o_f sp2fm sp
End
Theorem substR_FDOM[transfer_rule]:
(substR |==> (=)) FDOM domain
Proof
simp[FUN_REL_def, substR_def]
QED
Theorem substR_FLOOKUP[transfer_rule]:
(substR |==> (=) |==> OPTREL RKC) FLOOKUP (flip lookup)
Proof
simp[FUN_REL_def, substR_def, FLOOKUP_o_f] >> rpt strip_tac >>
rename [‘lookup n sp’]>> Cases_on ‘lookup n sp’ >> simp[RKC_def]
QED
Definition cwfs_def:
cwfs s <=> swfs (map encode_infer_t s) /\ wf s
End
Theorem sp2fm_map:
sp2fm (map f sp) = f o_f sp2fm sp
Proof
simp[finite_mapTheory.FLOOKUP_EXT, fmspTheory.FLOOKUP_sp2fm, FUN_EQ_THM,
lookup_map, finite_mapTheory.FLOOKUP_o_f] >>
simp[optionTheory.OPTION_MAP_CASE, combinTheory.o_DEF]
QED
Theorem substR_RFORALL[transfer_rule]:
((substR |==> (==>)) |==> (==>)) (RES_FORALL wfs) (RES_FORALL cwfs)
Proof
simp[FUN_REL_def, RES_FORALL_THM, IN_DEF, substR_def] >> rpt strip_tac >>
gvs[cwfs_def, swfs_def, sp2fm_map]
QED
(*
Theorem RKC_FORALL[transfer_rule]:
((RKC |==> (==>)) |==> (==>)) $! $!
Proof
irule transferTheory.ALL_surj_imp_imp >> simp[surj_RKC]
QED
*)
Theorem wfs_rule[transfer_rule]:
(substR |==> (=)) wfs cwfs
Proof
simp[cwfs_def, FUN_REL_def, swfs_def, RKC_def, fmspTheory.FMSP_def,
substR_def, sp2fm_map]
QED
Theorem svwalk_result_encodable:
wf fm /\ swfs (map f fm) ∧ (∀n. ∃y. Var n = f y) ⇒
∀x. ∃y. svwalk (map f fm) x = f y
Proof
strip_tac >> ‘wfs (sp2fm (map f fm))’ by gvs[swfs_def] >>
drule (DISCH_ALL walkTheory.vwalk_ind) >>
simp[RIGHT_FORALL_IMP_THM] >> disch_then ho_match_mp_tac >> rw[] >>
simp[Once svwalk_thm] >> rename [‘lookup k (map f fm)’] >>
Cases_on ‘lookup k (map f fm)’ >> simp[] >>
gvs[AllCaseEqs(), lookup_map] >> rename [‘f v = Pair _ _’] >>
Cases_on ‘f v’ >> simp[] >> metis_tac[]
QED
Definition cvwalk_def:
cvwalk s n = decode_infer_t (svwalk (map encode_infer_t s) n)
End
Theorem cvwalk_rule[transfer_rule]:
(substR |==> (=) |==> RKC) vwalk cvwalk
Proof
simp[cvwalk_def, FUN_REL_def, RKC_def, substR_def] >>
rpt strip_tac >> rename [‘svwalk (map encode_infer_t sp) n’] >>
‘∃it. svwalk (map encode_infer_t sp) n = encode_infer_t it’
by (irule svwalk_result_encodable >> simp[swfs_def, sp2fm_map] >>
metis_tac[encode_infer_t_def]) >>
simp[] >> gvs[svwalk_def, sp2fm_map]
QED
Theorem term_CASE_encode:
term_CASE (encode_infer_t v) vf pf cf =
infer_t_CASE v
(cf o DB_tag)
(λl n. pf (Const Tapp_tag)
(Pair (Const (TC_tag n)) (encode_infer_ts l)))
vf
Proof
Cases_on ‘v’ >> simp[encode_infer_t_def]
QED
Theorem cvwalk_thm =
cvwalk_def |> SPEC_ALL
|> SRULE[lookup_map, option_CASE_MAP, combinTheory.o_ABS_L,
term_CASE_encode, Once svwalk_thm,
ASSUME “wf (map encode_infer_t s)”,
ASSUME “swfs (map encode_infer_t s)”]
|> SRULE[GSYM encode_infer_t_def, GSYM cvwalk_def,
decode_option_CASE, decode_infer_t_CASE,
combinTheory.o_ABS_R]
Definition cwalk_def[nocompute]:
cwalk s it = decode_infer_t $ swalk (map encode_infer_t s) (encode_infer_t it)
End
Theorem swalk_result_encodable:
!s it. cwfs s ==>
?it'. swalk (map encode_infer_t s) (encode_infer_t it) =
encode_infer_t it'
Proof
simp[cwfs_def, swalk_thm, term_CASE_encode,
AllCaseEqs()] >> rpt strip_tac >>
Cases_on ‘it’ >> simp[]
>- metis_tac[encode_infer_t_def]
>- metis_tac[encode_infer_t_def] >>
rename [‘svwalk _ n’] >> qid_spec_tac ‘n’ >>
irule svwalk_result_encodable >> simp[] >> metis_tac[encode_infer_t_def]
QED
Theorem swalk_elim:
cwfs s ==>
swalk (map encode_infer_t s) (encode_infer_t it) =
encode_infer_t (cwalk s it)
Proof
strip_tac >> simp[cwalk_def] >> ONCE_REWRITE_TAC [EQ_SYM_EQ] >>
irule (cj 1 decode_right_inverse) >> metis_tac[swalk_result_encodable]
QED
Theorem substR_walk[transfer_rule]:
(substR |==> RKC |==> RKC) walk cwalk
Proof
simp[cwalk_def, FUN_REL_def, substR_def] >> rpt strip_tac >>
rename [‘swalk (map encode_infer_t sp) (encode_infer_t it)’] >>
‘?it'. swalk (map encode_infer_t sp) (encode_infer_t it) = encode_infer_t it'’
by (irule swalk_result_encodable >> simp[cwfs_def, swfs_def, sp2fm_map]) >>
gs[RKC_def, swalk_def, sp2fm_map]
QED
val cwf = ASSUME “cwfs s” |> SRULE[cwfs_def] |> cj 2
val cwfs = ASSUME “cwfs s” |> SRULE[cwfs_def] |> cj 1
Theorem cwalk_thm =
cwalk_def |> SPEC_ALL
|> SRULE [swalk_thm, term_CASE_encode,
decode_infer_t_CASE, combinTheory.o_ABS_L,
combinTheory.o_ABS_R, cwf]
|> SRULE[decode_infer_t_def, GSYM cvwalk_def]
Definition coc_def[nocompute]:
coc s it n = soc (map encode_infer_t s) (encode_infer_t it) n
End
Theorem soc_encode_ts:
cwfs s ==>
(soc (map encode_infer_t s) (encode_infer_ts its) n ⇔
EXISTS (λi. soc (map encode_infer_t s) (encode_infer_t i) n) its)
Proof
strip_tac >> map_every assume_tac [cwf, cwfs] >>
Induct_on ‘its’ >>
simp[encode_infer_t_def, soc_thm]
QED
Theorem substR_oc[transfer_rule]:
(substR |==> RKC |==> (=) |==> (=)) oc coc
Proof
simp[FUN_REL_def, RKC_def, substR_def, coc_def, soc_def, sp2fm_map]
QED
Theorem coc_thm =
coc_def |> SPEC_ALL
|> SRULE[Once soc_walking, cwf, cwfs,
UNDISCH swalk_elim, term_CASE_encode,
combinTheory.o_DEF]
|> SRULE[soc_thm, cwf, UNDISCH soc_encode_ts]
|> SRULE[GSYM coc_def]
Definition t_vars_def: t_vars t = vars (encode_infer_t t)
End
Definition cunify_def:
cunify s t1 t2 = OPTION_MAP (map decode_infer_t)
(sunify (map encode_infer_t s) (encode_infer_t t1)
(encode_infer_t t2))
End
Theorem fm2sp_delete:
fm2sp (fm \\ k) = delete k $ fm2sp fm
Proof
simp[spt_eq_thm, wf_delete, lookup_delete, DOMSUB_FLOOKUP_THM] >>
metis_tac[]
QED
Theorem domain_fm2sp:
∀fm. domain (fm2sp fm) = FDOM fm
Proof
Induct >> simp[fm2sp_delete, DELETE_NON_ELEMENT_RWT]
QED
Theorem swalk_encode_infer_ts_EQ_VAR:
swfs s ∧ wf s ⇒ swalk s (encode_infer_ts ts) ≠ Var v
Proof
Cases_on ‘ts’ >> simp[swalk_thm, encode_infer_t_def]
QED
Theorem encode_t_vs_ts:
encode_infer_t x ≠ encode_infer_ts l
Proof
Cases_on ‘x’ >> Cases_on ‘l’ >> simp[encode_infer_t_def] >>
Cases_on ‘h’ >> simp[encode_infer_t_def]
QED
Theorem swalk_encode_infer_ts:
wf s ⇒ swalk s (encode_infer_ts ts) = encode_infer_ts ts
Proof
Cases_on ‘ts’ >> simp[encode_infer_t_def, swalk_thm]
QED
Theorem sunify_wf:
∀s t1 t2 s'. swfs s ∧ wf s ∧ sunify s t1 t2 = SOME s' ⇒ wf s'
Proof
‘∀f t1 t2 s'. wfs f ∧ sunify (fm2sp f) t1 t2 = SOME s' ⇒ wf s'’
suffices_by (rpt strip_tac >>
first_x_assum $ qspec_then ‘sp2fm s’ mp_tac >>
simp[] >> gvs[swfs_def] >> metis_tac[]) >>
recInduct unify_ind >> rpt gen_tac >> strip_tac >>
simp[Once sunify_thm, swfs_def, SF CONJ_ss]>>
simp[AllCaseEqs()] >> rw[] >> simp[wf_insert] >>
gvs[swalk_def] >> gvs[sunify_def]
QED
Theorem sunify_constconst:
wf s ∧ swfs s ⇒
sunify s (Const c1) (Const c2) = if c1 = c2 then SOME s else NONE
Proof
simp[Once sunify_thm, swalk_thm]
QED
Theorem sunify_pairconstconst:
wf s ∧ swfs s ⇒
sunify s (Pair (Const c1) t1) (Pair (Const c2) t2) =
if c1 = c2 then sunify s t1 t2 else NONE
Proof
simp[Once sunify_thm, swalk_thm, sunify_constconst] >> rw[]
QED
Theorem sunify_result_encodable:
∀st1t2 s pt1 pt2 s'.
st1t2 = (s,pt1,pt2) ∧ swfs (map encode_infer_t s) ∧ wf s ∧
((∃t1 t2. pt1 = encode_infer_t t1 ∧ pt2 = encode_infer_t t2) ∨
(∃ts1 ts2. pt1 = encode_infer_ts ts1 ∧ pt2 = encode_infer_ts ts2)) ∧
sunify (map encode_infer_t s) pt1 pt2 = SOME s' ⇒
∃m. s' = map encode_infer_t m
Proof
‘WF (inv_image uR (λ(s,t1,t2). (sp2fm (map encode_infer_t s), t1, t2)))’
by (irule WF_inv_image >> simp[unifDefTheory.WF_uR]) >>
dxrule WF_INDUCTION_THM >> strip_tac >>
RULE_ASSUM_TAC (SRULE[RIGHT_FORALL_IMP_THM])>>
pop_assum ho_match_mp_tac >> simp[FORALL_PROD] >> rw[] >>
rename [‘sunify (map encode_infer_t σ) _ _’] >>
pop_assum mp_tac >> simp[Once sunify_thm] >>
simp[AllCaseEqs()] >> rw[] >> gvs[swalk_encode_infer_ts_EQ_VAR] >>~-
([‘swalk _ (encode_infer_t _) = Var _’,
‘insert _ _ _ = map encode_infer_t _’],
qmatch_abbrev_tac ‘∃m. insert k M _ = _ m’ >>
‘∃M0. M = encode_infer_t M0’
by (qpat_x_assum ‘swalk _ _ = M’ (SUBST1_TAC o SYM) >>
irule swalk_result_encodable >> simp[cwfs_def, swfs_def]) >>
pop_assum SUBST1_TAC >>
irule_at Any (GSYM map_insert)) >>~-
([‘map encode_infer_t σ = map encode_infer_t _’],
irule_at Any EQ_REFL) >~
[‘swalk (map encode_infer_t σ) (encode_infer_t t1) = Pair _ _’,
‘(_, encode_infer_t t1, encode_infer_t t2)’]
>- (‘∃it1. swalk (map encode_infer_t σ) (encode_infer_t t1) =
encode_infer_t it1’
by (irule swalk_result_encodable >> simp[cwfs_def]) >>
‘∃it2. swalk (map encode_infer_t σ) (encode_infer_t t2) =
encode_infer_t it2’
by (irule swalk_result_encodable >> simp[cwfs_def]) >>
gvs[] >>
Cases_on ‘it1’ >> gvs[encode_infer_t_def] >>
Cases_on ‘it2’ >> gvs[encode_infer_t_def] >>
gvs[sunify_constconst, sunify_pairconstconst] >>
first_x_assum irule >> first_assum $ irule_at (Pat ‘sunify _ _ _ = _’) >>
simp[encode_t_vs_ts, PULL_EXISTS] >>
rpt (irule_at Any EQ_REFL) >>
simp[uR_def] >> gvs[swalk_def, swfs_def] >>
qabbrev_tac ‘θ = sp2fm (map encode_infer_t σ)’ >>
conj_tac
>- (dxrule_all allvars_SUBSET >> simp[allvars_def] >>
SET_TAC[]) >>
drule_then (rpt o dxrule) walkstar_subterm_smaller >>
simp[]) >>
gvs[swalk_encode_infer_ts] >>
Cases_on ‘ts1’ >> gvs[encode_infer_t_def] >>
Cases_on ‘ts2’ >> gvs[encode_infer_t_def] >>
rename [‘sunify _ (encode_infer_t t1) (encode_infer_t t2)’] >>
first_assum (qpat_assum ‘sunify _ (encode_infer_t t1) _ = SOME _’ o
mp_then Any mp_tac) >>
impl_tac
>- (simp[encode_t_vs_ts, PULL_EXISTS] >>
rpt (irule_at Any EQ_REFL) >>
simp[uR_def] >> gvs[swfs_def] >>
simp[allvars_def] >> SET_TAC []) >>
disch_then $ qx_choose_then ‘σ'’ strip_assume_tac >> gvs[] >>
first_x_assum irule >> first_assum $ irule_at Any >>
simp[encode_t_vs_ts, PULL_EXISTS] >> rpt $ irule_at Any EQ_REFL >>
gvs[swfs_def, sunify_def] >>
drule_all_then strip_assume_tac unify_unifier >> simp[] >>
‘wf (map encode_infer_t σ')’ by (ASM_REWRITE_TAC[] >> simp[]) >> gvs[] >>
simp[uR_def] >> simp[allvars_def] >> rw[]
>- SET_TAC[]
>- SET_TAC[]
>- (qpat_assum ‘unify _ (encode_infer_t t1) _ = SOME _’
(mp_then Any mp_tac unify_uP) >> simp[] >>
simp[uP_def, allvars_def] >> SET_TAC[])
QED
Theorem map_decode_encode:
cwfs s ==> map decode_infer_t (map encode_infer_t s) = s
Proof
strip_tac >> gvs[cwfs_def] >> simp[spt_eq_thm, lookup_map]>>
simp[OPTION_MAP_COMPOSE, combinTheory.o_DEF]
QED
Theorem sunify_t_elim:
cwfs s ⇒
sunify (map encode_infer_t s) (encode_infer_t t1) (encode_infer_t t2) =
OPTION_MAP (map encode_infer_t) (cunify s t1 t2)
Proof
strip_tac >> simp[cunify_def, OPTION_MAP_COMPOSE] >>
Cases_on ‘sunify (map encode_infer_t s) (encode_infer_t t1)
(encode_infer_t t2)’ >> simp[] >>
drule_at Any sunify_result_encodable>> simp[encode_t_vs_ts] >> impl_tac
>- gvs[cwfs_def, swfs_def, sp2fm_map] >>
simp[PULL_EXISTS, map_map_o]
QED
Theorem option_map_itcase:
OPTION_MAP f (infer_t_CASE arg x y z) =
infer_t_CASE arg (OPTION_MAP f o x) (λl n. OPTION_MAP f (y l n))
(OPTION_MAP f o z)
Proof
Cases_on ‘arg’ >> simp[]
QED
Theorem option_map_COND:
OPTION_MAP f (COND g t e) = COND g (OPTION_MAP f t) (OPTION_MAP f e)
Proof
rw[]
QED
Theorem sptree_map_COND:
sptree$map f (COND g t e) = COND g (map f t) (map f e)
Proof
rw[]
QED
Theorem SOME_COND:
SOME (COND g t e) = COND g (SOME t) (SOME e)
Proof
rw[]
QED
Theorem OPTION_MAP_BIND:
OPTION_MAP f (OPTION_BIND m mf) =
OPTION_BIND m (OPTION_MAP f o mf)
Proof
Cases_on ‘m’ >> simp[]
QED
Theorem OPTION_BIND_MAP:
OPTION_BIND (OPTION_MAP f m) mf =
OPTION_BIND m (mf o f)
Proof
Cases_on ‘m’ >> simp[]
QED
Definition cunifyl_def:
cunifyl s ts1 ts2 =
OPTION_MAP (map decode_infer_t)
(sunify (map encode_infer_t s)
(encode_infer_ts ts1)
(encode_infer_ts ts2))
End
Theorem sunify_preserves_swfs:
swfs s ∧ sunify s t1 t2 = SOME s' ⇒ swfs s'
Proof
simp[swfs_def, sunify_def, PULL_EXISTS] >>
metis_tac[unifPropsTheory.unify_unifier]
QED
Theorem substR_unify:
(substR |==> RKC |==> RKC |==> OPTREL substR) unify cunify
Proof
simp[FUN_REL_def, RKC_def, cunify_def,
optionTheory.OPTION_MAP_COMPOSE, sp2fm_map, substR_def] >>
rpt strip_tac >> qmatch_abbrev_tac ‘OPTREL substR X _’ >>
Cases_on ‘X’ >> simp[] >> gs[substR_def, sp2fm_map]
>- simp[sunify_def, sp2fm_map] >>
rename [‘unify _ _ _ = SOME result’] >>
‘wfs result’ by metis_tac[unifPropsTheory.unify_unifier] >>
rename [‘sunify (map encode_infer_t sp) (encode_infer_t t1)
(encode_infer_t t2)’] >>
‘?sresult. sunify (map encode_infer_t sp) (encode_infer_t t1)
(encode_infer_t t2) = SOME sresult’
by simp[sunify_def, sp2fm_map] >>
‘wf sresult’
by (irule sunify_wf >> first_assum $ irule_at (Pat ‘sunify _ _ _ = _’) >>
simp[swfs_def, sp2fm_map]) >>
drule_at (Pos last) sunify_result_encodable >>
simp[swfs_def, sp2fm_map, PULL_EXISTS] >> rw[] >>
gvs[sunify_def, sp2fm_map] >>
simp[substR_def, sp2fm_map] >>
first_x_assum (mp_tac o Q.AP_TERM ‘sp2fm’) >>
simp[sp2fm_map]
QED
Definition capply_subst_def[nocompute]:
(capply_subst s (Infer_Tuvar n) = dtcase lookup n s of
NONE => Infer_Tuvar n
| SOME it => it) ∧
(capply_subst s (Infer_Tapp ts tc) = Infer_Tapp (MAP(capply_subst s) ts) tc) ∧
(capply_subst s (Infer_Tvar_db n) = Infer_Tvar_db n)
Termination
WF_REL_TAC ‘measure (infer_t_size o SND)’
End
Theorem capply_subst_thm[simp,compute] = SRULE [SF ETA_ss] capply_subst_def
Theorem cunify_thm =
cunify_def |> SPEC_ALL
|> SRULE [Once sunify_thm, cwf, cwfs,
UNDISCH swalk_elim, term_CASE_encode,
combinTheory.o_DEF]
|> SRULE[soc_thm, cwf, cwfs, GSYM coc_def,
option_map_itcase, combinTheory.o_ABS_R,
UNDISCH map_decode_encode,
option_map_COND, map_insert, sptree_map_COND,
UNDISCH soc_encode_ts, decode_infer_t_def,
sunify_constconst, sunify_pairconstconst, SOME_COND,
GSYM cunifyl_def]
Theorem cunifyl_NIL2 =
cunifyl_def |> SPEC_ALL
|> Q.INST [‘ts1’ |-> ‘[]’, ‘ts2’ |-> ‘[]’]
|> SRULE [Once sunify_thm, cwf, cwfs,
encode_infer_t_def, swalk_thm,
UNDISCH swalk_elim, term_CASE_encode,
UNDISCH map_decode_encode,
combinTheory.o_DEF]
Theorem cunifyl_NILCONS =
cunifyl_def |> SPEC_ALL
|> Q.INST [‘ts1’ |-> ‘[]’, ‘ts2’ |-> ‘t2::ts2’]
|> SRULE [Once sunify_thm, cwf, cwfs,
encode_infer_t_def, swalk_thm,
UNDISCH swalk_elim, term_CASE_encode,
UNDISCH map_decode_encode,
combinTheory.o_DEF]
Theorem cunifyl_CONSNIL =
cunifyl_def |> SPEC_ALL
|> Q.INST [‘ts1’ |-> ‘t1::ts1’, ‘ts2’ |-> ‘[]’]
|> SRULE [Once sunify_thm, cwf, cwfs,
encode_infer_t_def, swalk_thm,
UNDISCH swalk_elim, term_CASE_encode,
UNDISCH map_decode_encode,
combinTheory.o_DEF]
Theorem cunifyl_CONS2 =
cunifyl_def |> SPEC_ALL
|> Q.INST [‘ts1’ |-> ‘t1::ts1’, ‘ts2’ |-> ‘t2::ts2’]
|> SRULE [Once sunify_thm, cwf, cwfs,
encode_infer_t_def, swalk_thm,
OPTION_MAP_BIND, combinTheory.o_DEF,
encode_infer_t_def, swalk_thm,
UNDISCH swalk_elim, term_CASE_encode,
UNDISCH map_decode_encode,
UNDISCH sunify_t_elim, OPTION_BIND_MAP,
combinTheory.o_DEF]
|> SRULE[GSYM cunifyl_def]
Theorem cunify_preserves_cwfs:
cwfs s0 ∧ cunify s0 t1 t2 = SOME s ⇒ cwfs s
Proof
simp[cunify_def, cwfs_def, PULL_EXISTS] >> gen_tac >>
rpt (disch_then strip_assume_tac) >> reverse conj_asm2_tac
>- (drule_at (Pos last) sunify_wf >> simp[]) >>
drule_all sunify_preserves_swfs >> strip_tac >>
drule_at (Pos last) sunify_result_encodable >> simp[encode_t_vs_ts] >>
rw[] >> simp[map_map_o]
QED
Theorem cunifyl_thm:
cwfs s ⇒
cunifyl s ts1 ts2 =
dtcase (ts1,ts2) of
([],[]) => SOME s
| (t1::ts1, t2::ts2) => do s' <- cunify s t1 t2; cunifyl s' ts1 ts2 od
| _ => NONE
Proof
Cases_on ‘ts1’ >> Cases_on ‘ts2’ >>
simp[cunifyl_NILCONS, cunifyl_NIL2, cunifyl_CONS2, cunifyl_CONSNIL]
QED
Definition cwalkstar_def:
cwalkstar s it =
decode_infer_t (walkstar (encode_infer_t o_f sp2fm s) (encode_infer_t it))
End
Theorem walkstar1[local] =
UNDISCH walkstar_thm |> oneline
|> INST_TYPE [alpha |-> “:atom”]
|> Q.INST [‘s’ |-> ‘encode_infer_t o_f sp2fm ss’]
|> Q.INST [‘ss’ |-> ‘s’]
Theorem walkstar2[local] =
UNDISCH walkstar_thm |> INST_TYPE [alpha |-> “:atom”]
|> Q.INST [‘s’ |-> ‘encode_infer_t o_f sp2fm ss’]
|> Q.INST [‘ss’ |-> ‘s’]
Theorem cvwalk_rwt:
wf s ⇒ wfs (encode_infer_t o_f sp2fm s) ⇒
vwalk (encode_infer_t o_f sp2fm s) v =
encode_infer_t (cvwalk s v)
Proof
simp[cvwalk_def] >> rpt strip_tac >>
‘∃y. svwalk (map encode_infer_t s) v = encode_infer_t y’
by (irule svwalk_result_encodable >>
simp[encode_eq_var, swfs_def, sp2fm_map]) >>
simp[decode_left_inverse_I] >> gvs[svwalk_def, sp2fm_map]
QED
Theorem decode_infer_ts_walkstar:
wfs (encode_infer_t o_f sp2fm s) ⇒
decode_infer_ts (walkstar (encode_infer_t o_f sp2fm s) (encode_infer_ts l)) =
MAP (cwalkstar s) l
Proof
strip_tac >> Induct_on ‘l’ >> simp[encode_infer_t_def, walkstar2] >>
simp[decode_infer_t_def] >>
simp[cwalkstar_def, sp2fm_map]
QED
Theorem cwalkstar_thm =
cwalkstar_def |> SPEC_ALL
|> SRULE [term_CASE_encode,
decode_infer_t_CASE, combinTheory.o_ABS_L,
combinTheory.o_ABS_R, cwf, decode_infer_t_def,
Once $ walkstar1, walkstar2]
|> SRULE [UNDISCH_ALL cvwalk_rwt,
term_CASE_encode, decode_infer_t_CASE,
combinTheory.o_DEF, decode_infer_t_def,
walkstar2, UNDISCH_ALL decode_infer_ts_walkstar]
|> PROVE_HYP cwf
|> PROVE_HYP (SRULE [swfs_def, sp2fm_map] cwfs)
|> DISCH_ALL
Theorem walkstar_def'[local] =
MATCH_MP
(GEN_ALL walkstar_def)
(ASSUME “wfs (sp2fm (map encode_infer_t s) : atom subst$subst)”)
Theorem walkstar_thm'[local] =
MATCH_MP
(GEN_ALL walkstar_thm)
(ASSUME “wfs (sp2fm (map encode_infer_t s) : atom subst$subst)”)
Theorem infer_t_CASE_RAND:
f (infer_t_CASE it tvf taf tuf) =
infer_t_CASE it (f o tvf) (λl n. f (taf l n)) (f o tuf)
Proof
Cases_on ‘it’ >> simp[]
QED
Theorem cunify_unifier:
cwfs s ∧ cunify s t1 t2 = SOME sx ⇒
cwfs sx ∧ subspt s sx ∧ cwalkstar sx t1 = cwalkstar sx t2
Proof
simp[cwfs_def, cwalkstar_def, cunify_def, unify_unifier,
PULL_EXISTS, wf_map, sp2fm_map] >> rpt strip_tac >>
gvs[]>> drule_at (Pos last) sunify_result_encodable >>
simp[encode_t_vs_ts] >> rw[] >>
drule_all_then strip_assume_tac sunify_preserves_swfs >>
drule_at (Pos last) sunify_wf >> simp[] >> strip_tac >>
simp[SRULE [cwfs_def] map_decode_encode] >>
gvs[sunify_def, swfs_def] >>
drule_all unify_unifier
>- (simp[SUBMAP_FLOOKUP_EQN, FLOOKUP_o_f, AllCaseEqs(), PULL_EXISTS,
subspt_lookup, lookup_map] >> rpt strip_tac >> first_assum drule >>
‘cwfs m’ by simp[cwfs_def, swfs_def] >>
first_x_assum (mp_tac o Q.AP_TERM ‘map decode_infer_t’) >>
simp[map_decode_encode, lookup_map] >> disch_then SUBST_ALL_TAC >>
first_x_assum drule >> simp[]) >>
rpt strip_tac >>
rename [‘walkstar ((encode_infer_t o decode_infer_t) o_f z)’] >>
‘(encode_infer_t o decode_infer_t) o_f z = z’ suffices_by simp[] >>
simp[FLOOKUP_EXT, FLOOKUP_o_f, FUN_EQ_THM] >> qx_gen_tac ‘n’ >>
Cases_on ‘FLOOKUP z n’ >> simp[] >>
qpat_x_assum ‘map encode_infer_t _ = fm2sp z’ mp_tac >>
simp[spt_eq_thm, lookup_map] >>
disch_then $ qspec_then ‘n’ (assume_tac o SYM) >> gvs[]
QED
fun tcallify_th fixedvs th =
let val (l,r) = dest_eq (concl th)
val (lf0, args0) = strip_comb l
val args = op_set_diff aconv args0 fixedvs
val lf = list_mk_comb(lf0, fixedvs)
val atup = pairSyntax.list_mk_pair args
val inty = type_of atup
val body_t = tailrecLib.mk_sum_term lf inty r
in
pairSyntax.mk_pabs(atup, body_t)
end
val cvwalk_code = tcallify_th [“s:infer_t num_map”] cvwalk_thm
Definition cvwalk_code_def:
cvwalk_code s = ^cvwalk_code
End
Theorem sum_CASE_infer_CASE:
sum_CASE (infer_t_CASE i vf af uf) lf rf =
infer_t_CASE i (λv. sum_CASE (vf v) lf rf)
(λl n. sum_CASE (af l n) lf rf)
(λu. sum_CASE (uf u) lf rf)
Proof
Cases_on ‘i’ >> simp[]
QED
Theorem cvwalk_preserves_precond:
∀x y.
(λn. cwfs s) x ∧ cvwalk_code s x = INL y ⇒ (λn. cwfs s) y
Proof
simp[cvwalk_code_def, AllCaseEqs(), FORALL_PROD]
QED
Definition cvwalkR_def:
cvwalkR σ = λv v0. vR (encode_infer_t o_f sp2fm σ) v v0
End
Theorem cvwalk_ensures_decrease:
∀x y. (λn. cwfs s) x ∧ cvwalk_code s x = INL y ⇒ cvwalkR s y x
Proof
simp[cwfs_def, swfs_def, wfs_def, cvwalk_code_def, AllCaseEqs(), FORALL_PROD,
cvwalkR_def, sp2fm_map] >>
simp[substTheory.vR_def, FLOOKUP_o_f, encode_infer_t_def]
QED
Theorem WF_cvwalkR:
∀x. (λn. cwfs s) x ⇒ WF (cvwalkR s)
Proof
simp[FORALL_PROD, cwfs_def, swfs_def, cvwalkR_def, wfs_def, sp2fm_map,
SF ETA_ss]
QED
Theorem cvwalk_tcallish:
∀x. (λn. cwfs s) x ⇒
cvwalk s x = TAILCALL (cvwalk_code s) (cvwalk s) x
Proof
simp[whileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE,
sum_CASE_infer_CASE, FORALL_PROD] >>
simp[Once (DISCH_ALL cvwalk_thm), cwfs_def]
QED
Theorem cvwalk_cleaned:
∀x. (λn. cwfs s) x ⇒ cvwalk s x = TAILREC (cvwalk_code s) x
Proof
match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >>
rpt conj_tac
>- ACCEPT_TAC cvwalk_preserves_precond
>- (rpt strip_tac >> qexists_tac ‘cvwalkR s’ >> conj_tac
>- (irule $ iffLR WF_EQ_WFP >> irule WF_cvwalkR >> gs[]) >>
rpt strip_tac >> gvs[] >>
irule cvwalk_ensures_decrease >> simp[])
>- ACCEPT_TAC cvwalk_tcallish
QED
Definition tcvwalk_def:
tcvwalk s n = TAILREC (cvwalk_code s) n
End
Theorem cvwalk_eta[local]: (λn. cvwalk_code s n) = cvwalk_code s
Proof simp[FUN_EQ_THM]
QED
Theorem tcvwalk_thm =
tcvwalk_def |> SRULE[Once whileTheory.TAILREC, cvwalk_code_def]
|> SRULE[sum_CASE_option_CASE, sum_CASE_infer_CASE]
|> SRULE[GSYM tcvwalk_def, cvwalk_eta,
GSYM (SRULE [FUN_EQ_THM] cvwalk_code_def)]
Theorem tcvwalk_correct =
SRULE[FORALL_PROD, GSYM tcvwalk_def] cvwalk_cleaned
Definition tcwalk_def:
tcwalk s it = dtcase it of
Infer_Tvar_db c => Infer_Tvar_db c
| Infer_Tapp l n => Infer_Tapp l n
| Infer_Tuvar v => tcvwalk s v
End
Theorem tcwalk_correct:
∀s it. cwfs s ⇒ cwalk s it = tcwalk s it
Proof
rpt strip_tac >> simp[cwalk_thm, tcvwalk_correct, tcwalk_def]
QED
Definition cocl_def:
(cocl s [] n ⇔ F) ∧
(cocl s (i::is) n ⇔ coc s i n ∨ cocl s is n)
End
Theorem cocl_EXISTS:
cocl s its n ⇔ EXISTS (λi. coc s i n) its
Proof
Induct_on ‘its’ >> simp[cocl_def]
QED
Theorem coc_thm' = CONJ (SRULE[GSYM cocl_EXISTS] coc_thm) cocl_def
Definition kcoc_def:
kcoc s it n k = cwc (coc s it n) k
End
Definition kcocl_def:
kcocl s its n k = cwc (cocl s its n) k
End
Theorem contify_infer_case:
contify k (infer_t_CASE it cf af uf) =
contify (λit. dtcase it of Infer_Tvar_db c => contify k (cf c)
| Infer_Tapp l n => contify k (af l n)
| Infer_Tuvar v => contify k (uf v))
it
Proof
Cases_on ‘it’ >> simp[contify_def]
QED
Theorem kcoc_thm =
kcoc_def |> SPEC_ALL
|> SRULE[GSYM contify_cwc, ASSUME “cwfs s”, coc_thm']
|> CONV_RULE
(TOP_DEPTH_CONV (contify_CONV [contify_infer_case]))
|> SRULE [cwcp “cwalk”, cwcp “cwalk s”, cwcp “$=”, cwcp “$= x”,
cwcp “cocl”, cwcp “cocl s”]
|> SRULE [GSYM kcocl_def]
Theorem cwc_OR:
cwc (bool$\/ b) k = if b then k (K T) else k I
Proof
rw[cwc_def] >> AP_TERM_TAC >> simp[FUN_EQ_THM]
QED
Theorem kcocl_Ky:
kcocl s t n (λx. y) = y
Proof
simp[kcocl_def, cwc_def]
QED
Theorem kcocl_thm =
kcocl_def |> SPEC_ALL
|> SRULE [GSYM contify_cwc, ASSUME “cwfs s”,
Once $ DefnBase.one_line_ify NONE cocl_def]
|> CONV_RULE
(TOP_DEPTH_CONV (contify_CONV [contify_infer_case]))
|> SRULE [cwcp “coc”, cwcp “coc s”, cwc_OR,
cwcp “cocl”, cwcp “cocl s”]
|> SRULE[GSYM kcoc_def, GSYM kcocl_def]
|> SRULE[cwc_def, SF ETA_ss, kcocl_Ky]
Type kcockont = “:infer_t list list”
Definition apply_kcockont_def:
apply_kcockont s n [] b = b ∧
apply_kcockont s n (ts :: rest) b =
if b then apply_kcockont s n rest T
else kcocl s ts n (apply_kcockont s n rest)
End
Theorem apply_kcockontT[simp]:
apply_kcockont s n ts T = T
Proof
Induct_on ‘ts’ >> simp[apply_kcockont_def]
QED
Definition dfkcoc_def:
dfkcoc s t n k = kcoc s t n (apply_kcockont s n k)
End
Definition dfkcocl_def:
dfkcocl s ts n k = kcocl s ts n (apply_kcockont s n k)
End
Theorem apply_kcockont_thm =
REWRITE_RULE [GSYM dfkcocl_def, apply_kcockontT] apply_kcockont_def
Theorem dfkcoc_thm =
dfkcoc_def |> SPEC_ALL
|> ONCE_REWRITE_RULE [kcoc_thm]
|> SRULE [GSYM apply_kcockont_thm, GSYM dfkcocl_def]
Theorem dfkcocl_thm =
dfkcocl_def |> SPEC_ALL
|> ONCE_REWRITE_RULE [kcocl_thm]
|> SRULE [GSYM apply_kcockont_thm, GSYM dfkcocl_def]
|> SRULE [SF ETA_ss, GSYM dfkcoc_def]
Theorem apply_kcockont_HDNIL:
apply_kcockont s n ([] :: k) = apply_kcockont s n k
Proof
simp[FUN_EQ_THM, apply_kcockont_thm, Once kcocl_thm, dfkcocl_thm] >>
Cases >> simp[]
QED
Theorem dfkcocl_HDNIL:
dfkcocl s ts n ([] :: k) = dfkcocl s ts n k
Proof
simp[dfkcocl_def, apply_kcockont_HDNIL]
QED
Theorem dfkcocl_removed:
dfkcocl s ts n k = apply_kcockont s n (ts :: k) F
Proof
simp[apply_kcockont_thm] >> simp[dfkcocl_thm] >>
simp[dfkcoc_def, apply_kcockont_HDNIL]
QED
val remove = CONV_RULE (RAND_CONV (REWRITE_CONV[dfkcocl_removed]))
Theorem dfkcocl_nonrecursive0 = remove dfkcocl_thm
Theorem dfkcocl_nonrecursive =
dfkcocl_nonrecursive0
|> SRULE[apply_kcockont_thm]
|> CONV_RULE (RAND_CONV (SCONV [dfkcocl_thm]))
|> SRULE[dfkcoc_thm, apply_kcockont_HDNIL, dfkcocl_HDNIL]
|> CONV_RULE (RAND_CONV (SCONV [dfkcocl_removed]))
Overload kcocwl0 = “apply_kcockont”
Theorem kcocwl0_thm =
apply_kcockont_thm
|> CONJUNCTS
|> map (GEN_ALL o PURE_REWRITE_RULE[dfkcocl_nonrecursive] o SPEC_ALL)
|> LIST_CONJ
Definition kcocwl_def: kcocwl s n ts = kcocwl0 s n ts F
End
Theorem kcocwl0_varcheck: kcocwl0 s n ts b = if b then T else kcocwl s n ts
Proof