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.

#### 156 lines 4.6 KiB Raw Blame History

 ```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. ``` ``` ``` ``` ```