-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathloderunner.v
More file actions
2152 lines (2051 loc) · 155 KB
/
loderunner.v
File metadata and controls
2152 lines (2051 loc) · 155 KB
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
Require Import Relations.
Require Import List.
Import ListNotations.
(* Formalism of loderunner; this must be checked to agree with the desired game.
Note that the y-axis points downwards. *)
Inductive tile := | air | stone | brick | ladder | pipe.
Definition is_solid t := t = stone \/ t = brick.
Definition is_supporting t := is_solid t \/ t = ladder.
Definition is_holdable t := t = ladder \/ t = pipe.
Definition position:Set := nat * nat.
Definition below (p:position) := let (x,y) := p in (x,S y).
Definition above (p q:position) := q = below p.
Definition right (p q:position) := p = let (x,y) := q in (S x,y).
Definition beside p q := right p q \/ right q p.
Definition grid A := list (list A).
Record state := {sp: position ; sg: grid tile ; sd: list position}.
Definition evg {A} a (g:grid A) (p:position) := nth (fst p) (nth (snd p) g []) a.
Definition ev := evg stone.
Definition set p t g h := ev h p = t /\ forall q, q = p \/ ev h q = ev g q.
Definition supported g p := (is_holdable (ev g p)) \/ (is_supporting (ev g (below p))).
Inductive move g : relation position :=
| move_down : forall p q, above p q -> move g p q
| move_up : forall p q, above q p -> (ev g p = ladder) -> move g p q
| move_beside : forall p q, beside p q -> supported g p -> move g p q.
Inductive step : relation state :=
| step_move p q g d: move g p q -> ~is_solid (ev g q) ->
step {|sp:=p;sg:=g;sd:=d|} {|sp:=q;sg:=g;sd:=d|}
| step_destroy p ps pb g h d: beside p ps -> above ps pb ->
~is_solid (ev g ps) -> ev g pb = brick -> supported g p -> set pb air g h ->
step {|sp:=p;sg:=g;sd:=d|} {|sp:=p;sg:=h;sd:=pb::d|}
| step_solidify p q g h d: p <> q -> set q brick g h ->
step {|sp:=p;sg:=g;sd:=d++[q]|} {|sp:=p;sg:=h;sd:=d|}.
Definition can_reach := clos_refl_trans _ step.
Definition can_reach_pos g p q := exists d h,
can_reach {|sp:=p;sg:=g;sd:=[]|} {|sp:=q;sg:=h;sd:=d|}.
Definition rect {A} w h (g:grid A) := length g = h /\ forall r, In r g -> length r = w.
Definition cross g := exists w h, rect (S w) (S h) g /\
can_reach_pos g (0,0) (w,h) /\
can_reach_pos g (w,0) (0,h) /\
~can_reach_pos g (0,0) (0,h) /\
~can_reach_pos g (w,0) (w,h).
Definition contains (g : grid tile) t := exists r, In t r /\ In r g.
Definition exists_cross := exists g, cross g.
Definition cross_required_tiles := forall l,
(exists g, cross g /\ forall t, contains g t -> In t l) <-> incl [brick;ladder] l.
(* End of formalism. Now we prove exists_cross and cross_required_tiles. *)
Require Import Ascii.
Require Import String.
Require Import Basics.
Require Import EqualitiesFacts.
Require Lists.ListSet.
Import Nat.
Import PeanoNat.Nat.
Import List.
#[local] Instance neq_Symmetric {A} : RelationClasses.Symmetric (fun (x y:A) => x <> y).
intros x y H G. symmetry in G. apply (H G). Qed.
#[local] Instance beside_Symmetric : RelationClasses.Symmetric beside.
intros p q. unfold beside. tauto. Qed.
Definition dims {A} (g:grid A) := let w := length (hd [] g) in
if forallb (fun r => length r =? w) g then Some(w,length g) else None.
Lemma isrect {A} (g:grid A): match dims g with | Some(w,h) => rect w h g | None => True end.
unfold dims. destruct (forallb _ _) eqn:E. rewrite forallb_forall in E. split. split. intros r H.
rewrite <- eqb_eq. apply (E _ H). split. Qed.
Lemma minus_less {a b c:nat} : S a = b - c -> c < b.
intros H. apply Minus.lt_O_minus_lt. rewrite <- H. apply Le.le_n_S. apply le_0_l. Qed.
Lemma minus_inv {a b:nat}: a < b -> exists c, c < b /\ c = b - S a /\ a = b - S c.
intros H. exists (b-S a). assert (S a=b-(b-S a)) as H1. symmetry. apply add_sub_eq_r. symmetry.
apply Minus.le_plus_minus. apply H. repeat split. apply (minus_less H1). rewrite sub_succ_r.
apply (f_equal pred H1). Qed.
Definition grid_map {A B} (f:A->B) g := map (map f) g.
Lemma nth_nil {A} (a:A) n: nth n [] a = a. destruct n; split. Qed.
Lemma nth_y {A x y a w h} {gr:grid A} : rect w h gr -> h <= y -> evg a gr (x,y) = a.
intros [Hh _] Hy. unfold evg. simpl. rewrite <- Hh in Hy. rewrite (nth_overflow _ _ Hy). apply nth_nil. Qed.
Lemma nth_x {A x y a w h} {gr:grid A} : rect w h gr -> w <= x -> evg a gr (x,y) = a.
intros [_ Hw] Hx. unfold evg. apply nth_overflow. eapply Le.le_trans. 2: apply Hx.
destruct (nth_in_or_default y gr []) as [H|H]. rewrite Hw. constructor. apply H. simpl.
rewrite H. apply le_0_l. Qed.
Definition grid_size {A} (g:grid A) := fold_left plus (map (@length _) g) 0.
Fixpoint replace {A} (x:nat) (a:A) l := match (x,l) with | (_,[]) => []
| (S x,b::l) => b::(replace x a l)
| (0,b::l) => a::l end.
Lemma replace_len {A x l} {a:A}: length (replace x a l) = length l.
revert x. induction l; intros [|x]; try split. simpl. rewrite IHl. split. Qed.
Lemma replace1 {A x l} {a b:A}: x < length l -> nth x (replace x a l) b = a.
revert x. induction l. intros x H. inversion H. intros [|x] H. split. apply Le.le_S_n in H. apply (IHl _ H). Qed.
Lemma replace2 {A x1 x2 l} {a b:A}: x1 = x2 \/ nth x1 (replace x2 a l) b = nth x1 l b.
revert x1 x2. induction l. intros x1 [|x2]; right; split. intros [|x1] [|x2]. left. split. 1,2:right;split.
destruct (IHl x1 x2) as [H|H]. left. rewrite H. split. right. apply H. Qed.
Definition replaceg {A} (p:position) (a:A) g := let (x,y):= p in replace y (replace x a (nth y g [])) g.
Definition setg {A} p (d t:A) g h := evg d h p = t /\ forall q, q = p \/ evg d h q = evg d g q.
Lemma set_equiv p t g h : set p t g h <-> setg p stone t g h. unfold set. unfold setg. tauto. Qed.
Lemma replace_set {A} p (d t:A) g: evg d g p = d \/ setg p d t g (replaceg p t g).
destruct p as [x y]. unfold replaceg. unfold setg. unfold evg. simpl.
epose proof (Compare_dec.le_lt_dec _ x) as [H|H]. left. apply nth_overflow. apply H. right.
epose proof (replace1 _) as G. split. rewrite G. apply replace1. apply H. intros [z w]. simpl.
epose proof replace2 as [F|F]. 2:rewrite F. rewrite F. rewrite G. epose proof replace2 as [E|E]. 2:rewrite E.
left. rewrite E. split. all:right;split. Unshelve. epose proof (Compare_dec.le_lt_dec _ y) as [G|G].
rewrite nth_overflow in H. inversion H. all:apply G. Qed.
Definition flipg {A} := map (@rev A).
Definition flipp w (p:position) := match p with | (x,y) => (w-S x,y) end.
Module Sym.
Section Sym.
Context {w:nat}.
Definition flipx x := if x<?w then w-S x else x.
Definition flipr r := let r1 := r ++ (repeat stone (w-length r)) in
(rev (firstn w r1))++(skipn w r1).
Lemma flipr_nth x r : nth x r stone = nth (flipx x) (flipr r) stone.
unfold flipr. set (r++_) as r1.
erewrite (_:forall a b d, length a = w -> nth (flipx x)(rev a++b) d=nth x (a++b) d). rewrite firstn_skipn.
unfold r1. destruct (Compare_dec.le_lt_dec (length r) x) as [Hx|Hx]. rewrite app_nth2. rewrite nth_repeat.
apply nth_overflow. 1,2:apply Hx. rewrite app_nth1. split. apply Hx. apply firstn_length_le.
unfold r1. rewrite app_length. rewrite repeat_length. rewrite add_comm. apply sub_add_le. Unshelve.
intros a b d Hw. unfold flipx. destruct (x<?w) eqn:Hx. apply Compare_dec.leb_complete in Hx.
destruct (minus_inv Hx) as [x1[H1[H2 H3]]]. rewrite <- H2. repeat (rewrite app_nth1). rewrite H3.
rewrite <- Hw. apply rev_nth. 3:rewrite rev_length. 1,2,3: rewrite Hw. 1,3:apply H1. apply Hx.
apply Compare_dec.leb_complete_conv in Hx. apply Le.le_S_n in Hx. repeat (rewrite app_nth2).
1,3: rewrite rev_length. split. 1,2: rewrite Hw. 1,2: apply Hx. Qed.
Definition flipg1 g := map flipr g.
Definition flipp1 (p:position) := match p with | (x,y) => (flipx x,y) end.
Lemma flip_ev g p: ev (flipg1 g) (flipp1 p) = ev g p.
symmetry. unfold ev. unfold evg. unfold flipg1. destruct p as [x y]. simpl.
destruct (Compare_dec.le_lt_dec (length g) y) as [Hy|Hy]. repeat (rewrite (nth_overflow _ [])).
repeat (rewrite nth_nil). split. rewrite map_length. 1,2:apply Hy. erewrite (nth_indep (map _ _)).
rewrite map_nth. apply flipr_nth. rewrite map_length. apply Hy. Qed.
Lemma flipr_eq r: length r = w -> rev r = flipr r.
intros Hr. unfold flipr. rewrite <- Hr. rewrite sub_diag. simpl. rewrite app_nil_r. rewrite skipn_all.
rewrite app_nil_r. rewrite firstn_all. split. Qed.
Lemma flipg1_eq {h g}: rect w h g -> flipg g = flipg1 g.
intros [Hh Hw]. unfold flipg1. unfold flipg. apply map_ext_in. intros r Hr. apply flipr_eq. apply Hw.
apply Hr. Qed.
Lemma flipp1_eq {p}: fst p < w -> flipp w p = flipp1 p.
destruct p as [x y]. simpl. unfold flipx. intros Hx. rewrite <- ltb_lt in Hx. rewrite Hx. split. Qed.
Definition thin g:= forall p, ~ is_solid (ev g p) -> fst p < w.
Lemma flip_below p: flipp1 (below p) = below (flipp1 p). destruct p as [x y]. split. Qed.
Lemma flip_right {p q}: right p q -> fst p < w -> right (flipp1 q) (flipp1 p).
destruct q as [x y]. intros Hr. rewrite Hr. intros Hx1. repeat (rewrite <- flipp1_eq). 3:apply Le.le_S_n.
3:constructor. 2,3:apply Hx1. unfold right. simpl. rewrite <- sub_succ_l. rewrite sub_succ. split. apply Hx1.
Qed.
Lemma flip_beside {p q}: beside p q -> fst p < w -> fst q < w -> beside (flipp1 p) (flipp1 q).
unfold beside. intros [H|H] Hp Hq. 1:right. 2:left. all:apply flip_right. all:assumption. Qed.
Lemma flip_above {p q}: above p q -> above (flipp1 p) (flipp1 q).
unfold above. rewrite <- flip_below. apply f_equal. Qed.
Lemma flip_supported {g p}: supported g p -> supported (flipg1 g) (flipp1 p).
intros [H|H]. 1:left. 2:right. 2:rewrite <- flip_below. 1,2:rewrite flip_ev. 1,2:assumption. Qed.
Lemma flip_move {g p q}: fst p < w -> fst q < w -> move g p q -> move (flipg1 g) (flipp1 p) (flipp1 q).
intros Hp Hq H. inversion H. 3:apply move_beside. 4:apply flip_supported. 3:apply flip_beside.
2:apply move_up. 1:apply move_down. 1,2:apply flip_above. 3:rewrite flip_ev. all:assumption. Qed.
Lemma flipx_inv x : flipx (flipx x) = x.
unfold flipx. destruct (Compare_dec.le_lt_dec w x) as [Hx|Hx]. rewrite <- ltb_ge in Hx. repeat (rewrite Hx).
split. destruct (minus_inv Hx) as [x1[H1[H2 H3]]]. rewrite <- ltb_lt in Hx. rewrite Hx. rewrite <- H2.
rewrite <- ltb_lt in H1. rewrite H1. symmetry. apply H3. Qed.
Lemma flipp1_inv p: flipp1 (flipp1 p) = p. destruct p. simpl. rewrite flipx_inv. split. Qed.
Lemma flip_set {g h p t}: set p t g h -> set (flipp1 p) t (flipg1 g) (flipg1 h).
intros [H1 H2]. split. rewrite flip_ev. apply H1. intros q. rewrite <- (flipp1_inv q). set (flipp1 q) as r.
repeat (rewrite flip_ev). destruct (H2 r) as [Hr|Hr]. left. rewrite Hr. split. right. apply Hr. Qed.
Definition thins s := fst (sp s) < w /\ thin (sg s).
Definition flips s := {|sp:=flipp1 (sp s);sg:=flipg1 (sg s);sd:=map flipp1 (sd s)|}.
Lemma flip_step {s t}: thins s -> step s t -> thins t /\ step (flips s) (flips t).
destruct s as [p g d]. destruct t as [q h e]. intros [Hp Hg] Hs. unfold flips. simpl. inversion Hs.
rewrite H4 in Hg. pose proof (Hg _ H6) as Hq. split. apply (conj Hq Hg). apply step_move.
apply (flip_move Hp Hq H1). rewrite flip_ev. apply H6. rewrite H2 in Hp. pose proof (Hg _ H7) as Hps.
repeat split. apply Hp. simpl. intros r Hr. destruct ((proj2 H10) r) as [Hr1|Hr1]. replace (fst r) with (fst ps).
apply Hps. rewrite Hr1. rewrite H6. destruct ps. split. rewrite Hr1 in Hr. apply (Hg _ Hr).
apply (step_destroy _ (flipp1 ps)). apply (flip_beside H5 Hp). apply Hps. apply (flip_above H6).
1,2:(rewrite flip_ev; assumption). apply (flip_supported H9). apply (flip_set H10). rewrite H3 in Hp.
repeat split. apply Hp. simpl. intros r Hd. destruct ((proj2 H6) r) as [Hr|Hr]; rewrite Hr in Hd.
rewrite (proj1 H6) in Hd. destruct Hd. right. split. apply (Hg _ Hd). rewrite map_app. apply step_solidify.
intros Heq. apply (f_equal flipp1) in Heq. repeat (rewrite flipp1_inv in Heq). apply (H1 Heq).
apply (flip_set H6). Qed.
Lemma flip_reach {s t}: thins s -> can_reach s t -> thins t /\ can_reach (flips s) (flips t).
intros Hs. revert t. apply clos_refl_trans_ind_left. split. apply Hs. apply rt_refl.
intros t r Hst [Ht Hr] Htr. destruct (flip_step Ht Htr) as [H1 H2]. split. apply H1. eapply rt_trans.
apply Hr. apply rt_step. apply H2. Qed.
Theorem reach {h g p q}: rect w h g -> fst p < w -> can_reach_pos g p q
-> can_reach_pos (flipg g) (flipp w p) (flipp w q).
intros Hg Hp [d [g1 Hd]]. eassert _ as Ht. 2:destruct (flip_reach Ht Hd) as [[Ht1 _] Hr]. split. apply Hp.
intros [x y] Hs. destruct (Compare_dec.le_lt_dec w x) as [Hx|Hx]. unfold ev in Hs. rewrite (nth_x Hg Hx) in Hs.
destruct Hs. left. split. apply Hx. rewrite (flipp1_eq Hp). simpl in Ht1. rewrite (flipp1_eq Ht1).
rewrite (flipg1_eq Hg). eexists. eexists. apply Hr. Qed.
End Sym.
End Sym.
Theorem cross_sym {w h g}: g=flipg g -> rect (S w) (S h) g ->
can_reach_pos g (w,0) (0,h) -> ~can_reach_pos g (0,0) (0,h) -> cross g.
intros Hs Hg Hp Hn. exists w. exists h. eenough ((0,0)=_) as H1.
unshelve (eapply (conj Hg (conj _ (conj Hp (conj Hn _))))). 2:intros H. 2:apply Hn. 1,2:rewrite Hs; rewrite H1.
erewrite (_:(w,h)=_). eapply (Sym.reach Hg _ Hp). erewrite (_:(0,h)=_).
eapply (Sym.reach Hg _ H). Unshelve. 3,5:constructor. all:unfold flipp. 1,3:rewrite sub_diag.
3:(rewrite sub_succ;rewrite sub_0_r). all:split. Qed.
Scheme Equality for tile. (* Defines tile_beq, internal_tile_dec_bl *)
Definition is_empty t := ~is_solid t.
Definition emptyb t := match t with | stone | brick => false | _ => true end.
Definition supportingb t := match t with | stone | brick | ladder => true | _ => false end.
Definition holdableb t := match t with | ladder | pipe => true | _ => false end.
Definition supportedb g p := ((holdableb (ev g p)) || (supportingb (ev g (below p))))%bool.
Lemma tile_dec {t1 t2} : (t1 = t2) <-> tile_beq t1 t2 = true.
split. apply internal_tile_dec_lb. apply internal_tile_dec_bl. Qed.
Lemma not_equiv P Q: ((P \/ Q) /\ ~(P /\ Q)) -> (~P <-> Q).
intros [HO HN]. split. intros H. destruct HO as [HP|HQ]. destruct (H HP). apply HQ. intros HQ HP.
apply (HN (conj HP HQ)). Qed.
Proposition empty_equiv {t} : is_empty t <-> emptyb t = true.
unfold is_empty. apply not_equiv. unfold is_solid. repeat (rewrite tile_dec). split. destruct t; tauto.
destruct t; simpl; intros [[H|H] G]; inversion H; inversion G. Qed.
Lemma empty_dec {t} : is_empty t \/ is_solid t.
rewrite empty_equiv. unfold is_solid. destruct t; simpl; tauto. Qed.
Proposition supporting_equiv {t} : is_supporting t <-> supportingb t = true.
unfold is_supporting. unfold is_solid. repeat (rewrite tile_dec). destruct t; simpl; tauto. Qed.
Proposition holdable_equiv {t} : is_holdable t <-> holdableb t = true.
unfold is_holdable. repeat (rewrite tile_dec). destruct t; simpl; tauto. Qed.
Proposition supported_equiv {g p} : supported g p <-> supportedb g p = true.
unfold supported. unfold supportedb. rewrite Bool.orb_true_iff. rewrite supporting_equiv.
rewrite holdable_equiv. tauto. Qed.
Lemma air_empty: is_empty air. rewrite empty_equiv. split. Qed.
Module PP.
Inductive token := | token_tile (t:tile) | newline | unknown.
Definition parse_tile a := match a with
| "010"%char => newline
| " "%char => token_tile air
| "B"%char => token_tile brick
| "S"%char => token_tile stone
| "+"%char => token_tile ladder
| "-"%char => token_tile pipe
| _ => unknown end.
Fixpoint parse_helper s r l := match s with
| EmptyString => (rev r)::l
| String a s1 => let (r1,l1) := match (parse_tile a) with
| newline => ([], (rev r)::l)
| token_tile t => (t::r, l)
| unknown => (r, l) end in parse_helper s1 r1 l1 end.
Fixpoint chop {A} (l : list (list A)) := match l with
| []::l1 => chop l1
| _ => l end.
Definition parse s := chop (rev (chop (parse_helper s [] []))).
Fixpoint rev_list_ascii_to_string (s : list ascii) (t : string) := match s with
| [] => t
| a::s1 => rev_list_ascii_to_string s1 (String a t) end.
Definition index_char x := ascii_of_nat (48 + (x mod 10)).
Definition print_row swy r := match swy with
| (s,w,y) => (["010"%char;index_char y;" "%char]++(rev_append r s),max w (length r),S y) end.
Fixpoint index_row w s := match w with | 0 => s | S w => index_row w ((index_char w)::s) end.
Definition print_grid g := match fold_left print_row g (["010"%char],0,0) with
| (s,w,_) => rev_list_ascii_to_string (rev_append (index_row w []) s) "" end.
Definition tile_to_ascii t := match t with
| air => " "%char
| brick => "B"%char
| stone => "S"%char
| ladder => "+"%char
| pipe => "-"%char end.
Definition print_tiles g := print_grid (grid_map tile_to_ascii g).
End PP.
Fixpoint while {A B} (f:A -> A*option B) a n := match n with
| 0 => None
| S n => let (a,b) := f a in if b then b else while f a n end.
Lemma while_inv {A B} {f:A -> A*option B} {a b n} {P:A->Prop}: (forall c, P c -> P (fst (f c))) -> P a ->
while f a n = Some b -> exists c, P c /\ snd (f c) = Some b.
intros Hp. generalize a. induction n; intros c Hc H. inversion H. simpl in H.
destruct (f c) as (d,[e|]) eqn:Hfc. exists c. rewrite Hfc. apply (conj Hc H). unshelve (eapply (IHn _ _ H)).
pose proof (Hp _ Hc) as Hd. rewrite Hfc in Hd. apply Hd. Qed.
Module PosDec.
Include PairUsualDecidableType PeanoNat.Nat PeanoNat.Nat.
Include Equalities.HasEqDec2Bool.
End PosDec.
Definition poss := ListSet.set position.
Definition poss_union := ListSet.set_union PosDec.eq_dec.
Definition poss_diff := ListSet.set_diff PosDec.eq_dec.
Definition poss_mem := ListSet.set_mem PosDec.eq_dec.
Definition poss_inter := ListSet.set_inter PosDec.eq_dec.
Definition poss_remove := ListSet.set_remove PosDec.eq_dec.
Fixpoint splitn_helper {A} (n:nat) (p q:list A) := match (n,p,q) with
| (S n,p,a::q) => splitn_helper n (a::p) q
| _ => (n,p,q) end.
Definition splitn {A} n (l:list A) := match splitn_helper n [] l with
| (0,p,q) => Some (rev p, q)
| _ => None end.
Lemma splitn_app {A n} {l p q:list A}: splitn n l = Some (p,q) -> length p = n /\ l=p++q.
assert (forall m u r s, @splitn_helper A m r s = (0,u,q)->exists t,length t=m/\u=(rev t)++r/\s=t++q) as H.
induction m. intros u r s H. inversion H. exists []. repeat split. intros u r [|a s] H. inversion H. simpl in H.
destruct (IHm _ _ _ H) as [t [Ht [Hp Hq]]]. exists (a::t). rewrite <- Ht. rewrite Hp. rewrite Hq. simpl.
rewrite <- app_assoc. repeat split. unfold splitn. destruct (splitn_helper _ _ _) as [[[|m] r] s] eqn:E;
intros H1; inversion H1. rewrite H3 in E. destruct (H _ _ _ _ E) as [t [Ht [Hu Hs]]]. rewrite app_nil_r in Hu.
rewrite Hu. rewrite rev_involutive. apply (conj Ht Hs). Qed.
Lemma app1 {A s p q} {d:A}: length p = s -> forall x, nth (x+s) (p++q) d = nth x q d.
intros H x. rewrite add_comm. rewrite <- H. apply app_nth2_plus. Qed.
Lemma app2 {A s w x p q r} {d e:A}: length p = s -> length q = w -> x < w -> nth (x+s) (p++q++r) d = nth x q e.
intros Hs Hw Hx. rewrite (app1 Hs). rewrite <- Hw in Hx. rewrite app_nth1. apply nth_indep. all:apply Hx. Qed.
Lemma nth_hd {A n p q} {d:A}: length p = n -> nth n (p++q) d = hd d q.
intros H. rewrite (app1 H 0). destruct q; split. Qed.
Lemma len1 {A l n} {a:A}: length l = n -> length (l++[a]) = S n.
intros H. rewrite app_length. rewrite H. apply add_comm. Qed.
Lemma nxt {A} p q {a:A}: p++a::q = (p++[a])++q. rewrite <- app_assoc. split. Qed.
Module Pos.
Definition can_reach_any g p q := forall d, exists e h,
can_reach {|sp:=p;sg:=g;sd:=d|} {|sp:=q;sg:=h;sd:=e|}.
Definition state1:Type := (position * grid tile).
Definition reach1 (s t:state1) := forall d, exists e,
can_reach {|sp:=fst s;sg:=snd s;sd:=d|} {|sp:=fst t;sg:=snd t;sd:=e|}.
Ltac reach1_step := intros ?; eexists; apply rt_step; simpl.
Lemma reach1_refl: reflexive _ reach1. intros [p g] d. eexists. apply rt_refl. Qed.
(* Split the middle pair to make eapply more convenient *)
Lemma reach1_trans {s t p g}: reach1 s (p,g) -> reach1 (p,g) t -> reach1 s t.
intros H1 H2 d. destruct (H1 d) as [e H3]. destruct (H2 e) as [f H4]. eexists. eapply rt_trans.
apply H3. apply H4. Qed.
Section Reach.
Context (g:grid tile).
Definition pre_neighbors (p:position) := let (x,y) := p in
let s := supportedb g p in [
(s, (S x,y));
((s && (0 <? x))%bool, (pred x, y));
((tile_beq (ev g p) ladder && (0 <? y))%bool, (x, pred y));
(true, (x, S y))].
Definition neighbors p :=
let n1 := map (@snd _ _) (filter (@fst _ _) (pre_neighbors p)) in
filter (fun q => emptyb (ev g q)) n1.
Definition reachb_step p oc := match oc with
| ([],_) => (oc,None)
| (q::o,c) => ((poss_union (poss_diff (neighbors q) c) o,q::c),if (PosDec.eqb p q) then Some tt else None)
end.
Definition reachb p q := if (while (reachb_step q) ([p],[]) (grid_size g)) then true else false.
Definition reach_pos p q := forall d, can_reach {|sp:=p;sg:=g;sd:=d|} {|sp:=q;sg:=g;sd:=d|}.
Definition reach_set p oc := forall q, In q (@fst poss poss oc) -> reach_pos p q.
Lemma reach_set_init p: reach_set p ([p],[]).
intros q [H|[]] d. rewrite H. apply rt_refl. Qed.
Lemma pre_neighbors_suff p q: In (true,q) (pre_neighbors p) -> move g p q.
destruct p as [x y]. intros [H|[H|[H|[H|[]]]]]; inversion H. 2,3:rewrite Bool.andb_true_iff in H1.
2,3:destruct H1 as [H1 H3]. 1,2:(rewrite <- supported_equiv in H1;apply move_beside). 2,4:apply H1.
right. split. destruct x. 3:destruct y. 1,3:(rewrite ltb_irrefl in H3;inversion H3). left. split.
apply move_up. split. rewrite <- tile_dec in H1. apply H1. apply move_down. split. Qed.
Lemma neighbors_suff p q: In q (neighbors p) -> reach_pos p q.
unfold neighbors. intros H d. rewrite filter_In in H. destruct H as [H1 H2]. apply rt_step. apply step_move.
apply pre_neighbors_suff. rewrite in_map_iff in H1. destruct H1 as [[b q1][H3 H4]]. rewrite filter_In in H4.
destruct H4 as [H4 H5]. rewrite <- H3. rewrite <- H5. apply H4. apply (proj2 empty_equiv H2). Qed.
Lemma reach_set_inv p q oc: reach_set p oc -> reach_set p (fst (reachb_step q oc)).
intros H r Hr. destruct oc as [[|s o] c]. apply H. apply Hr. simpl in Hr.
destruct (ListSet.set_union_elim _ _ _ _ Hr) as [H1|H1]. apply ListSet.set_diff_elim1 in H1. intros d.
eapply rt_trans. apply H. left. split. apply neighbors_suff. apply H1. apply H. right. apply H1. Qed.
Lemma reachb_correct {p q}: reachb p q = true -> reach_pos p q.
unfold reachb. destruct (while _ _ _) eqn:H. intros _. eapply (while_inv _ (reach_set_init p)) in H.
destruct H as [[[|r o] c] [H1 H2]]; simpl in H2. inversion H2. destruct (PosDec.eqb q r) eqn:Hqr.
rewrite PosDec.eqb_eq in Hqr. rewrite Hqr. apply H1. left. split. inversion H2. intros H2. inversion H2.
Unshelve. apply reach_set_inv. Qed.
Lemma reach_pos1 {p q}: reach_pos p q -> reach1 (p,g) (q,g). intros H d. eexists. apply H. Qed.
End Reach.
Lemma mv q g p: if reachb g p q then reach1 (p,g) (q,g) else True.
destruct (_:bool) eqn:H. apply reachb_correct in H. apply (reach_pos1 _ H). split. Qed.
Section Destroy.
Lemma beside_left {x y}: beside (x,y) (S x,y). right. split. Qed.
Lemma beside_right {x y}: beside (S x,y) (x,y). left. split. Qed.
Definition destroyb g p q := (supportedb g p && emptyb (ev g q) && tile_beq (ev g (below q)) brick)%bool.
Lemma destroy_suff g p q d: beside p q -> destroyb g p q = true -> let r := below q in
step {|sp:=p;sg:=g;sd:=d|} {|sp:=p;sg:=replaceg r air g;sd:=r::d|}.
unfold destroyb. repeat (rewrite Bool.andb_true_iff). rewrite <- supported_equiv. rewrite <- tile_dec.
rewrite <- empty_equiv. intros Hp [[Hs He] Hb]. eapply step_destroy. apply Hp. split. apply He.
apply Hb. apply Hs. rewrite set_equiv. epose proof (replace_set _ _ _ _) as [H|H]. 2:apply H.
unfold ev in Hb. rewrite H in Hb. inversion Hb. Qed.
Lemma destroy r {q} (Hb:beside q r) g p: if (destroyb g q r && reachb g p q)%bool then
reach1 (p,g) (q,(replaceg (below r) air g)) else True.
destruct (_:bool) eqn:H. rewrite Bool.andb_true_iff in H. destruct H as [Hd H]. eapply reach1_trans.
pose proof (mv q g p) as Hm. rewrite H in Hm. apply Hm. reach1_step. apply destroy_suff; assumption. split. Qed.
End Destroy.
Section Drill.
Definition drill_row s w r := match splitn s r with | None => None | Some (r1,r2) =>
match splitn w r2 with | None => None | Some (r3,r4) =>
if forallb (tile_beq brick) ((hd stone r4)::r3) then
Some (Some (r1++(repeat air w)++r4))
else if (forallb (emptyb) r3) then Some None else None
end end.
Fixpoint drill_top s w g h := match g with | [] => None | r::g1 => match drill_row s w r with
| None => None
| Some None => Some (rev_append g h, length g1)
| Some (Some r1) => drill_top s (S w) g1 (r1::h) end end.
Definition drill_helper (q:position) g p := let (x,y) := q in match (splitn (S y) g) with | None => None
| Some (gb,h) => match drill_top x 1 (rev gb) [] with | None => None | Some (ga,z) =>
if reachb g p (x,z) then Some (ga++h) else None end end.
Definition forp s w (P:nat->Prop) := forall x, x < w -> P (x+s).
Definition forr s w r P := forp s w (fun x => P(nth x r stone)).
Lemma for_sub {s1 w1 s2 w2 P}: forp s1 w1 P -> s1 <= s2 -> w2 + s2 <= w1 + s1 -> forp s2 w2 P.
intros H L R x Hx. assert (x+s2=x+s2-s1+s1) as E. symmetry. apply sub_add. eapply le_trans. apply L.
apply Plus.le_plus_r. rewrite E. apply H. rewrite <- (add_sub w1 s1). apply le_add_le_sub_r. simpl. rewrite <- E.
eapply le_trans. 2:apply R. apply Plus.plus_lt_compat_r. apply Hx. Qed.
Lemma forS {s w P}: forp s (S w) P -> forp s w P /\ forp (S s) w P.
intros H. split; apply (for_sub H). 4:rewrite add_succ_r. all:repeat constructor. Qed.
Lemma movei {w y g} s x1 x2: forp s w (fun x => is_empty (ev g (x,y)) /\ supported g (x,y)) -> x1 < w -> x2 < w
-> reach1 (x1+s,y,g) (x2+s,y,g).
intros H. assert (x1<=x2 \/ x2<=x1) as [G|G]. epose proof Compare_dec.le_lt_dec as [G|G]. left. apply G.
right. apply Le.le_Sn_le. apply G. all:induction G; intros H1 H2. 1,3:apply reach1_refl.
pose proof (Le.le_Sn_le _ _ H2) as H3. eapply reach1_trans. apply (IHG H1 H3). reach1_step.
apply step_move. apply move_beside. right. split. apply (proj2 (H _ H3)). apply (proj1 (H _ H2)).
pose proof (Le.le_Sn_le _ _ H1) as H3. eapply reach1_trans. 2:apply (IHG H3 H2). reach1_step.
apply step_move. apply move_beside. left. split. apply (proj2 (H _ H1)). apply (proj1 (H _ H3)). Qed.
Definition brick_air s w b a := exists r1 r2, length r1 = s /\ b = r1++(repeat brick w)++r2 /\
a = r1++(repeat air w)++r2.
Lemma ev_app {A g1 g2 r1 r2 x y} {a d:A}: length g1 = y -> length r1 = x
-> evg d (g1++(r1++a::r2)::g2) (x,y) = a.
intros Hy Hx. unfold evg. simpl. rewrite (nth_hd Hy). simpl. rewrite (nth_hd Hx). split. Qed.
Lemma nth_app1 {A n p q} {a b d:A}: length p = n \/ nth n (p++a::q) d = nth n (p++b::q) d.
revert n. induction p; intros [|n]; try tauto. destruct (IHp n) as [H|H]. left. apply (f_equal _ H). right.
simpl. rewrite H. split. Qed.
Lemma set_app {A x y g1 g2 r1 r2} {a b d:A}: length g1 = y -> length r1 = x ->
setg (x,y) d a (g1++(r1++b::r2)::g2) (g1++(r1++a::r2)::g2).
intros Hy Hx. split. apply (ev_app Hy Hx). intros [z w]. unfold evg. simpl. epose proof nth_app1 as [H|H].
2:rewrite H;right;split. repeat (rewrite (nth_hd H)). simpl. epose proof nth_app1 as [G|G]. 2:right;apply G.
left. rewrite <- Hx. rewrite <- Hy. rewrite <- H. rewrite <- G. split. Qed.
Lemma brick_support {g p}: ev g (below p) = brick -> supported g p. right. left. right. apply H. Qed.
Lemma ev_app0 {g1 g2 r x y}: length g1 = y -> ev (g1++r::g2) (x,y) = nth x r stone.
intros Hy. unfold ev. unfold evg. simpl. rewrite nth_hd. split. apply Hy. Qed.
Lemma ev_app1 {g1 g2 r1 r2 x y}: length g1 = y -> ev (g1++r1::r2::g2) (below (x,y)) = nth x r2 stone.
intros Hy. rewrite nxt. simpl. apply (ev_app0 (len1 Hy)). Qed.
Lemma stripr {y g1 g2 r a b} s w: length g1 = y -> brick_air s w b a -> supported (g1++r::b::g2) (w+s,y)
-> forr s (S w) r is_empty -> reach1 (s,y,g1++r::b::g2) (w+s,y,g1++r::a::g2).
intros Hy [r1 [r2 [Hs [Hb Ha]]]]. rewrite Ha. rewrite Hb. clear Ha Hb. revert r1 s Hs. induction w;
intros r1 s Hs Hw1 E. apply reach1_refl. simpl.
eassert (forall x r3 h, ev (g1++r::(r1++r3)::h) (below(x+s,y))=_) as E1. intros x r3 h. rewrite (ev_app1 Hy).
apply (app1 Hs). eenough _ as Hb. eapply reach1_trans. eapply reach1_trans; reach1_step. apply step_move.
apply move_beside. right. split. apply brick_support. apply Hb. rewrite (ev_app0 Hy). apply (E 1).
repeat (apply Le.le_n_S). apply Le.le_0_n. eapply (step_destroy _ (_,_)). left. 1,2:split. rewrite (ev_app0 Hy).
apply (E 0). repeat (apply Le.le_n_S). apply Le.le_0_n. apply Hb. destruct w. apply Hw1. apply brick_support.
rewrite (E1 1). split. rewrite nxt. simpl. apply set_app. apply (len1 Hy). apply Hs. rewrite <- app_assoc. simpl.
rewrite <- add_succ_r. repeat (rewrite (nxt r1 (_++r2))). apply IHw. apply (len1 Hs). rewrite add_succ_r.
destruct Hw1 as [Hw1|Hw1]. left. revert Hw1. repeat (rewrite (ev_app0 Hy)). tauto. right. rewrite <- app_assoc.
revert Hw1. simpl. repeat (rewrite (E1 (S w))). simpl. tauto. apply (proj2 (forS E)). rewrite (E1 0). split. Qed.
Lemma nth_repeat1 {s w x t r1 r2}: length r1 = s -> x < w -> nth (x+s) (r1++(repeat t w)++r2) stone = t.
intros Hs Hx. erewrite (app2 Hs (repeat_length _ _) Hx). apply nth_repeat. Qed.
Lemma drill_row_brick {s w b a}: drill_row s w b = Some (Some a) -> brick_air s w b a /\
forr s (S w) b (Logic.eq brick) /\ forr s w a is_empty /\ nth (w+s) a stone = brick.
unfold drill_row. destruct (splitn _ _) as [[r1 rr]|] eqn:E. apply splitn_app in E.
destruct (splitn _ _) as [[r2 r3]|] eqn:F. apply splitn_app in F. destruct (forallb _ _) eqn:G.
2: destruct (forallb _ r2). all:intros H; inversion H. rewrite forallb_forall in G. eassert _ as H3.
eapply G. left. split. rewrite <- tile_dec in H3. eassert (r2=_) as H2. eapply Forall_eq_repeat.
rewrite Forall_forall. intros x Hx. rewrite tile_dec. apply G. right. apply Hx. rewrite (proj2 E).
rewrite (proj2 F). rewrite H2. rewrite (proj1 F). eassert (forall t,_=nth _ (r1++repeat t w++r3) _) as B.
intros t. rewrite app_assoc. rewrite nth_hd. apply H3. rewrite app_length. rewrite repeat_length. split.
rewrite <- (proj1 E). repeat eexists. 1,2:intros x Hx. inversion Hx. rewrite add_comm. apply B. symmetry.
apply (nth_repeat1 (eq_refl _) H4). rewrite (nth_repeat1 (eq_refl _) Hx). apply air_empty.
rewrite add_comm. symmetry. apply B. Qed.
Lemma drill1 {g1 g2 b a r x y w}: length g1=y -> drill_row x w b = Some (Some a) ->
forr x (S w) r is_empty -> w>0 -> (w=1 \/ forr x w (hd [] g2) (Logic.eq brick)) ->
reach1 (x,y,g1++r::b::g2) (x,S y,g1++r::a::g2).
intros Hy Hd E W B2. destruct (drill_row_brick Hd) as [Hab [B1 [A A1]]]. eapply reach1_trans.
apply (stripr _ _ Hy Hab). apply brick_support. rewrite (ev_app1 Hy). symmetry. apply B1. constructor. apply E.
destruct w. inversion W. eapply reach1_trans. eapply reach1_trans; reach1_step; eapply (step_move (_,_)).
apply move_beside. left. split. apply brick_support. rewrite (ev_app1 Hy). apply A1. rewrite (ev_app0 Hy).
apply E. apply le_succ_diag_r. apply move_down. split. rewrite (ev_app1 Hy). apply A. constructor.
destruct w. apply reach1_refl. destruct B2 as [B2|B2]. inversion B2. eapply (movei x (S w) 0). 2:constructor.
intros z Hz. split. replace (z+x,S y) with (below(z+x,y)). rewrite (ev_app1 Hy). apply (A z Hz). split.
apply brick_support. rewrite nxt. rewrite (nxt _ g2). unfold ev. unfold evg. rewrite nth_hd. symmetry.
apply (B2 z Hz). apply len1. apply (len1 Hy). apply Le.le_n_S. apply Le.le_0_n. Qed.
Lemma drill_row_empty {s w r}: drill_row s w r = Some None -> forr s w r is_empty.
unfold drill_row. destruct (splitn _ _) as [[r1 rr]|] eqn:E. apply splitn_app in E.
destruct (splitn _ _) as [[r2 r3]|] eqn:F. apply splitn_app in F. destruct (forallb _ _).
2:destruct (forallb _ r2) eqn:G. all:intros H;inversion H. rewrite (proj2 E). rewrite (proj2 F). intros x Hx.
erewrite (app2 (proj1 E) (proj1 F) Hx). rewrite empty_equiv. rewrite forallb_forall in G. apply G. apply nth_In.
rewrite (proj1 F). apply Hx. Unshelve. apply air. Qed.
Lemma drill2 {x y w b g h k}: drill_top x w b h = Some (k,y) -> (w=1 \/ forr x w (hd [] g) (Logic.eq brick)) ->
w>0 -> exists a r, k=a++r::h /\ reach1 (x,y,(rev b)++g) (x,length a,a++r::g) /\ forr x w r is_empty.
revert w g h k. induction b; intros w g h k. 2:simpl; destruct (drill_row _ _ _) as [[r1|]|] eqn:E.
all:intros H Hb Hw; inversion H. destruct (drill_row_brick E) as [_ [Hb1 [He1 _]]].
epose proof (IHb _ (a::g) _ _ H _ _) as [l [r [Hk [Hr He]]]]. exists (l++[r]). exists r1.
repeat (rewrite <- app_assoc). repeat split. apply Hk. eapply reach1_trans. apply Hr. rewrite app_length.
rewrite add_comm. simpl. apply (drill1 (eq_refl _) E He Hw Hb). apply He1. exists (rev b). exists a.
rewrite rev_append_rev. repeat split. rewrite <- app_assoc. rewrite rev_length. apply reach1_refl.
apply (drill_row_empty E). Unshelve. right. apply Hb1. constructor. apply Hw. Qed.
Lemma drill_length {x y w b h k}: drill_top x w b h = Some (k,y) -> length h + length b = length k.
revert w h. induction b; intros w h. 2:simpl; destruct (drill_row _ _ _) as [[r1|]|] eqn:E.
all:intros H; inversion H. rewrite <- (IHb _ _ H). rewrite add_succ_r. split. rewrite rev_append_rev.
rewrite app_length. rewrite rev_length. rewrite add_comm. simpl. rewrite add_succ_r. split. Qed.
Lemma drill q g p: match drill_helper q g p with | Some h => reach1 (p,g) (q,h) | _ => True end.
destruct q as [x y]. unfold drill_helper. destruct (splitn _ _) as [[b h]|] eqn:E.
destruct (drill_top _ _ _ _) as [[a z]|] eqn:F. destruct (reachb _ _ _) eqn:G. apply splitn_app in E.
epose proof (drill2 F _ _) as [k [r [Hk [Hr _]]]]. eapply reach1_trans. apply reach_pos1.
apply (reachb_correct _ G). rewrite (proj2 E). rewrite Hk. rewrite <- app_assoc. replace y with (length k).
rewrite rev_involutive in Hr. apply Hr. apply drill_length in F. rewrite rev_length in F. rewrite Hk in F.
rewrite (proj1 E) in F. rewrite app_length in F. simpl in F. rewrite add_comm in F. inversion F. all:split.
Unshelve. left. split. constructor. Qed.
Fixpoint ind_helper {A} (f:A->bool) l n := match l with | [] => None
| a::l => if (f a) then Some n else ind_helper f l (S n) end.
Definition ind {A} (f:A->bool) l := ind_helper f l 0.
Definition striph0 s w r := match (splitn s r) with | None => None | Some (r1,r2) =>
match (splitn w r2) with | None => None | Some (r3,r4) =>
if forallb emptyb r3 then ind holdableb r3 else None end end.
Definition striph1 s w r := match (splitn s r) with | None => None | Some (r1,r2) =>
match (splitn w r2) with | None => None | Some (r3,r4) =>
if forallb (tile_beq brick) r3 then Some(r1++repeat air w++r4) else None end end.
Definition striph p s w y g := match (splitn y g) with
| Some (g1,r0::r1::g2) => match (striph0 s w r0,striph1 s w r1) with
| (Some x,Some a) => if (reachb g p (x+s,y) && (1<?w))%bool then Some (x+s,g1++r0::a::g2) else None
| _ => None end
| _ => None end.
Lemma ind_helper_nth {A f n m l} {a:A}: ind_helper f l n = Some m -> exists k, m=n+k /\ k < length l /\
f (nth k l a) = true.
revert n. induction l; intros n; simpl. 2:destruct (f _) eqn:E. all:intros H. 1,2:inversion H. repeat eexists.
apply plus_n_O. apply Le.le_n_S. apply Le.le_0_n. apply E. destruct (IHl _ H) as [k [Hm [Hk Hf]]]. exists (S k).
rewrite add_succ_r. repeat split. apply Hm. apply Le.le_n_S. apply Hk. apply Hf. Qed.
Lemma ind_nth {A f m l} {a:A}: ind f l = Some m -> m < length l /\ f (nth m l a) = true.
intros H. epose proof (ind_helper_nth H) as [k [Hm G]]. rewrite Hm. apply G. Qed.
Lemma striph0_suff {s w x r}: striph0 s w r = Some x -> forr s w r is_empty /\ x < w /\
is_holdable (nth (x+s) r stone).
unfold striph0. destruct (splitn _ _) as [[r1 r2]|] eqn:E. apply splitn_app in E.
destruct (splitn _ _) as [[r3 r4]|] eqn:F. apply splitn_app in F. destruct (forallb _ _) eqn:G. all:intros H.
2,3,4:inversion H. eapply ind_nth in H. rewrite (proj2 E). rewrite (proj2 F). split. intros u Hu.
erewrite (app2 (proj1 E) (proj1 F) Hu). rewrite empty_equiv. rewrite forallb_forall in G. apply G. apply nth_In.
rewrite (proj1 F). apply Hu. apply proj1 in F. rewrite F in H. erewrite (app2 (proj1 E) F (proj1 H)).
rewrite holdable_equiv. apply H. Unshelve. all: apply air. Qed.
Lemma striph1_suff {s w a b}: striph1 s w b = Some a -> brick_air s w b a.
unfold striph1. destruct (splitn _ _) as [[r1 r2]|] eqn:E. apply splitn_app in E.
destruct (splitn _ _) as [[r3 r4]|] eqn:F. apply splitn_app in F. destruct (forallb _ _) eqn:G. all:intros H;
inversion H. rewrite (proj2 E). rewrite (proj2 F). rewrite forallb_forall in G. eassert (r3=_) as H2.
eapply Forall_eq_repeat. rewrite Forall_forall. intros t Ht. rewrite tile_dec. apply (G _ Ht). rewrite H2.
rewrite (proj1 F). repeat eexists. apply (proj1 E). Qed.
Lemma stripl {y g1 g2 r a b} s w: length g1 = y -> brick_air (S s) w b a -> supported (g1++r::b::g2) (s,y)
-> forr s (S w) r is_empty -> reach1 (w+s,y,g1++r::b::g2) (s,y,g1++r::a::g2).
intros Hy [r1 [r2 [Hs [Hb Ha]]]]. rewrite Ha. rewrite Hb. clear Ha Hb. revert r1 s Hs. induction w;
intros r1 s Hs H0 E. apply reach1_refl. simpl. eapply reach1_trans. rewrite (nxt r1). rewrite <- add_succ_r.
apply IHw. apply (len1 Hs). apply brick_support. rewrite (ev_app1 Hy). 1,3:rewrite <- nxt. rewrite (nth_hd Hs).
split. eenough _ as B. eapply reach1_trans; reach1_step. eapply (step_move _ (_,_)). apply move_beside.
left. split. apply brick_support. apply B. rewrite (ev_app0 Hy). apply (E 0). apply lt_0_succ.
eapply step_destroy. right. split. split. rewrite (ev_app0 Hy). apply (E 1). apply Le.le_n_S. apply lt_0_succ.
apply B. destruct H0 as [H0|H0]. left. revert H0. repeat (rewrite (ev_app0 Hy)). tauto. right. revert H0.
repeat (rewrite (ev_app1 Hy)). eassert (forall q, nth s (r1++q) _=nth s r1 _) as T. intros q. apply app_nth1.
rewrite Hs. constructor. repeat (rewrite T). tauto. simpl. repeat (rewrite (nxt g1 (_::g2))). apply set_app.
apply (len1 Hy). apply Hs. rewrite (ev_app1 Hy). rewrite (nth_hd Hs). split. apply (proj2 (forS E)). Qed.
Lemma strip s w y g p: match striph p s w y g with | Some (z,h) => reach1 (p,g) (z,y,h) | _ => True end.
unfold striph. destruct (splitn _ _) as [[g1 [|r0 [|b g2]]]|] eqn:Hy; try split. apply splitn_app in Hy.
destruct (striph0 _ _ _) as [x|] eqn:F. apply striph0_suff in F. destruct F as [E Hx].
destruct (striph1 _ _ _) as [a|] eqn:G. apply striph1_suff in G. rewrite (proj2 Hy). apply proj1 in Hy.
destruct (reachb _ _ _) eqn:R. destruct (1<?w) eqn:W. all:try split. simpl. eapply reach1_trans.
apply reach_pos1. apply (reachb_correct _ R). destruct w as [|[|w]]; inversion W. apply ltb_lt in W.
destruct G as [r1 [r2 [Hs [Hb Ha]]]]. rewrite Hb. rewrite Ha. eassert (forall h, supported (g1++r0::h) _) as Hh.
intros h. left. erewrite (ev_app0 Hy). apply (proj2 Hx). apply proj1 in Hx. eassert (x<=_) as Hx1. apply le_S.
apply Le.le_S_n. apply Hx. eassert (forall z h, z<_ -> is_empty (ev (g1++r0::h) _)) as He. intros z h Hz.
erewrite (ev_app0 Hy). apply (E _ Hz). destruct x. eenough _ as Hb0. eapply reach1_trans. reach1_step.
apply step_move. apply move_beside. right. split. apply brick_support. apply Hb0. apply (He 1). apply W.
eapply reach1_trans. reach1_step. eapply (step_destroy _ (_,_)). left. split. split. apply (He 0).
apply lt_0_succ. apply Hb0. apply brick_support. rewrite (ev_app1 Hy). rewrite nxt. rewrite nth_hd. split.
apply (len1 Hs). rewrite nxt. apply (set_app (len1 Hy) Hs). rewrite <- nxt. eapply reach1_trans.
eapply (movei (S s) 0 w). 3:constructor. intros z Hz. split. rewrite add_succ_r. apply (He (S z)).
apply Le.le_n_S. apply Hz. apply brick_support. rewrite (ev_app1 Hy). rewrite nxt.
replace (brick::_++r2) with (repeat brick (S w)++r2). erewrite app2. apply nth_repeat. apply (len1 Hs).
apply repeat_length. apply Hz. split. apply lt_0_succ. rewrite add_succ_r. apply (stripl s (S w) Hy). simpl.
exists (r1++[air]). eexists. repeat (rewrite <- nxt). repeat split. apply (len1 Hs). apply Hh. apply E.
rewrite (ev_app1 Hy). rewrite (nth_hd Hs). split. eenough _ as Hsp. eassert _ as Hwx1.
apply Minus.le_plus_minus_r. apply Le.le_S_n. apply Hx1. eassert (S(S w)=_) as Hwx. rewrite <- Hwx1. symmetry.
apply add_succ_l. eapply reach1_trans. eapply (movei s (S x) (S w)). 3: constructor. intros z Hz. split.
apply He. apply Hz. apply (Hsp z Hz). apply Hx. eapply reach1_trans. erewrite (_:S w+s=_).
eapply (stripl (x+s) (S w-x)). apply Hy. rewrite Hwx. rewrite repeat_app. rewrite <- app_assoc.
rewrite app_assoc. repeat eexists. rewrite app_length. rewrite repeat_length. rewrite Hs. rewrite add_comm.
apply add_succ_l. apply Hsp. eapply le_trans. 2:apply Hx. apply le_succ_diag_r. intros z Hz. rewrite add_assoc.
apply E. rewrite <- Hwx1. rewrite add_comm. rewrite <- add_succ_r. apply Plus.plus_lt_compat_l. apply Hz.
eapply reach1_trans. eapply (movei s x 0). 2:constructor. intros z Hz. split. apply He. eapply le_trans.
apply Hz. apply Hx1. rewrite <- app_assoc. apply brick_support. rewrite (ev_app1 Hy). erewrite (app2 Hs _ Hz).
apply nth_repeat. apply lt_0_succ. apply (stripr s (S x) Hy). rewrite Hwx. rewrite repeat_app.
repeat (rewrite <- app_assoc). repeat eexists. apply Hs. apply Hh. intros z Hz. apply E. eapply le_trans.
apply Hz. apply Hx. Unshelve. intros z Hz. apply brick_support. rewrite (ev_app1 Hy).
erewrite (app2 Hs (repeat_length _ _) Hz). apply nth_repeat. rewrite add_assoc. rewrite (add_comm _ x).
rewrite Hwx1. split. apply repeat_length. Qed.
End Drill.
Ltac display := lazymatch goal with
| |- can_reach_any ?g ?p ?q =>
let s := eval compute in (PP.print_tiles g) in idtac s end.
Lemma init g {p q}: can_reach_any g p q -> can_reach_pos g p q.
intros H. destruct (H []) as [d [h H1]]. repeat eexists. apply H1. Qed.
Ltac init := lazymatch goal with
| |- can_reach_pos ?g _ _ => apply (init g) end.
Lemma helper {g p t q h}: reach1 (p,g) (q,h) -> can_reach_any h q t -> can_reach_any g p t.
intros H1 H2 d. epose proof (H1 d) as [e H3]. epose proof (H2 e) as [f [? H4]]. repeat eexists.
eapply rt_trans. apply H3. apply H4. Qed.
Ltac helper f := lazymatch goal with
| |- can_reach_any ?g ?p _ => let H := fresh in (
pose proof (f g p) as H; compute in H; apply (helper H); clear H) end.
Ltac mv q := helper (mv q).
Ltac dl r := helper (destroy r beside_right).
Ltac dr r := helper (destroy r beside_left).
Ltac drill q := helper (drill q).
Ltac strip s w h := helper (strip s w h).
Lemma done g p q: reachb g p q = true -> can_reach_any g p q.
intros H d. exists d. exists g. apply (reachb_correct _ H). Qed.
Ltac done := lazymatch goal with
| |- can_reach_any ?g ?p ?q => apply (done g p q (Logic.eq_refl true)) end.
End Pos.
Fixpoint consec {A} P (l:list A) := match l with
| a::((b::t) as m) => (P a b) /\ consec P m
| _ => True end.
Definition hasfirst {A} P (l:list A):Prop := match l with | [] => False | a::_ => P a end.
Lemma consec1 {A P} {l m:list A}: consec P (l++m) -> consec P l /\ consec P m.
induction l. simpl. tauto. destruct l. destruct m; repeat split. apply (proj2 H). intros [G H]. repeat split;
tauto. Qed.
Lemma consec2 {A P l m} {a:A}: consec P (a::m) -> consec P (l++[a]) -> consec P (l++a::m).
destruct m. tauto. intros [H M]. induction l. intros _. apply (conj H M). destruct l. intros [G _]. split.
apply G. apply IHl. split. intros [G C]. split. apply G. apply IHl. apply C. Qed.
Module Neg.
Definition reach1 s p := exists t, can_reach s t /\ sp t = p.
Definition desc (P:state->Prop) s := forall t, can_reach s t -> P t.
Definition inv (P:state->Prop) := forall s t, step s t -> P s -> P t.
Definition rinv (P Q:state->Prop) := forall s t, step s t -> P s -> Q s -> Q t.
Lemma desc_inv {P}: inv (desc P).
intros s t H D u R. apply D. eapply rt_trans. eapply rt_step. apply H. apply R. Qed.
Lemma inv1 {P s t}: inv P -> can_reach s t -> P s -> P t. intros H R Ps. revert t R.
apply clos_refl_trans_ind_left. apply Ps. intros ? ? _ P1 Hs. apply (H _ _ Hs P1). Qed.
Definition frontier (P Q:state->Prop) := forall s t, step s t -> P s -> (P t \/ Q t).
Definition fronts s P Q := P s /\ frontier P Q.
Definition andp {A} P Q (a:A) := P a /\ Q a.
Definition orp {A} P Q (a:A) := P a \/ Q a.
Lemma refs {P Q R s}: rinv P R -> R s -> fronts s P Q -> fronts s (andp P R) (andp Q R).
intros I Rs [Ps F]. repeat split; try assumption. intros t u K [Pt Rt]. pose proof (I _ _ K Pt Rt).
pose proof (F _ _ K Pt). unfold andp. tauto. Qed.
Definition implp {A} (P Q:A->Prop) := forall a, P a -> Q a.
Lemma impl_rinv {P Q R}: rinv Q R -> implp P Q -> rinv P R.
intros QR I s t H Ps Rs. apply (QR s t H (I _ Ps) Rs). Qed.
Lemma fronts_reach {P Q s t}: fronts s P Q -> can_reach s t ->
P t \/ exists u, can_reach s u /\ can_reach u t /\ Q u.
intros [Ps F]. revert t. apply clos_refl_trans_ind_left. tauto. intros t u ST [Pt|[v [SV [VT Qv]]]] TU.
destruct (F _ _ TU Pt) as [Pu|Qu]. tauto. right. exists u. repeat split. eapply rt_trans. apply ST.
apply rt_step. apply TU. apply rt_refl. tauto. right. exists v. repeat split; try assumption. eapply rt_trans.
apply VT. apply rt_step. apply TU. Qed.
Lemma applyf {P Q s p}: fronts s P Q -> reach1 s p -> exists t, can_reach s t /\ ((P t /\ sp t = p) \/
(Q t /\ reach1 t p)).
intros F [t [R T]]. pose proof (fronts_reach F R) as [Pt|[u[SU[UT Qu]]]]. exists t. tauto. exists u.
assert (reach1 u p). exists t. all:tauto. Qed.
Inductive tilep := | is: tile -> tilep | qm.
Inductive tilem (destroyed:Prop): tilep -> tile -> Prop :=
| matchis t: ~destroyed -> tilem destroyed (is t) t
| matchb: ~destroyed -> tilem destroyed qm brick
| matcha: destroyed -> tilem destroyed qm air.
Definition tilems t p s := (tilem (In p (sd s)) t (ev (sg s) p)).
Definition free s := is_empty (ev (sg s) (sp s)).
Definition validd s := NoDup (sd s) /\ forall p, In p (sd s) -> ev (sg s) p = air.
Definition evp := evg (is stone).
Definition gridm gp ps s := In (sp s) ps /\ (forall p, tilems (evp gp p) p s) /\ free s /\ validd s.
Lemma gridm_app g p q s: gridm g (p++q) s <-> gridm g p s \/ gridm g q s.
unfold gridm. rewrite in_app_iff. tauto. Qed.
Lemma grid_map_ev {A B} (f:A->B) g p a: evg (f a) (grid_map f g) p = f (evg a g p).
unfold evg. unfold grid_map. erewrite (_:[]=_). rewrite map_nth. apply map_nth. Unshelve. split. Qed.
Lemma init g p {q}: emptyb (ev g p) = true -> can_reach_pos g p q ->
exists s, reach1 s q /\ (gridm (grid_map is g) [p] s).
intros E [d [h H]]. repeat eexists. apply H. split. left. split. intros r. unfold evp. rewrite grid_map_ev.
apply matchis. intros []. unfold free. rewrite empty_equiv. apply E. constructor. intros ? []. Qed.
Definition tilep_to_ascii t := match t with | is t => PP.tile_to_ascii t | _ => "?"%char end.
Definition print_gp gp := PP.print_grid (grid_map tilep_to_ascii gp).
Lemma notthere {g ps s p}: gridm g ps s -> sp s = p -> poss_mem p ps = false -> False.
intros [M] P. rewrite P in M. unfold poss_mem. rewrite ListSet.set_mem_correct2. apply Bool.diff_true_false.
apply M. Qed.
Ltac init := lazymatch goal with
| |- ~can_reach_pos ?g ?p ?q => let H := fresh in (
intros H; apply (init g p (Logic.eq_refl _)) in H; destruct H as [? [? ?]]) end.
Ltac display := lazymatch goal with
| [ _:reach1 ?s _ , _:gridm ?g ?ps ?s |- False ] =>
let s := eval compute in (print_gp g) in idtac s; idtac ps end.
Ltac applyf :=
let splitp := repeat (match goal with
| [H:andp _ _ _ |- _] => destruct H as [??]
| [H:orp _ _ _ |- _] => destruct H as [?|?] end) in
let clears s := repeat (match goal with
| [H:desc ?P s, R:can_reach s ?t |- _] => apply (inv1 desc_inv R) in H end); clear dependent s in
let notthere := try (match goal with
| [M:gridm _ ?ps ?s, P:(sp ?s) = ?q |- False] => apply (notthere M P (Logic.eq_refl false)) end) in
lazymatch goal with
| [R:reach1 ?s _, F:fronts ?s _ _ |- False] =>
destruct (applyf F R) as [?[?[[??]|[??]]]]; clears s; splitp; notthere end.
Definition up (p:position) := match p with | (x,y) => (x,pred y) end.
Definition candestroy s p := snd p > 0 /\ beside (sp s) (up p) /\ supported (sg s) (sp s) /\
is_empty (ev (sg s) (up p)).
Lemma candestroy1 {s pb} ps: beside (sp s) ps -> above ps pb -> supported (sg s) (sp s) ->
is_empty (ev (sg s) ps) -> candestroy s pb.
unfold candestroy. destruct ps as [u v]. intros B A Q E. rewrite A. split. apply lt_0_succ. tauto. Qed.
Lemma setgneq {A p q g h} {a b:A}: setg p a b g h -> p <> q -> evg a h q = evg a g q.
intros H P. destruct (proj2 H q) as [E|E]. symmetry in E. destruct (P E). apply E. Qed.
Lemma setneq {p q t g h}: set p t g h -> p <> q -> ev h q = ev g q.
intros H P. destruct (proj2 H q) as [E|E]. symmetry in E. destruct (P E). apply E. Qed.
Lemma stepev {s t} p: step s t -> (ev (sg t) p = ev (sg s) p /\ (In p (sd s) <-> In p (sd t))) \/
(ev (sg t) p = brick /\ (sp s) <> p /\ sd s = (sd t)++[p]) \/
(ev (sg s) p = brick /\ ev (sg t) p = air /\ candestroy s p /\ sd t = p::sd s).
intros H. inversion H; simpl. tauto. destruct (PosDec.eq_dec pb p) as [E|E]; unfold PosDec.eq in E. right. right.
rewrite <- E. apply proj1 in H5. set (candestroy _ _) as C. enough C. tauto. apply (candestroy1 ps); assumption.
rewrite (setneq H5 E). tauto. destruct (PosDec.eq_dec q p) as [E|E]; unfold PosDec.eq in E. right. left.
rewrite <- E. repeat split; try tauto. apply (proj1 H1). rewrite (setneq H1 E). rewrite in_app_iff. simpl. tauto.
Qed.
Lemma solidinv {s t p}: step s t -> is_solid (ev (sg s) p) -> is_solid (ev (sg t) p) \/
(candestroy s p /\ sd t = p::sd s).
intros H B. destruct (stepev p H) as [[E _]|[[E _]|E]]; try (rewrite E). 2:unfold is_solid. all:tauto. Qed.
Lemma steppos {s t}: step s t -> (move (sg s) (sp s) (sp t) /\ free t /\ sg t = sg s /\ sd t = sd s) \/
sp t = sp s. intros H. inversion H; tauto. Qed.
Lemma freeinv: inv free.
unfold free. intros s t H F. destruct (steppos H) as [[_ [G]]|P]. tauto. rewrite P. destruct (stepev (sp s) H)
as [[E]|[[_[E]]|[_[E]]]]; try rewrite E. tauto. destruct E. split. apply air_empty. Qed.
Lemma validdinv: inv validd.
unfold validd. intros [? ? ?] t H. inversion H; simpl; intros [D A]. tauto. split. constructor. intros E.
apply (A _) in E. rewrite E in H6. inversion H6. apply D. intros q [Q|Q]. rewrite <- Q. apply (proj1 H9).
destruct (proj2 H9 q) as [E|E]. rewrite E. apply (proj1 H9). rewrite E. apply (A _ Q). apply NoDup_remove in D.
rewrite app_nil_r in D. split. tauto. intros r R. destruct (proj2 H5 r) as [E|E]. rewrite E in R. tauto.
rewrite E. apply A. rewrite in_app_iff. tauto. Qed.
Lemma tilem_iff {P Q tp t} (H:P <-> Q): tilem P tp t -> tilem Q tp t.
intros M. inversion M; constructor; tauto. Qed.
Lemma qminv {p}: rinv validd (tilems qm p).
unfold tilems. intros s t H [V] M. destruct (stepev p H) as [[E D]|[[E[_ D]]|[_[E[_ D]]]]]; rewrite E.
apply (tilem_iff D M). rewrite D in V. apply NoDup_remove in V. rewrite app_nil_r in V. apply matchb. tauto.
apply matcha. rewrite D. left. split. Qed.
Section Expand.
Definition emptybp t := match t with | is t => emptyb t | _ => true end.
Definition supportingbp t := match t with | is t => supportingb t | _ => true end.
Definition holdablebp t := match t with | is t => holdableb t | _ => false end.
Definition supportedbp g p := ((holdablebp (evp g p)) || (supportingbp (evp g (below p))))%bool.
Definition brickbp t := match t with | is brick => true | _ => false end.
Definition ladderbp t := match t with | is ladder => true | _ => false end.
Definition qmbp t := match t with | qm => true | _ => false end.
Definition notholdableb t := negb (holdablebp t).
Definition adj p q := match (p,q) with | ((x,y),(z,w)) =>
(((x=?z)&&((y=?S w)||(w=?S y)))||((y=?w)&&((z=?S x)||(x=?S z))))%bool end.
Definition ft pr g l := filter (fun p => pr (evp g p)) l.
Definition fe := ft emptybp.
Definition prenh g p := if supportedbp g p then (S(fst p),snd p)::(
if 0<?fst p then [(pred(fst p),snd p)] else []) else [].
Definition prenv g p := (below p)::(if (ladderbp (evp g p)&&(0<?snd p))%bool then [(fst p,pred(snd p))] else []).
Definition neighbors g p := let (nh,nv) := (fe g (prenh g p),fe g (prenv g p)) in
let d := ft brickbp g (map below nh) in (d,nh++nv).
Definition destroyall g l := fold_right (fun p h => replaceg p qm h) g l.
Definition expand_step b goc := match goc with
| (g,[],c) => (goc,Some (g,c))
| (g,p::o,c) => if poss_mem p b then (g,o,c,None) else let (d,n) := neighbors g p in
let (c1,c2) := partition (fun q => existsb (adj q) d) c in
(destroyall g d, poss_union (poss_diff (n++c1) c2) o, p::c2,None) end.
Definition expand g ps b := while (expand_step b) (g,ps,[]) (5*(grid_size g)).
Definition from (p:position) (l:list position) := map (fun q => (p,q)) l.
Definition expand_step1 b db gocl := match gocl with
| (g,[],c,l) => (gocl,Some (g,c,l))
| (g,p::o,c,l) => if poss_mem p b then (g,o,c,l,None) else let (d,n) := neighbors g p in
let (d1,d2) := partition (fun q => poss_mem q db) d in
let (c1,c2) := partition (fun q => existsb (adj q) d2) c in
(destroyall g d2, poss_union (poss_diff (n++c1) c2) o, p::c2,(from p d1)++l,None) end.
Definition expand1 g ps b db := while (expand_step1 b db) (g,ps,[],[]) (5*(grid_size g)).
Lemma emptym {P t tp}: is_empty t -> tilem P tp t -> emptybp tp = true.
intros H M. inversion M. rewrite empty_equiv in H. apply H. all:split. Qed.
Lemma supportingm {P t tp}: is_supporting t -> tilem P tp t -> supportingbp tp = true.
intros H M. inversion M. rewrite supporting_equiv in H. apply H. all:split. Qed.
Lemma holdablem {P t tp}: is_holdable t -> tilem P tp t -> holdablebp tp = true.
intros H M. rewrite holdable_equiv in H. inversion M. apply H. all:rewrite <- H2 in H; inversion H. Qed.
Lemma supportedm {ps gp s p}: supported (sg s) p -> gridm gp ps s -> supportedbp gp p = true.
unfold supportedbp. intros [H|H] [_ [M]]. rewrite (holdablem H (M _)). split. rewrite (supportingm H (M _)).
apply Bool.orb_true_r. Qed.
Lemma ladderm {ps gp s p}: ev (sg s) p = ladder -> gridm gp ps s -> ladderbp (evp gp p) = true.
intros H [_ [M]]. pose proof (M p) as P. unfold tilems in P. rewrite H in P. inversion P. split. Qed.
Lemma brickbp_equiv {t}: brickbp t = true <-> t = is brick.
destruct t. destruct t0. 3:tauto. all:simpl; split; intros H; inversion H. Qed.
Lemma notholdable_suff {g ps s p}: gridm g ps s -> notholdableb (evp g p) = true -> ~is_holdable (ev (sg s) p).
intros [_[M _]] T H. apply Bool.diff_true_false. rewrite <- T. unfold notholdableb. rewrite Bool.negb_false_iff.
eapply (holdablem H). apply M. Qed.
Lemma destroyall_evp {g l}: (forall p, In p l -> evp g p = is brick) -> forall p, evp (destroyall g l) p =
if (poss_mem p l) then qm else evp g p.
unfold destroyall. unfold evp. induction l. split. simpl. intros B p. epose proof (IHl _) as IH.
epose proof replace_set as [R|R]. rewrite IH in R. rewrite B in R. destruct (poss_mem _ _) in R; inversion R.
left. split. destruct (_ p a) as [E|E]. rewrite E. apply (proj1 R). destruct (proj2 R p) as [P|P].
destruct (E P). rewrite P. apply IH. Unshelve. intros q Q. apply B. tauto. Qed.
Lemma prenh_beside {g p q}: In q (prenh g p) -> beside p q.
unfold prenh. destruct (_:bool). intros [H|H]. right. rewrite <- H. destruct p; split. destruct p as [[|x] y].
destruct H. destruct H as [H|[]]. rewrite <- H. left. split. intros []. Qed.
Lemma pren_adj g {p q}: In q (prenh g p) \/ In q (prenv g p) -> adj p q = true.
unfold adj. unfold prenv. intros [H|[H|H]]. destruct (prenh_beside H) as [E|E]; rewrite E.
destruct q. 2:destruct p. 3:rewrite <- H; destruct p. 4:destruct (_:bool) eqn:E in H. 4:destruct H as [H|[]];
rewrite <- H; destruct p as [x [|y]]. all:simpl;repeat (rewrite eqb_refl); repeat (rewrite Bool.orb_true_r);
try split. rewrite Bool.andb_false_r in E. inversion E. destruct H as []. Qed.
Section Destroy.
Context {g:grid tilep} {p:position} {d d2:list position} {n:list position}.
Hypothesis E: neighbors g p = (d,n).
Hypothesis D: incl d2 d.
Notation h := (destroyall g d2).
Lemma dbrick q: In q d2 -> evp g q = is brick.
intros I. apply D in I. revert I. unfold neighbors in E. inversion E. unfold ft. rewrite filter_In. intros [_ H].
destruct (evp g q) as [t|]. destruct t. 3:split. all:inversion H. Qed.
Lemma evph {q}: (In q d2 /\ evp g q = is brick /\ evp h q = qm) \/ evp h q = evp g q.
unfold h. rewrite (destroyall_evp dbrick). destruct (poss_mem q d2) eqn:M. apply ListSet.set_mem_correct1 in M.
left. repeat split. apply M. apply (dbrick _ M). right. split. Qed.
Lemma dpren {pr q}: pr = prenh \/ pr = prenv -> pr h q = pr g q.
intros [P|P]; rewrite P. unfold prenh. unfold supportedbp. erewrite (_:holdablebp _=_).
erewrite (_:supportingbp _=_). split. unfold prenv. unfold ladderbp. epose proof evph as [[_ [G H]]|H];
rewrite H; try (rewrite G); split. Unshelve. all:epose proof evph as [[_ [G H]]|H]; rewrite H; try (rewrite G);
split. Qed.
Lemma dempty q: ~In q d2 -> emptybp (evp h q) = emptybp (evp g q).
intros Q. epose proof evph as [[H _]|H]. destruct (Q H). rewrite H. split. Qed.
Definition notdadj q := forall r, In r d2 -> adj q r = false.
Lemma dadj: notdadj p.
assert (forall n, n=?S n=false) as F. intros x. rewrite eqb_neq. apply n_Sn. intros r I. apply D in I. revert I.
unfold neighbors in E. inversion E. unfold ft. intros H. apply incl_filter in H. rewrite in_map_iff in H.
destruct H as [q [R Q]]. rewrite <- R. unfold fe in Q. apply incl_filter in Q. unfold adj. unfold below.
destruct (prenh_beside Q) as [B|B]; rewrite B; [destruct q;rewrite eqb_sym|destruct p]; repeat (rewrite F);
split. Qed.
Lemma fgh {pr q}: notdadj q -> pr = prenh \/ pr = prenv -> fe h (pr h q) = fe g (pr g q).
intros R P. rewrite (dpren P). unfold fe. unfold ft. apply filter_ext_in. intros a A. apply dempty. intros I.
apply R in I. erewrite (pren_adj g) in I. inversion I. destruct P as [P|P]; rewrite <- P; tauto. Qed.
Lemma ngh {q e d1 m}: neighbors g q = (e,m) -> notdadj q -> incl e (d1++d2) -> exists e1, incl e1 d1 /\
neighbors h q = (e1,m).
unfold neighbors. intros P Q I. repeat (rewrite (fgh Q)). rewrite pair_equal_spec in P. rewrite (proj2 P).
eexists. repeat split. unfold ft. intros r. rewrite filter_In. rewrite (destroyall_evp dbrick r).
destruct (poss_mem _ _) eqn:M. intros [_ H]. inversion H. apply ListSet.set_mem_complete1 in M. intros [R B].
assert (In r e) as K. rewrite <- (proj1 P). unfold ft. rewrite filter_In. tauto. apply I in K.
rewrite in_app_iff in K. all:tauto. Qed.
Lemma np {d1}: incl d (d1++d2) -> exists e, incl e d1 /\ neighbors h p = (e,n). apply (ngh E dadj). Qed.
End Destroy.
Lemma oc_incl d c {p n o b}: let (c1,c2) := partition (fun q => existsb (adj q) d) c in
incl (n++p::o++c++b) (poss_union (poss_diff (n++c1) c2) o++(p::c2)++b).
destruct (partition _ _) as [c1 c2] eqn:C. intros q. repeat (rewrite in_app_iff). unfold poss_union.
rewrite ListSet.set_union_iff. simpl. unfold poss_diff. rewrite ListSet.set_diff_iff.
repeat (rewrite in_app_iff). rewrite (elements_in_partition _ _ C). assert (In q c2\/~In q c2).
destruct (poss_mem q c2) eqn:H. apply ListSet.set_mem_correct1 in H. 2: apply ListSet.set_mem_complete1 in H.
all:tauto. Qed.
Lemma part_incl {A d d1 d2} {f:A->bool}: partition f d = (d1,d2) -> incl d (d1++d2) /\ incl d2 d.
intros H. split; intros a; pose proof (elements_in_partition _ _ H a); try rewrite (in_app_iff); tauto. Qed.
Lemma from_incl {p d e}: incl d e -> incl (from p d) (from p e).
intros I pq. unfold from. repeat (rewrite in_map_iff). intros [q[P Q]]. apply I in Q. exists q. tauto. Qed.
Lemma partf {A f} {l:list A}: let (_,m) := partition f l in forall a, In a m -> f a = false.
induction l. intros _ []. simpl. destruct (partition f l). destruct (f a) eqn:F. apply IHl. intros x [X|X].
rewrite <- X. apply F. apply (IHl _ X). Qed.
Lemma existsb_false {A f} {l:list A}: existsb f l = false -> forall a, In a l -> f a = false.
induction l. intros _ ? []. simpl. rewrite Bool.orb_false_iff. intros [F H] b [B|B]. rewrite <- B. apply F.
apply (IHl H _ B). Qed.
Definition hasn b gocl := match gocl with | (g,o,c,l) => forall p, In p c -> let (d,n) := neighbors g p in
incl n (o++c++b) /\ incl (from p d) l end.
Lemma hasninv b db gocl: hasn b gocl -> hasn b (fst (expand_step1 b db gocl)).
unfold expand_step1. destruct gocl as [[[g [|r o]] c] l]. tauto. destruct (poss_mem r b) eqn:M.
intros H p Hp. pose proof (H p Hp) as G. destruct (neighbors _ _) as [d n]. split. intros q Hq.
destruct (proj1 G q Hq) as [I|I]. rewrite app_assoc. apply in_or_app. right. eapply ListSet.set_mem_correct1.
rewrite <- I. apply M. apply I. apply (proj2 G). destruct (neighbors _ _) as [d n] eqn:N.
destruct (partition _ _) as [d1 d2] eqn:D. apply part_incl in D. epose proof (oc_incl d2 c) as I.
destruct (partition _ _) as [c1 c2] eqn:C. intros H p [Hp|Hp]. rewrite <- Hp.
pose proof (np N (proj2 D) (proj1 D)) as [e[E N1]]. rewrite N1. split. eapply incl_tran. apply incl_appl.
apply incl_refl. apply I. apply incl_appl. apply (from_incl E). epose proof (H p _) as G.
destruct (neighbors g p) as [e m] eqn:N1. epose proof (ngh N (proj2 D) N1 _ (incl_appl _ _)) as [e1[E N2]].
rewrite N2. split. eapply incl_tran. apply incl_appr. apply (proj1 G). apply I. apply incl_appr.
eapply incl_tran. apply (from_incl E). apply (proj2 G). Unshelve. apply part_incl in C. apply (proj2 C _ Hp).
unfold notdadj. apply existsb_false. epose proof partf as P. rewrite C in P. apply (P _ Hp). apply incl_refl.
Qed.
Lemma prenh_suff {g ps p q s}: gridm g ps s -> beside p q -> supported (sg s) p -> In q (prenh g p).
intros M B H. unfold prenh. rewrite (supportedm H M). destruct B as [E|E]; rewrite E. destruct q. right. left.
split. destruct p. left. split. Qed.
Lemma pren_suff {g ps p q s}: gridm g ps s -> move (sg s) p q -> In q (prenh g p ++ prenv g p).
rewrite in_app_iff. intros M H. inversion H. 1,2:right. rewrite H0. left. split. unfold prenv.
rewrite (ladderm H1 M). rewrite H0. destruct q. right. left. split. left. apply (prenh_suff M H0 H1). Qed.
Definition justdestroyed g p q s := gridm (replaceg q qm g) [p] s /\ candestroy s q /\ is_empty(ev (sg s) q).
Definition jdl g l s := exists p q, In (p,q) l /\ justdestroyed g p q s.
Lemma tilemqm {P tp t}: tilem P tp t -> P -> tp = qm. intros M H. inversion M; tauto. Qed.
Lemma tilemb {P tp t}: t = brick -> tilem P tp t -> tp = is brick \/ tp = qm.
intros H M. rewrite H in M. inversion M; tauto. Qed.
Lemma right_irrefl {p}: ~right p p. destruct p as [x y]. intros P. inversion P. eapply n_Sn. apply H0. Qed.
Lemma beside_irrefl {p}: ~beside p p. intros [P|P]; apply (right_irrefl P). Qed.
Lemma besidey {p q}: beside p q -> snd p = snd q.
intros [E|E]; rewrite E. destruct q as [? ?]. split. destruct p as [? ?]. split. Qed.
Lemma upbelow {p}: up(below p) = p. destruct p; split. Qed.
Lemma setgeq {A p g} {a:A}: setg p a (evg a g p) g g. repeat split. intros q. tauto. Qed.
Lemma tilemsset {p a b g h s t}: (forall q, tilems (evp g q) q s) -> setg p (is stone) a g h ->
set p b (sg s) (sg t) -> (forall q, p<>q -> (In q (sd s) <-> In q (sd t))) ->
tilem (In p (sd t)) a b -> forall q, tilems (evp h q) q t.
intros T H L I P q. unfold tilems. unfold evp. destruct (PosDec.eq_dec p q) as [E|E]; unfold PosDec.eq in E.
rewrite <- E. rewrite (proj1 H). rewrite (proj1 L). apply P. rewrite (setgneq H E). rewrite (setneq L E).
eapply tilem_iff. apply (I q E). apply T. Qed.
Lemma nsuff {g p d n}: neighbors g p = (d,n) -> frontier (gridm g [p]) (orp (gridm g n) (jdl g (from p d))).
unfold neighbors. unfold fe. unfold ft. rewrite <- filter_app. rewrite pair_equal_spec.
intros [D N] [???] t H M. pose proof M as [[P|[]] [T [F V]]]. unfold tilems in T. apply (freeinv _ _ H) in F.
apply (validdinv _ _ H) in V. inversion H. right. left. assert (In q n). rewrite <- N. rewrite filter_In.
split. rewrite P. apply (pren_suff M H4). apply (emptym H5 (T _)). unfold gridm. unfold tilems. simpl.
rewrite H2. tauto. pose proof (tilemb H6 (T _)) as [G|G]. right. right. exists p. exists pb. split. unfold from.
rewrite in_map_iff. eexists. repeat split. rewrite <- D. rewrite filter_In. split. rewrite in_map_iff.
exists ps. rewrite H4. repeat split. rewrite filter_In. split. rewrite P. apply (prenh_suff M H3 H8).
apply (emptym H5 (T _)). rewrite G. split. split. split. simpl. tauto. split. epose proof replace_set as [R|R].
assert (is brick=is stone) as X. rewrite <- G. apply R. inversion X. eapply (tilemsset T R). apply H9. simpl.
tauto. apply matcha. simpl. tauto. rewrite H7. tauto. split. set (_:state) as s in H.
assert (candestroy s pb) as X. apply (candestroy1 ps); simpl; tauto. unfold candestroy. unfold supported. simpl.
repeat (erewrite (setneq H9)). apply X. 1,2,3:rewrite H4. 1,3:destruct ps as [? v]; intros E; apply (n_Sn v).
symmetry. apply (f_equal (@snd _ _) E). rewrite <- E in H3. apply besidey in H3. symmetry. apply H3.
intros E. apply (f_equal up) in E. repeat (rewrite upbelow in E). rewrite E in H3. apply (beside_irrefl H3).
simpl. rewrite (proj1 H9). apply air_empty. left. split. simpl. tauto. split. eapply (tilemsset T setgeq).
apply H9. simpl. tauto. fold evp. rewrite G. apply matcha. simpl. tauto. rewrite H7. tauto. left. split. simpl.
tauto. split. eapply (tilemsset T setgeq). apply H5. rewrite <- H3. intros ?. simpl. rewrite in_app_iff. simpl.
tauto. fold evp. rewrite (tilemqm (T q)). apply matchb. rewrite <- H2 in V. intros X. apply (proj2 V _) in X.
simpl in X. rewrite (proj1 H5) in X. inversion X. rewrite <- H3. simpl. rewrite in_app_iff. simpl. tauto.
rewrite H2. tauto. Qed.
Definition gridme {L} s (gocl:(_*L)) := match gocl with | (g,o,c,_) => gridm g (o++c) s end.
Lemma gridmeinv b db s (B:~In (sp s) b) gocl: gridme s gocl -> gridme s (fst (expand_step1 b db gocl)).
destruct gocl as [[[g [|r o]] c] ?]. unfold expand_step1. tauto. destruct s as [p h d]. unfold gridme.
intros [P [T [F V]]]. unfold expand_step1. destruct (poss_mem r b) eqn:M. simpl. destruct P as [P|P].
destruct B. rewrite <- P. eapply ListSet.set_mem_correct1. apply M. unfold gridm. tauto.
destruct (neighbors g r) as [e n] eqn:N. destruct (partition _ _) as [d1 d2] eqn:D. apply part_incl in D.
epose proof (oc_incl d2 c) as I. destruct (partition _ _) as [c1 c2]. simpl. split.
repeat (rewrite app_nil_r in I). eapply incl_tran. 2:apply I. apply incl_appr. apply incl_refl. apply P. split.
unfold tilems. unfold tilems in T. intros q. simpl. pose proof (T q) as Q. simpl in Q.
epose proof (evph N (proj2 D)) as [[_ [G H]]|G]. rewrite G in Q. inversion Q. rewrite H. apply matchb. apply H2.
rewrite G. apply Q. tauto. Qed.
Lemma expandterm {gocl h qs l b db}: snd(expand_step1 b db gocl)=Some (h, qs, l) -> gocl = (h,[],qs,l).
unfold expand_step1. destruct gocl as [[[g [|r o]] c] ?]. 2:destruct (poss_mem r b). 3:destruct (neighbors _ _);
repeat (destruct (partition _ _)). all:intros H; inversion H. split. Qed.
Lemma gridm_incl {g ps qs s}: incl ps qs -> gridm g ps s -> gridm g qs s.
intros H. pose proof (H (sp s)). unfold gridm. tauto. Qed.
Lemma orpassoc {g p q s P}: gridm g p s \/ (orp (gridm g q) P s) <-> gridm g (p++q) s \/ P s.
unfold orp. rewrite gridm_app. tauto. Qed.
Theorem expandsuff1 {g ps s} h qs l b db: gridm g ps s -> poss_inter ps b = [] ->
expand1 g ps b db = Some (h, qs, l) -> fronts s (gridm h qs) (orp (gridm h b) (jdl h l)).
intros G P H. split. epose proof (while_inv (gridmeinv b db s _) _ H) as [c [C T]]. apply expandterm in T.
rewrite T in C. apply C. epose proof (while_inv (hasninv b db) _ H) as [c [C T]]. apply expandterm in T.
rewrite T in C. intros t u TU M. rewrite orpassoc. pose proof (proj1 M) as Q. pose proof (C (sp t) Q) as CT.
destruct (neighbors h _) as [d n] eqn:N. apply nsuff in N. epose proof (N _ _ TU _) as K.
rewrite orpassoc in K. destruct K as [K|K]. left. eapply gridm_incl. 2:apply K. intros r [R|R]. rewrite <- R.
rewrite in_app_iff. tauto. apply (proj1 CT). apply R. right. destruct K as [p[q[V W]]]. exists p. exists q.
apply (proj2 CT) in V. tauto. Unshelve. intros I. eassert (In _ []) as []. rewrite <- P.
apply ListSet.set_inter_intro. apply (proj1 G). apply I. unfold gridme. rewrite app_nil_r. apply G. intros ? [].
split. simpl. tauto. apply (proj2 M). Qed.
Lemma jdlsplit {g p q l s}: jdl g ((p,q)::l) s -> justdestroyed g p q s \/ jdl g l s.
intros [?[?[[E|E]D]]]. inversion E. tauto. right. eexists. eexists. apply (conj E D). Qed.
Lemma jdlnil {g s}: ~jdl g [] s. intros [?[?[[]]]]. Qed.
Lemma standing {s q g p}: candestroy s q -> gridm g [p] s ->
((notholdableb (evp g p)&&qmbp(evp g (below p)))%bool=true) ->
is_solid (ev (sg s) (below p)) /\ is_empty (ev (sg s) (up q)).
rewrite Bool.andb_true_iff. intros [_[_[H E]]] M [F Q]. pose proof M as [[P|[]] [T _]]. rewrite <- P in H. split.
destruct H as [H|[H|H]]. destruct (notholdable_suff M F H). tauto. pose proof (T(below p)) as K.
unfold tilems in K. rewrite H in K. inversion K. rewrite <- H0 in Q. inversion Q. apply E. Qed.
Lemma part_allf {A f} {l:list A}: (forall a, f a = false) -> partition f l = ([],l).
intros H. induction l. split. simpl. rewrite IHl. rewrite H. split. Qed.
Lemma stepequiv {b goc}: expand_step1 b [] (goc,[]) = let (goc1,res) := expand_step b goc in
((goc1,[]),option_map (fun x => (x,[])) res).
unfold expand_step1. unfold expand_step. destruct goc as [[g [|p o]]c]. split. destruct (poss_mem _ _). split.
destruct (neighbors _ _). rewrite part_allf. destruct (partition _ _). split. split. Qed.
Lemma whileequiv {b goc n}: while (expand_step1 b []) (goc,[]) n =
option_map (fun x => (x,[])) (while (expand_step b) goc n).
revert goc. induction n. split. intros goc. unfold while. rewrite stepequiv. destruct (expand_step b goc) as
[goc1 [res|]]; simpl. split. apply IHn. Qed.
Theorem expandsuff {g ps s} h qs b: gridm g ps s -> poss_inter ps b = [] ->
expand g ps b = Some (h, qs) -> fronts s (gridm h qs) (gridm h b).
unfold expand. intros M I E. epose proof (expandsuff1 h qs [] b [] M I _) as [H F]. split. apply H.
intros t u U T. destruct (F t u U T) as [?|[?|[?[?[[]]]]]]; tauto. Unshelve. unfold expand1. rewrite whileequiv.
rewrite E. split. Qed.
End Expand.
Ltac untilf b := lazymatch goal with
| [ _:reach1 ?s _ , M:gridm ?g ?ps ?s |- False ] =>
lazymatch eval compute in (expand g ps b) with
| Some (?h,?qs) => pose proof (expandsuff h qs b M (Logic.eq_refl _) (Logic.eq_refl _)) end end.
Ltac splitapp := repeat (lazymatch goal with
| [H:gridm _ (_++_) _ |- _] => rewrite gridm_app in H; destruct H as [?|?] end).
Ltac until b := untilf b; applyf; splitapp.
Ltac until1 b db := let applydestroy := try (lazymatch goal with
| [D:candestroy ?s ?q, M:gridm ?g [?p] ?s |- _] => let H := fresh in let K := fresh in
pose proof (standing D M (Logic.eq_refl _)) as [H K]; simpl in H; simpl in K end) in
let jdls := repeat (lazymatch goal with
| [H:jdl _ (_::_) _ |- _] => apply jdlsplit in H; destruct H as [[?[??]]|?]; [applydestroy|idtac]
| [H:jdl _ [] _ |- False] => apply (jdlnil H) end) in
lazymatch goal with | [ _:reach1 ?s _ , M:gridm ?g ?ps ?s |- False ] =>
lazymatch eval compute in (expand1 g ps b db) with | Some (?h,?qs,?l) =>
pose proof (expandsuff1 h qs l b db M (Logic.eq_refl _) (Logic.eq_refl _)); applyf; jdls
end end.
Ltac stuck := until (@nil position); lazymatch goal with
| [M:gridm _ [] ?s |- _] => destruct M as [[]] end.
Section Strip.
Definition hassolid d s := exists p, In p d /\ is_solid (ev (sg s) p).
Definition row x (y:nat) w := map (fun u => (u,y)) (seq x w).
Lemma plusin {x w} u: u < w -> x <= u+x < w+x.