123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156 |
- Require Import Coq.Sorting.Mergesort.
- Require Import Coq.Lists.List.
- Require Import Coq.Program.Wf.
- Require Import Coq.Arith.PeanoNat.
- Require Import Omega.
- Require Import ExtrHaskellBasic.
-
- Definition has_pair (t : nat) (is : list nat) : Prop :=
- exists n1 n2 : nat, n1 <> n2 /\ In n1 is /\ In n2 is /\ n1 + n2 = t.
-
- Fixpoint find_matching (is : list nat) (total : nat) (x : nat) : option nat :=
- match is with
- | nil => None
- | cons y ys =>
- if Nat.eqb (x + y) total
- then Some y
- else find_matching ys total x
- end.
-
- Fixpoint find_sum (is : list nat) (total : nat) : option (nat * nat) :=
- match is with
- | nil => None
- | cons x xs =>
- match find_matching xs total x with
- | None => find_sum xs total (* Was buggy! *)
- | Some y => Some (x, y)
- end
- end.
-
- Lemma find_matching_correct : forall is k x y,
- find_matching is k x = Some y -> x + y = k.
- Proof.
- intros is. induction is;
- intros k x y Hev.
- - simpl in Hev. inversion Hev.
- - simpl in Hev. destruct (Nat.eqb (x+a) k) eqn:Heq.
- + injection Hev as H; subst.
- apply EqNat.beq_nat_eq. auto.
- + apply IHis. assumption.
- Qed.
-
- Lemma find_matching_skip : forall k x y i is,
- find_matching is k x = Some y -> find_matching (cons i is) k x = Some y.
- Proof.
- intros k x y i is Hsmall.
- simpl. destruct (Nat.eqb (x+i) k) eqn:Heq.
- - apply find_matching_correct in Hsmall.
- symmetry in Heq. apply EqNat.beq_nat_eq in Heq.
- assert (i = y). { omega. } rewrite H. reflexivity.
- - assumption.
- Qed.
-
- Lemma find_matching_works : forall is k x y, In y is /\ x + y = k ->
- find_matching is k x = Some y.
- Proof.
- intros is. induction is;
- intros k x y [Hin Heq].
- - inversion Hin.
- - inversion Hin.
- + subst a. simpl. Search Nat.eqb.
- destruct (Nat.eqb_spec (x+y) k).
- * reflexivity.
- * exfalso. apply n. assumption.
- + apply find_matching_skip. apply IHis.
- split; assumption.
- Qed.
-
- Theorem find_sum_works :
- forall k is, has_pair k is ->
- exists x y, (find_sum is k = Some (x, y) /\ x + y = k).
- Proof.
- intros k is. generalize dependent k.
- induction is; intros k [x' [y' [Hneq [Hinx [Hiny Hsum]]]]].
- - (* is is empty. But x is in is! *)
- inversion Hinx.
- - (* is is not empty. *)
- inversion Hinx.
- + (* x is the first element. *)
- subst a. inversion Hiny.
- * (* y is also the first element; but this is impossible! *)
- exfalso. apply Hneq. apply H.
- * (* y is somewhere in the rest of the list.
- We've proven that we will find it! *)
- exists x'. simpl.
- erewrite find_matching_works.
- { exists y'. split. reflexivity. assumption. }
- { split; assumption. }
- + (* x is not the first element. *)
- inversion Hiny.
- * (* y is the first element,
- so x is somewhere in the rest of the list.
- Again, we've proven that we can find it. *)
- subst a. exists y'. simpl.
- erewrite find_matching_works.
- { exists x'. split. reflexivity. rewrite plus_comm. assumption. }
- { split. assumption. rewrite plus_comm. assumption. }
- * (* y is not the first element, either.
- Of course, there could be another matching pair
- starting with a. Otherwise, the inductive hypothesis applies. *)
- simpl. destruct (find_matching is k a) eqn:Hf.
- { exists a. exists n. split.
- reflexivity.
- apply find_matching_correct with is. assumption. }
- { apply IHis. unfold has_pair. exists x'. exists y'.
- repeat split; assumption. }
- Qed.
-
- Extraction Language Haskell.
- Extraction "test.hs" find_sum.
-
- Check find_sum_works.
-
- (* WIP stuff for 2-pointer solution. *)
-
- Inductive non_empty {X : Type} : list X -> Prop :=
- | non_empty_cons : forall x xs, non_empty (cons x xs).
-
- Lemma nil_empty {X: Type} : ~ @non_empty X nil.
- Proof. intros H. inversion H. Qed.
-
- Program Fixpoint last (is : list nat) (H : non_empty is) {measure (length is)} : nat :=
- match is with
- | nil => _
- | cons x nil => x
- | cons x (cons y xs) => last (cons y xs) _
- end.
- Obligation 1.
- exfalso. apply (nil_empty H).
- Qed.
- Obligation 2.
- apply non_empty_cons.
- Qed.
-
- Program Fixpoint drop_last (is : list nat) (H : non_empty is) {measure (length is)} : list nat :=
- match is with
- | nil => _
- | cons x nil => nil
- | cons x (cons y xs) => cons x (drop_last (cons y xs) _)
- end.
- Obligation 1.
- exfalso. apply (nil_empty H).
- Qed.
- Obligation 2.
- apply non_empty_cons.
- Qed.
-
- Program Fixpoint find_pair (is : list nat) (t : nat) : option (nat * nat) :=
- match is with
- | nil => None
- | cons x nil => None
- | cons x (cons y xs) => Some (x, last (cons y xs) _)
- end.
- Obligation 1.
- apply non_empty_cons.
- Qed.
|