You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

day1.v 4.6KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156
  1. Require Import Coq.Sorting.Mergesort.
  2. Require Import Coq.Lists.List.
  3. Require Import Coq.Program.Wf.
  4. Require Import Coq.Arith.PeanoNat.
  5. Require Import Omega.
  6. Require Import ExtrHaskellBasic.
  7. Definition has_pair (t : nat) (is : list nat) : Prop :=
  8. exists n1 n2 : nat, n1 <> n2 /\ In n1 is /\ In n2 is /\ n1 + n2 = t.
  9. Fixpoint find_matching (is : list nat) (total : nat) (x : nat) : option nat :=
  10. match is with
  11. | nil => None
  12. | cons y ys =>
  13. if Nat.eqb (x + y) total
  14. then Some y
  15. else find_matching ys total x
  16. end.
  17. Fixpoint find_sum (is : list nat) (total : nat) : option (nat * nat) :=
  18. match is with
  19. | nil => None
  20. | cons x xs =>
  21. match find_matching xs total x with
  22. | None => find_sum xs total (* Was buggy! *)
  23. | Some y => Some (x, y)
  24. end
  25. end.
  26. Lemma find_matching_correct : forall is k x y,
  27. find_matching is k x = Some y -> x + y = k.
  28. Proof.
  29. intros is. induction is;
  30. intros k x y Hev.
  31. - simpl in Hev. inversion Hev.
  32. - simpl in Hev. destruct (Nat.eqb (x+a) k) eqn:Heq.
  33. + injection Hev as H; subst.
  34. apply EqNat.beq_nat_eq. auto.
  35. + apply IHis. assumption.
  36. Qed.
  37. Lemma find_matching_skip : forall k x y i is,
  38. find_matching is k x = Some y -> find_matching (cons i is) k x = Some y.
  39. Proof.
  40. intros k x y i is Hsmall.
  41. simpl. destruct (Nat.eqb (x+i) k) eqn:Heq.
  42. - apply find_matching_correct in Hsmall.
  43. symmetry in Heq. apply EqNat.beq_nat_eq in Heq.
  44. assert (i = y). { omega. } rewrite H. reflexivity.
  45. - assumption.
  46. Qed.
  47. Lemma find_matching_works : forall is k x y, In y is /\ x + y = k ->
  48. find_matching is k x = Some y.
  49. Proof.
  50. intros is. induction is;
  51. intros k x y [Hin Heq].
  52. - inversion Hin.
  53. - inversion Hin.
  54. + subst a. simpl. Search Nat.eqb.
  55. destruct (Nat.eqb_spec (x+y) k).
  56. * reflexivity.
  57. * exfalso. apply n. assumption.
  58. + apply find_matching_skip. apply IHis.
  59. split; assumption.
  60. Qed.
  61. Theorem find_sum_works :
  62. forall k is, has_pair k is ->
  63. exists x y, (find_sum is k = Some (x, y) /\ x + y = k).
  64. Proof.
  65. intros k is. generalize dependent k.
  66. induction is; intros k [x' [y' [Hneq [Hinx [Hiny Hsum]]]]].
  67. - (* is is empty. But x is in is! *)
  68. inversion Hinx.
  69. - (* is is not empty. *)
  70. inversion Hinx.
  71. + (* x is the first element. *)
  72. subst a. inversion Hiny.
  73. * (* y is also the first element; but this is impossible! *)
  74. exfalso. apply Hneq. apply H.
  75. * (* y is somewhere in the rest of the list.
  76. We've proven that we will find it! *)
  77. exists x'. simpl.
  78. erewrite find_matching_works.
  79. { exists y'. split. reflexivity. assumption. }
  80. { split; assumption. }
  81. + (* x is not the first element. *)
  82. inversion Hiny.
  83. * (* y is the first element,
  84. so x is somewhere in the rest of the list.
  85. Again, we've proven that we can find it. *)
  86. subst a. exists y'. simpl.
  87. erewrite find_matching_works.
  88. { exists x'. split. reflexivity. rewrite plus_comm. assumption. }
  89. { split. assumption. rewrite plus_comm. assumption. }
  90. * (* y is not the first element, either.
  91. Of course, there could be another matching pair
  92. starting with a. Otherwise, the inductive hypothesis applies. *)
  93. simpl. destruct (find_matching is k a) eqn:Hf.
  94. { exists a. exists n. split.
  95. reflexivity.
  96. apply find_matching_correct with is. assumption. }
  97. { apply IHis. unfold has_pair. exists x'. exists y'.
  98. repeat split; assumption. }
  99. Qed.
  100. Extraction Language Haskell.
  101. Extraction "test.hs" find_sum.
  102. Check find_sum_works.
  103. (* WIP stuff for 2-pointer solution. *)
  104. Inductive non_empty {X : Type} : list X -> Prop :=
  105. | non_empty_cons : forall x xs, non_empty (cons x xs).
  106. Lemma nil_empty {X: Type} : ~ @non_empty X nil.
  107. Proof. intros H. inversion H. Qed.
  108. Program Fixpoint last (is : list nat) (H : non_empty is) {measure (length is)} : nat :=
  109. match is with
  110. | nil => _
  111. | cons x nil => x
  112. | cons x (cons y xs) => last (cons y xs) _
  113. end.
  114. Obligation 1.
  115. exfalso. apply (nil_empty H).
  116. Qed.
  117. Obligation 2.
  118. apply non_empty_cons.
  119. Qed.
  120. Program Fixpoint drop_last (is : list nat) (H : non_empty is) {measure (length is)} : list nat :=
  121. match is with
  122. | nil => _
  123. | cons x nil => nil
  124. | cons x (cons y xs) => cons x (drop_last (cons y xs) _)
  125. end.
  126. Obligation 1.
  127. exfalso. apply (nil_empty H).
  128. Qed.
  129. Obligation 2.
  130. apply non_empty_cons.
  131. Qed.
  132. Program Fixpoint find_pair (is : list nat) (t : nat) : option (nat * nat) :=
  133. match is with
  134. | nil => None
  135. | cons x nil => None
  136. | cons x (cons y xs) => Some (x, last (cons y xs) _)
  137. end.
  138. Obligation 1.
  139. apply non_empty_cons.
  140. Qed.