text:
Require Import Arith.

(* EXAMPLES *)
(* The following function takes two arguments a and b
which are numbers of type nat and returns b + 2 * (a + b) *)
Definition f_ex (a b : nat) := b + 2 * (a + b).

(* When p is a pair, you can access its components by the "pattern-matching"
  construct illustrated in the following function. *)
Definition add_pair_components (p : nat * nat) :=
  match p with (a, b) => a + b end.

(* f_ex is a function with two arguments.  add_pair_components is a
  function with one argument, which is a pair. *)

(* END OF EXAMPLES *)

(* 1/ Define a function that takes two numbers as arguments and returns
  the sum of the squares of these numbers. *)

(* 2/ Define a function that takes 5 arguments a b c d e, which are all
   numbers and returns the sum of all these numbers. *)

(* 3/ Define a function named add5 that takes a number as argument and returns
   this number plus 5. *)

(* The following should return 8 *)
(* Compute add5 3.*)

(* The following commands make it possible to find pre-defined functions
Search nat.
Search bool.
 *)

(* 4/ Write a function swap of type list nat -> list nat such that
  swap (a::b::l) = (b::a::l)  and
  swap l' = l' if l' has less than 2 elements. *)

(* 5/ Write a function proc2 of type list nat -> nat, such that
   proc2 (a::b::l) = (b + 3) and
   proc2 l' = 0 if l' has less than 2 elements.

   In other words, proc2 only processes the 2nd argument of the list and
   returns that number plus 3.  If there is no second argument to the list,
   proc2 returns 0.  *)

(* 6/ Write a function ms of type list nat -> list nat such that
      ms (a::b::...::nil) = a+2::b+2::...::nil
      For instance
      ms (2::3::5::nil) = (4::5::7::nil) *)

(* 7/ Write a function sorted of type list nat -> bool, such that
    sorted l = true exactly when the natural numbers in
   l are in increasing order. *)

(* 8/ Write a function p2 of type nat -> nat such that
    p2 n = 2 ^ n *)

(* 9/ Write a function salt of type nat -> nat -> nat such that
   salt x n = x ^ n - x^ (n-1) + x^(n-2) .... + 1 or -1, if x <> 0,
   depending on the parity of n, thus
   salt x 3 = x^3 - x^2 + x - 1
   salt x 4 = x^4 - x^3 + x^2 - x + 1
   salt 2 3 = 5

   You may have to define auxiliary functions. *)

(* 10/  Consider the following definition *)

Inductive btree : Type :=
|  leaf
|  bnode (n:nat)(t1 t2: btree).

(* write a function that list the labels of a tree by infix order *)
(** you may use the concatenation function app on lists
  (also written l1 ++ l2 ) *)

(* write a boolean function that checks whether a tree is a binary
search tree *)

author: coq-community

repo: coq-art

save_path: github-repos/coq/coq-community-coq-art

lm_label:
1. YES
2. YES


text:
Require Import CpdtTactics.

(** propositional logic *)

(* (10 minutes) Propositional logic often comes with an A <=> B form that is
true when A and B have the same truth values. Show how to define "iff" as
a Coq Prop. *)

Function iff (A : Prop) (B : Prop) : Prop := (A -> B) /\ (B -> A).

Notation "a <=> b" := (iff a b) (at level 77, right associativity).
Hint Unfold iff.

Theorem iff_refl : forall P : Prop, P <=> P.
Proof.
  auto.
Qed.

Theorem iff_sym : forall P Q : Prop, (P <=> Q) <=> (Q <=> P).
Proof.
  intros; constructor; intro; unfold iff in H; constructor; apply H.
Qed.

(* How automated can you make these proofs? *)

(* (15 minutes) In college-level logic classes, we learn that implication can
be expressed in terms of not and or operations (rather than in terms of
forall). *)
Definition implies (A B : Prop) : Prop := ~A \/ B.
Notation "a => b" := (implies a b) (at level 75, right associativity).
Hint Unfold implies.

(* One might wonder whether this form of implication is "the same as" Coq's
version that uses forall. State two theorems claiming that each kind of
implication can be converted into the other. Which one(s) can you prove? *)

Theorem impl_implies : forall A B : Prop, A -> B -> A => B.
Proof. (* auto *)
  intros; unfold implies; unfold not; right; assumption.
Qed.

Theorem implies_impl : forall A B : Prop, A => B -> A -> B.
Proof.
  intros; unfold implies in H; inversion H.
    unfold not in H1; apply H1 in H0; contradiction.
    assumption.
Qed.

(* How about... *)
Axiom nowai : forall P : Prop, P \/ ~P.
(* ...now? *)

(* Some handy imports:
   Arith gives us nat, *, and +
   Arith.Even gives us even and odd
   Arith.Div2 gives us div2
*)
Require Import Arith.
Require Import Arith.Even.
Require Import Arith.Div2.
Set Implicit Arguments.
Hint Constructors even odd.

(** propositions with implicit equality *)

(* (35 minutes) The Collatz sequence starting at n is defined as the infinite
sequence obtained by iterating the step function:

step(n) = n/2  if n is even
step(n) = 3n+1 if n is odd

For example, the sequence starting at 11 looks like

11, 34, 17, 52, 26, 13, 40, 20, ...

It is conjectured that all collatz sequences eventually cycle (and in
particular reach 1 if they weren't 0 to begin with). Create an inductive
proposition collatz_cycles which expresses the fact that a particular nat
eventually reaches a cycle, then state and prove the fact that the collatz
sequence starting at 5 eventually cycles.

Don't forget about "Hint Constructors" and "auto n" when creating proofs about
constants!
*)
Print even.

(* sequence, starting with n reaches k *)
Inductive collatz_reaches : nat -> nat -> Prop :=
  | obv : forall k : nat, collatz_reaches k k
  | evC : forall k n : nat, even n -> collatz_reaches k (n / 2) ->
      collatz_reaches k n
  | odC : forall k n : nat, odd n -> collatz_reaches k (3 * n + 1) ->
      collatz_reaches k n.

Inductive collatz_cycles (n : nat) : Prop :=
  | Cev : (exists k, even k /\
      collatz_reaches k n /\ collatz_reaches k (k / 2)) -> collatz_cycles n
  | Cod : (exists k, odd k /\
      collatz_reaches k n /\ collatz_reaches k (3 * k + 1)) -> collatz_cycles n.

Hint Constructors collatz_reaches.

Theorem cc5 : collatz_cycles 5.
Proof.
  apply Cev; exists 4; split.
    auto 5.
  split. apply odC; auto 6.
  simpl; apply evC; auto 17.
  simpl; apply evC; auto 9.
  simpl; apply evC; auto 5.
  simpl; apply odC; auto 2.
Qed.

(* (45 minutes) We say a list A is a "subsequence" of a list B when you can
produce list A by deleting some elements from list B.  For example, [1,2,3] is
a subsequence of each of the lists
[1,2,3]
[1,1,1,2,2,3]
[1,2,7,3]
[5,6,1,9,9,2,7,3,8]
but it is not a subsequence of any of the lists:
[1,2]
[1,3]
[5,6,2,1,7,3,8]

Define an inductive proposition subsequence that captures what it means to be
a subsequence, then prove that subsequence is transitive. Some hints on
automating this proof:

1. Use Hint Constructors to add your inductive proposition's constructors to
the hint database.
2. Choose which thing you do induction on carefully!
3. Try "crush" and look where it fails -- then add that as a lemma and put it
in your rewriting database. For example, on my first attempt, crush died here
first:

  A : Type
  l1 : list A
  H : subsequence l1 nil
  l : list A
  ============================
   subsequence l1 l

So I added a lemma:

Lemma subsequence_nil_anything : forall A (l1 l2 : list A),
    subsequence l1 nil -> subsequence l1 l2.
(* ... ;-) *)
Qed.

Hint Resolve subsequence_nil_anything.

That let crush get a bit farther, and suggested the next lemma I would need to
prove.
*)

Section subsequence.
  Variable T : Type.

(* 1st arg is subsequence of 2nd *)
Inductive subsequence : list T -> list T -> Prop :=
  | sNil : forall l, subsequence nil l
  | sTail : forall (b : T) (l l1 : list T), subsequence l l1 -> subsequence l (b :: l1)
  | sHead : forall (a b : T) (l l1 : list T), a = b -> subsequence l l1 -> subsequence (cons a l) (cons b l1).

Hint Constructors subsequence.

Hypothesis sub_nil_any : forall l, subsequence l nil -> forall l1, subsequence l l1.
Hypothesis sub_weak : forall a l l1, subsequence (a :: l) l1 -> subsequence l l1.
Hint Resolve sub_nil_any.

Theorem subsequence_trans : forall l l1, subsequence l l1 -> forall l2, subsequence l1 l2 ->
    subsequence l l2.
Proof.
  induction 2; crush. inversion H; crush. inversion H2; crush. inversion H; crush.

Qed.

(* I'm not really sure why we're not getting this notation for free, actually.
But we're not, se here it is for convenience. *)
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition sub123 := subsequence [1; 2; 3].
Definition notsub123 := fun l => ~(subsequence [1; 2; 3] l).
Hint Unfold sub123.

Example e1 : sub123 [1; 2; 3]. auto 100. Qed.
Example e2 : sub123 [1; 1; 1; 2; 2; 3]. auto 100. Qed.
Example e3 : sub123 [1; 2; 7; 3]. auto 100. Qed.
Example e4 : sub123 [5; 6; 1; 9; 9; 2; 7; 3; 8]. auto 100. Qed.
(* optional; you'll like inversion and unfold a lot
Example e5 : notsub123 [1; 2]. (* TODO *) Qed.
Example e6 : notsub123 [1; 3]. (* TODO *) Qed.
Example e7 : notsub123 [5; 6; 2; 1; 7; 3; 8]. (* TODO *) Qed.
*)

author: fyrchik


text:
(* nat --> An 'Inductive' Type, and not an 'enumerated' type [Ex: Bool] *)
Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

(* Quick redefinition of : bool *)
Inductive bool : Type :=
  | true : bool
  | false : bool.

Definition negate_bool (b:bool) : bool :=
  match b with
  | true => false
  | false => true
end.

Definition pred (n:nat) : nat :=
  match n with
    | O => O
    | S n' => n'
end.

(* Verify the Number 3 *)
Check (S (S (S O))).

(* Using recusrion with : Fixpoint *)
Fixpoint odd_nat (n:nat) : bool :=
  match n with
  | O => false
  | S O => true
  | S (S n') => odd_nat n'
end.

Fixpoint even_nat (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even_nat n'
end.

Compute (even_nat (S (S (S (S O))))).
Check even_nat.
Check pred.
Check S.

(* A few Tests [Asserted as Proofs] *)
Example test_even_nat1 : even_nat (S (S (S (S O)))) = true.
Proof. simpl. reflexivity. Qed.
Example test_odd_nat1 : (odd_nat (S (S (S (S O))))) = false.
Proof. simpl. reflexivity. Qed.

(* Definition of the plus, minus, mult and fac functions *)
Fixpoint plus (n:nat) (m:nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
end.

Compute (plus (S (S (S O))) (S (S O))).

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O, _ => O
  | S _, O => n
  | S n', S m' => minus n' m'
end.

Fixpoint minus_2 (n:nat) (m:nat) : nat :=
  match m with
  | O => n
  | S m' => minus_2 (pred n) m'
end.

Compute (minus_2 (S (S (S (S (S O))))) (S (S O))).

Fixpoint mult (n:nat) (m:nat) : nat :=
  match n with
  | O => O
  | S n' => plus m (mult n' m)
end.

Fixpoint fac (n:nat) : nat :=
  match n with
  | O => S O
  | S O => S O
  | S n' => mult n (fac n')
end.

(* Simple Tests [Asserted as Proofs] for mult, etc. *)
Example test_fac_1: (fac (S (S (S O)))) = (S (S (S (S (S (S O)))))).
Proof. simpl. reflexivity. Qed.
Example test_mult_1: (mult (S (S O)) (S (S (S O)))) = (S (S (S( S( S( S O)))))).
Proof. simpl. reflexivity. Qed.
Example test_minus_1: (minus (S (S (S (S (S O))))) (S (S (S O)))) = (S (S O)).
Proof. simpl. reflexivity. Qed.
Example test_minus_2: (minus_2 (S (S (S (S (S O))))) (S (S (S O)))) = S (S O).
Proof. simpl. reflexivity. Qed.

(* Introduce notations *)
Notation "x + y" := (plus x y)
                        (at level 50, left associativity)
                        : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

(* Define Equality between 'nat' *)
Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
end.

Example test_beq_nat_1: (beq_nat (S (S (S O))) (S (S (S O)))) = true.
Proof. simpl. reflexivity. Qed.
Example test_beq_nat_2: (beq_nat (S (S (S O))) (S (S O))) = false.
Proof. simpl. reflexivity. Qed.

(* Define a function to test : n <= m, without using 'Fixpoint' *)
Fixpoint leq_nat (n m : nat) : bool :=
  match n, m with
  | O, _ => true
  | S _, O => false
  | S n', S m' => leq_nat n' m'
end.

(* Some computations of 'leq' before the Proofs *)
Compute (leq_nat (S (S (S O))) (S (S (S O)))).
Compute (leq_nat (S (S (S O))) (S (S (S (S O))))).
Compute (leq_nat (S (S (S (S O)))) (S (S (S O)))).

Example test_leq_nat1: (leq_nat (S (S (S O))) (S (S (S O)))) = true.
Proof. simpl. reflexivity. Qed.
Example test_leq_nat2: (leq_nat (S (S (S O))) (S (S (S (S O))))) = true.
Proof. simpl. reflexivity. Qed.
Example test_leq_nat3: (leq_nat (S (S (S (S O)))) (S (S (S O)))) = false.
Proof. simpl. reflexivity. Qed.

(* Let us write a few Theorems regarding the type : nat *)

(* Left addition of 0 *)
Theorem plus_O_n_l : forall n: nat, O + n = n.
Proof.
  intros n. reflexivity. Qed. (* simpl is not needed *)

(* To Coq, Lemma = Fact = Remark = Example = Theorem *)
(* The difference is mostly Syntactic Sugar *)

(* Left addition of 1 *)
Theorem plus_1_n_l : forall n: nat, (S O) + n = S n.
Proof.
  intros n. reflexivity. Qed.

(* Using rewrite *)

(* Addition of equal nat *)
Theorem plus_id : forall n m: nat,
n = m ->
n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity. Qed.

(* Addition of transitively equal nat *)
Theorem plus_id_transitive : forall n m o: nat,
n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity. Qed.

(* We can also use rewrite using a _previously_ proved Theorem *)
Theorem add_0_and_mult : forall n m: nat,
(O + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n_l.
  reflexivity. Qed.

(* Proof for Right multiplication by Successor *)
Theorem mult_S_n_1 : forall n m: nat,
m = S n -> m * ((S O) + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> plus_1_n_l.
  rewrite -> H.
  reflexivity. Qed.

(* When the _evaluation_ of an argument itself is recursive, then
proofs can't simply use _rewrite_ or _simpl_ -> Use _destruct_ *)
Theorem plus_1_neq_O : forall n: nat,
beq_nat (n + (S O)) O = false.
Proof.
  intros n. destruct n as [|n'].
  - reflexivity.
  - reflexivity. Qed.

(* Proof that 1 plus anything can never be zero in the realm of the natural numbers *)
Theorem zero_nbeq_plus_1 : forall n: nat,
beq_nat O (n + (S O)) = false.
Proof.
intros n. destruct n as [|n'].
- reflexivity.
- reflexivity. Qed.

(* Exercise 1 : Show that the identity function applied twice is the same as it being applied once *)
Theorem identity_fn_applied_twice : forall (f : bool -> bool),
(forall (x: bool), f x = x) -> (forall (b: bool), f (f b) = b).
Proof.
intros f H b.
rewrite <- H.
simpl.
rewrite <- H.
reflexivity.
Qed.

Theorem unnecess_brack_add : forall n m p: nat,
p + (n + m) = p + n + m.
Proof.
intros n m p. induction p as [|p' IHp'].
- simpl. reflexivity.
- simpl. rewrite -> IHp'. simpl. reflexivity.
Qed.

(* A List of Proofs about Functions of `Nat` from Chapter-3 (Induction) *)
(* NOTE : Not all _require_ Induction. In fact, the goal is to skillfully be minimal in the proofs *)
Theorem leq_nat_refl : forall n: nat,
true = leq_nat n n.
Proof.
intros n. induction n as [|n' IHn'].
- simpl. reflexivity.
- simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem zero_nbeq_S : forall n: nat,
beq_nat O (S n) = false.
Proof.
intros n.
simpl.
reflexivity.
Qed.

Theorem plus_ble_compat_l : forall n m p: nat,
leq_nat n m = true -> leq_nat (p + n) (p + m) = true.
Proof.
intros n m p H. induction p as [|p' IHp'].
- simpl. rewrite -> H. reflexivity.
- simpl. rewrite -> IHp'. reflexivity.
Qed.

Theorem S_nbeq_O : forall n: nat,
  beq_nat (S n) O = false.
Proof.
intros n.
simpl.
reflexivity.
Qed.

(* Temporary re-proof {already done in Induction.v} of plus_n_O *)
Theorem plus_n_O : forall n: nat,
n = n + O.
Proof.
intros n. induction n as [|n' IHn'].
- (* n = O *) reflexivity.
- (* n = S n' *) simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem mult_1_l : forall n: nat,
(S O) * n = n.
Proof.
intros n. induction n as [|n' IHn'].
- simpl. reflexivity.
- simpl. rewrite <- plus_n_O. reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p: nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
intros n m p. induction n as [|n' IHn'].
- simpl. reflexivity.
- simpl. rewrite -> IHn'. rewrite -> unnecess_brack_add. reflexivity.
Qed.

Theorem beq_nat_refl : forall n: nat,
true = beq_nat n n.
Proof.
intros n. induction n as [|n' IHn'].
- simpl. reflexivity.
- simpl. rewrite -> IHn'. simpl. reflexivity.
Qed.

repo: coq-types


text:
Require Import Bool Arith List.

(* 1. Define a recursive function that takes as input a list of numbers
   and returns the product of these numbers, *)

Fixpoint prodlist (l : list nat) :=
  match l with
  | nil => 1
  | x :: xs => x * prodlist xs
  end.

Compute prodlist nil.
Compute prodlist (0 :: 3 :: 7 :: nil).
Compute prodlist (3 :: 4 :: 2 :: nil).

(* 2. Define a recursive function that takes a list of numbers and
   returns true if and only if this list contains the number 0.
   Hint: pattern match on both the list and the elements of the list. *)

Fixpoint has_a_0 (l : list nat) :=
  match l with
  | nil => false
  | x :: xs =>
    match x with
    | 0 => true
    | S _ => has_a_0 xs
    end
  end.

Compute has_a_0 (2 :: 3 :: 0 :: 7 :: nil).
Compute has_a_0 nil.
Compute has_a_0 (3 :: 5 :: nil).

(* 3. Define a recursive function that takes as input two numbers and
   returns true if and only if these two numbers are the same natural
   number (such a function already exists in the Coq libraries
   (function beq_nat, but how would you define such a function), using
   only pattern-matching and recursion. *)

Fixpoint beq (a b : nat) :=
  match a, b with
  | 0, 0 => true
  | 0, S _ => false
  | S _, 0 => false
  | S a1, S b1 => beq a1 b1
end.

Compute beq 4 5.
Compute beq 7 7.

(* 4. Define a recursive function that takes a number n and a number
   a as input and returns a list of numbers containing n elements
   that are all a. *)

Fixpoint mklist (n a : nat) (l: list nat) :=
  match n with
  | 0 => l
  | S n1 => mklist n1 a (a::l)
  end.

Compute mklist 5 2 nil.
(*
Fixpoint mklist (n a : nat) :=
  match n with
  | 0 => nil
  | S n1 =>
              cons a (mklist n1 a)
*)

(* 5. Define a function that takes a number n and a number a and returns
   the list of n elements a ::a + 1:: Â· Â· Â· ::a + n:: nil. *)

Fixpoint mklist1 (n a : nat) :=
  match n with
  | 0 => nil
  | S n1 => cons (a) (mklist1 n1 (a + 1))
  end.

Compute mklist1 5 2.

(* 6. Define a function that takes as input a natural number and returns
   an element of option nat containing the predecessor if it exists or
   None if the input is 0. *)
Fixpoint pred (n : nat) :=
  match n with
  | 0 => None
  | S x => Some x
end.

Compute pred 0.
Compute pred 6.

(* 7. Define a recursive function that takes as input a list of numbers
   and returns the length of this list. *)

Fixpoint length (l : list nat) (n : nat) :=
  match l with
  | nil => n
  | x :: xs => length xs (n + 1)
  end.

Compute length nil 0.
Compute length (2 :: 3 :: nil) 0.
Compute length (2 :: 3 :: 4 :: 4 :: nil) 0.

(* 8. Can you write a recursive function values that takes as input a
   function f of type nat -> nat, an initial value a of type nat
   and a count n of type nat and produces the list
   a :: f a :: f (f a) :: ... *)

Fixpoint fold (f : nat -> nat) (a : nat) (n : nat) :=
  match n with
  | 0 => nil
  | S n1 => cons (a) (fold f (f a) n1)
  end.

Compute fold (fun x : nat => x) 0 5.
Compute fold (fun x : nat => x + 1) 3 4.
Compute fold S 3 4.

(* 9. To every natural number, we can associate the list of its digits
   from right to left. For instance, 239 should be associated to the list
   9::3::2::nil. We also consider that 0 can be mapped to nil. If l is
   such a list, we can consider the successor of a list of digits.
   For instance, the successor of 9::3::2::nil is 0::4::2.
   Define the algorithm on lists of natural numbers that computes the
   successor of that list. *)

Fixpoint lsucc (l: list nat) :=
  match l with
  | nil => 1::nil
  | x :: xs  =>
      match x with
      | 9 => 0 :: lsucc xs
      | _ => (x + 1) :: xs
      end
  end.

Compute lsucc (3 :: 9 :: 1 :: nil).
Compute lsucc (9 :: 3 :: 1 :: nil).
Compute lsucc (9 :: 9 :: 1 :: nil).
Compute lsucc nil.
Compute lsucc (9 :: nil).

Check lsucc.
(* 10. Assuming that lsuc is the function defined at the previous
   exercise, define the function nat_digits that maps every natural
   number to the corresponding list of digits (naive solutions are
   welcome, as long as they run). *)

Fixpoint nat_digits_aux (n i: nat) (li : list nat) :=
  match i with
  | 0 => li
  | S i1 => nat_digits_aux n i1 (lsucc li)
  end.

Definition nat_digits (n : nat) :=
  nat_digits_aux n n nil.

Compute nat_digits 4532.

(* 11. In the same context as the previous two exercises, define a function
   value that maps every list of digits to the natural number it
   represents. Thus, value (9::3::2::nil) should compute to 239. *)

Fixpoint value (l : list nat) :=
  match l with
  | nil => 0
  | x::xs => x + 10 * value(xs)
end.
Compute value (0 :: 2 :: 3 :: 4 :: nil).

(* 12. In the same context as the previous exercises, define a function
   licit that tells whether a list of integers corresponds to the digits
   of natural number: no digit should be larger than 9. For instance,
   licit (9::3::2::0::nil) should compute to true and licit (239::nil)
   should compute to false. *)

Fixpoint licit (l : list nat) (b : bool):=
  match l, b with
  | nil, true => true
  | _, false => false
  | x::xs, true => licit xs (leb x 10)
end.

Compute licit (9 :: 3 :: 2 :: 0 :: 34 :: nil) true.
Compute licit (2 :: 3 :: 9 :: nil) true.

(* 13. In the same context as the previous exercises, define functions
   to add two lists of digits so that the result represents the sum of
   the numbers represented by the lists of digits. In other words
   addl (7::2::nil) (5::3::nil) should return 2::6::nil
   (Hint: you should implement the algorithm you learned in elementary
   school for adding numbers). *)

Fixpoint addl (l1 l2 l: list nat) (c : nat) :=
  match l1, l2 with
  | nil, nil => l
  | nil, x::xs => (x +)
  | _, nil => l1::l
  | x1::xs1, x2::xs2 =>
    match leb (x1 + x2) 10 with
    | true => addl xs1 xs2 0
    | false => addl xs1 xs2 1
  end
end.

Compute addl (7 :: 2 :: nil) (5 :: 3 :: nil) nil 0.

(* 14. In the same context as the previous exercises, define a function
   for multiplying a list by a small natural number (by successive
   additions) and then a function mull for multiplying two lists of
   digits. *)

... mulln ...

Compute mulln 3 (2 :: 1 :: nil).

... mull ...

Compute 14 * 13.
Compute mull (4 :: 1 :: nil) (3 :: 1 :: nil).
Compute 437 * 25.
Compute mull (7 :: 3 :: 4 :: nil) (5 :: 2 :: nil).
Compute 97 * 75.
Compute mull (7 :: 9 :: nil) (5 :: 7 :: nil).

author: vabh

repo: Coq

save_path: github-repos/coq/vabh-Coq


text:
Inductive Nat :=
  |O : Nat
  |S : Nat -> Nat.
Check Nat_ind.

Fixpoint plus(n:Nat)(m:Nat) : Nat :=
  match n with
  |O => m
  |S v => S(plus v m)
  end.

Lemma O_plus_n_is_n:
  forall n, plus O n=n.
Proof.
  (* tactics *)
  intros n.
  simpl.
  reflexivity.
Qed.

Lemma n_plus_0_is_n:
  forall n, plus n O = n.
Proof.
  induction n.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHn.
    reflexivity.
Qed.

Lemma plus_comm:
  forall n m, plus n m = plus m n.
Proof.
  induction n.
  - intros m.
    simpl.
    rewrite n_plus_0_is_n.
    reflexivity.
  - induction m.
    + simpl.
      rewrite n_plus_0_is_n.
      reflexivity.
    + simpl.
      rewrite IHn.
      simpl.
      rewrite <- IHm.
      simpl.
      rewrite IHn.
      reflexivity.
Qed.

author: IonitaCatalin

repo: programming-language-principle


text:
Require Import List CpdtTactics.
Import ListNotations.

(* An abbreviation which given two nats n and m,
   decides whether {n <= m} or {n > m}. *)
Definition nat_lte := Compare_dec.le_gt_dec.

(* Insert a number into a list.  Assumes the list is
   sorted in in non-decreasing order. *)
Fixpoint insert (n:nat) (xs:list nat) : list nat :=
  match xs with
    | [] => [n]
    | h::t => if nat_lte n h then n::h::t else h::(insert n t)
  end.

(* Insertion sort. *)
Definition insert_sort (xs:list nat) : list nat :=
  fold_right insert [] xs.

(* Simple test. *)
Eval compute in insert_sort [3;2;5;1;7].

(* A useful predicate on lists.  list_all P xs holds
   when P holds on each element of xs. *)
Definition list_all {A:Type} (P:A->Prop) (xs:list A) : Prop :=
  fold_right (fun h t => P h /\ t) True xs.

(* We can use list_all to define a notion of a sorted list. *)
Fixpoint sorted (xs:list nat) : Prop :=
  match xs with
    | [] => True
    | h::t => sorted t /\ list_all (le h) t
  end.

(* Notice that this produces a predicate (which we can't prove!) *)
Eval compute in sorted [3;1;2].

(* We can prove this predicate though. *)
Example sorted_123 : sorted [1;2;3].
Proof.
  simpl.
  auto 100.
Qed.

(* Here's an alternative definition of sorted using an
   couple of inductive definitions. *)
Inductive list_lte : nat -> list nat -> Prop :=
| nil_list_lte : forall n, list_lte n nil
| cons_list_lte : forall n h t, n <= h -> list_lte n t -> list_lte n (h::t).

Inductive sorted' : list nat -> Prop :=
| nil_is_sorted : sorted' nil
| cons_is_sorted : forall h t, list_lte h t -> sorted' t -> sorted' (h::t).

(* And here's an example proof that the list [1;2;3] is sorted'. *)
Example sorted'_123 : sorted' [1;2;3].
Proof.
  Hint Constructors list_lte sorted'.
  auto 100.
Qed.

(* The two definitions of sorted'ness are equivalent. *)
Lemma list_lte_iff_list_all_lte :
  forall n (xs:list nat),
    list_lte n xs <-> list_all (le n) xs.
Proof.
  induction xs ; crush.
  inversion H1 ; intros ; subst.
  auto.
  inversion H1 ; intros ; subst.
  auto.
Qed.

Lemma sorted_iff_sorted' :
  forall (xs:list nat),
    sorted xs <-> sorted' xs.
Proof.
  Hint Constructors sorted'.
  induction xs ; crush.
  constructor.
  rewrite list_lte_iff_list_all_lte. auto. auto.
  inversion H1 ; intros ; subst. crush.
  rewrite <- list_lte_iff_list_all_lte.
  inversion H1 ; intros ; subst. auto.
Qed.

(* Let's try to prove that insert_sort produces a sorted list. *)
Lemma insert_sort_sorted : forall xs, sorted (insert_sort xs).
Proof.
  induction xs ; crush.
  unfold sorted.
  (* We're stuck since Coq doesn't know if (insert a (insert_sort xs))
     is empty or a cons. Let's try to convince it. *)
  remember (insert a (insert_sort xs)) as sorted_xs.
  destruct sorted_xs.
  (* If (insert a (insert_sort xs)) is empty, we don't have to prove
     anything -- an empty list is already sorted.  (But of course,
     (insert a (insert_sort xs)) is not empty. *)
  auto.
  (* Ugh!  We're no better off than we were before. Let's abort... *)
  Abort.

(* What we need to do first is prove something useful about
   insert.  For example, if xs is sorted and we insert n into
   it, we should get back a sorted list.  Before juming into
   that, let me define some useful lemmas. *)

(* A useful lemma that lifts implication to list_all.  It says
   that if P x -> Q x for any x, then list_all P xs -> list_all Q xs.
*)
Lemma list_all_imp{A}:
  forall (P Q : A -> Prop),
    (forall (x:A), P x -> Q x) ->
  (forall (xs:list A), list_all P xs -> list_all Q xs).
Proof.
  intros P Q H.
  induction xs ; crush.
Qed.

(* If n <= m and m <= each element of xs, then n <= each element of xs. *)
Lemma list_lte_nm (n m:nat) (xs:list nat) :
  n <= m -> list_all (le m) xs -> list_all (le n) xs.
Proof.
  intros.
  (* Aha!  Now we can use the list_all_imp lemma to avoid
    reasining about the list, and reduce this to a single element. *)
  eapply (list_all_imp (le m) (le n)) ; [ intros ; omega | auto ].
Qed.

(* So let's try to prove this fact now... *)
Lemma insert_sorted : forall n xs, sorted xs -> sorted (insert n xs).
Proof.
  induction xs ; crush.
  destruct (nat_lte n a) ; simpl.
  crush.
  (* Here's where our lemma above comes into play. *)
  eapply list_lte_nm ; eauto.
  crush.
  (* Ugh!  How are we supposed to prove that a <= insert n xs?
     Intuitively it's true, but how can we show this?  We need
     to know that if we insert n into xs, then the elements of
     the resulting list are either equal to n or one of the xs. *)
  Abort.

(* An equivalent way to capture "list_all" *)
Lemma in_list_all {A} (P:A->Prop) (xs:list A) :
  (forall x, In x xs -> P x) <-> list_all P xs.
Proof.
  induction xs ; crush.
Qed.

(* Now we can prove that if you insert n into xs, then
   any element of the resulting list is either equal to
   n or one of the xs. *)
Lemma in_insert :
  forall (xs:list nat) (n:nat),
    forall x, In x (insert n xs) -> x = n \/ In x xs.
Proof.
  induction xs ; crush.
  destruct (nat_lte n a) ; crush.
  specialize (IHxs _ _ H0). crush.
Qed.

(* The opposite fact will also be useful. *)
Lemma insert_in :
  forall (xs:list nat) (n:nat),
    forall x, x = n \/ In x xs -> In x (insert n xs).
Proof.
  induction xs ; crush.
  destruct (nat_lte n a) ; crush.
  destruct (nat_lte n x) ; crush.
  destruct (nat_lte n a) ; crush.
Qed.

Lemma insert_sorted : forall n xs, sorted xs -> sorted (insert n xs).
Proof.
  induction xs ; crush.
  destruct (nat_lte n a) ; simpl.
  crush.
  eapply list_lte_nm ; eauto.
  crush.
  (* here's where in_list_all comes into play -- we turn the
     list_all into reasoning about a particular element in
     (insert n xs) which has to be either n or one of the xs. *)
  apply in_list_all.
  intros.
  generalize (in_insert xs n x H2). intro.
  destruct H3.
  crush.
  (* here's where the opposite lemma comes into play. *)
  rewrite <- in_list_all in H1.
  crush.
Qed.

(* Once we've proved that insert produces a sorted list, we
   can easily prove that insert_sort produces a sorted list. *)
Lemma insert_sort_sorted : forall xs, sorted (insert_sort xs).
Proof.
  induction xs ; crush.
  apply insert_sorted ; auto.
Qed.

(* However, note that the following function also produces
   a sorted list:
*)
Definition bogus_sort (xs:list nat) : list nat := nil.

Lemma bogus_sort_sorted (xs:list nat) : sorted (bogus_sort xs).
  apply I.
Qed.

(* Here's an attempt to capture what it means for a sort
   function to actually be correct.   The output should
   be sorted, the length of the input should equal the
   length of the output, and every member of the input
   should be in the output (and vice versa, though this
   can be shown given that the lengths are the same.)
*)
Definition sublist {A} (xs ys:list A) : Prop :=
  forall (x:A), In x xs -> In x ys.

Definition sort_corr (xs ys:list nat) : Prop :=
  sorted ys /\ sublist xs ys /\ length xs = length ys.

(* There are, of course, alternative definitions.  For
   instance, we might specify that the output is a sorted
   permutation of the input.

   Often, you can't predict what will be the most useful
   specification.  That depends largely on who'se using
   the code and what they need to know.  For instance,
   we might be using the sort routine as part of a set
   implementation.  In that case, these properties would
   be good enough, though we'd probably want to build
   some derived properties.  For instance, we might
   like to know that

     (sort_corr xs ys) -> (sort_corr xs zs) -> ys = zs

   which *cannot* be proven from the spec above (and in
   fact is not true.)
*)

(* Let's prove now that our insertion sort is correct,
   according to the definition we gave above.  We have
   already shown insert_sort produces a sorted list.
   Now we just need to establish the other two properties: *)
Lemma insert_sort_sublist : forall xs, sublist xs (insert_sort xs).
Proof.
  unfold sublist.
  induction xs ; crush ; apply insert_in ; crush.
Qed.

Lemma insert_length : forall xs n, length (insert n xs) = S (length xs).
Proof.
  induction xs ; crush.
  destruct (nat_lte n a) ; crush.
Qed.

Lemma insert_sort_length : forall xs, length xs = length (insert_sort xs).
Proof.
  induction xs ; crush.
  rewrite insert_length. auto.
Qed.

(* And finally, we can show insertion sort is correct. *)
Lemma insert_sort_corr : forall xs, sort_corr xs (insert_sort xs).
Proof.
  unfold sort_corr. intro.
  split.
  apply insert_sort_sorted.
  split.
  apply insert_sort_sublist.
  apply insert_sort_length.
Qed.

(********************************************************)

(* Of course, we don't want to use an O(n^2) sort in practice.
   So here, I develop a merge sort.  This shows off something
   new -- defining a recursive function using something besides
   structural induction to establish termination.
*)

(* First, we need to define a function to merge two (already
   sorted lists).  Now normally, we'd write this as:

   Fixpoint merge (xs ys:list nat) {struct xs} : list nat :=
      match xs, ys with
      | [], ys => ys
      | xs, [] => xs
      | h1::t1, h2::t2 => if nat_lte h1 h2 then
                           h1 :: (merge t1 ys)
                         else
                           h2 :: (merge xs t2)
      end.

   But unfortunately, Coq will reject this because it's
   not the case that xs is always getting smaller, nor
   the case that ys is always getting smaller.  Of course,
   *one* of them is always getting smaller, so eventually,
   this will terminate.

   But in this case, we can hack around the problem by
   simply re-organizing the function as follows:
*)
Fixpoint merge (xs:list nat) : list nat -> list nat :=
  match xs with
    | nil => fun ys => ys
    | (x::xs') =>
      (fix inner_merge (ys:list nat) : list nat :=
         match ys with
           | nil => x::xs'
           | y::ys' => if nat_lte x y then
                         x :: (merge xs' (y::ys'))
                       else
                         y :: (inner_merge ys')
         end)
  end.
(* Note that for the out loop, we only call it with a
   smaller xs, and for the inner loop, we only call it
   with a smaller ys.  So Coq can see by structural
   induction the loops that the definition terminates.

   Note that if you tried to pull inner_merge out and
   define it as a top-level function, Coq would no
   longer be able to tell that merge terminates.
   In this sense, Coq's termination checking isn't
   modular.
*)

(* Test that merge works. *)
Eval compute in merge [1;3;5] [2;4;6].
Eval compute in merge [3] [1;4].

(* This function takes a list of lists of nats, and
   merges each pair of lists.  See the example below. *)
Fixpoint merge_pairs (xs:list (list nat)) : list (list nat) :=
  match xs with
    | h1::h2::t => (merge h1 h2) :: (merge_pairs t)
    | xs' => xs'
  end.

Eval compute in merge_pairs [[1;3];[2;4;9];[0];[2;3]].
Eval compute in merge_pairs [[1;3];[2;4;9];[0]].

(* To define our actualy merge sort, we want to take the
   initial list [n1;n2;...;nm] and turn it into a list of
   singleton lists: [[n1];[n2];...;[nm]] and then successively
   call merge_pairs until we get a single list out. *)

(* This function takes a list and turns it into a list
   of singleton lists of the elements. *)
Definition make_lists (xs:list nat) : list (list nat) :=
  List.map (fun x => x::nil) xs.

Eval compute in make_lists [5; 1; 4; 2; 3].
Eval compute in merge_pairs (merge_pairs (merge_pairs (make_lists [5; 1; 4; 2; 3]))).
(* As with merge, I would like to write the following function
   which is intended to iterate merging the pairs of a list of
   lists until we get a single list out:

  Fixpoint merge_iter (xs:list (list nat)) : list nat :=
    match xs with
    | [] => []
    | [h] => h
    | h1::h2::xs' => merge_iter (merge_pairs (h1::h2::xs'))
    end.

  But Coq can't tell that this terminates.  The problem is
  that we are calling merge_iter on (merge_pairs (h1::h2::xs'))
  instead of xs'.  Since in principle, merge_pairs could return
  a list no smaller than the input, Coq rejects the definition.

  All is not lost, though.  In Coq, we can define functions
  that use an arbitrary measure (or really, any well-founded
  relation) and show that the measure is always decreasing
  to convince Coq the function terminates.

  Before doing that, I need to establish a lemma that:

   length (merge_pairs (h1::h2::xs)) < length (h1::h2::xs)

  This is a little tricky to prove since we are peeling off
  2 elements instead of one.  One way to prove it is using
  so-called "strong-induction", but here's another way:
*)
Lemma merge_pairs_length' :
  forall xs, (forall h1 h2,
                length (merge_pairs (h1::h2::xs)) < length (h1::h2::xs)) /\
             (forall h,
                length (merge_pairs (h::xs)) <= length (h::xs)).
Proof.
  induction xs ; crush.
Qed.

(* What I did in merge_pairs_length' is generalize my desired
   property to one that holds regardless of the number of elements
   in the list.  Try doing it without the second case and see what
   goes wrong... *)

(* Anyway, my decreasing measure is now easy to establish from the
   lemma above. *)
Lemma merge_pairs_length :
  forall h1 h2 xs, length (merge_pairs (h1::h2::xs)) < length (h1::h2::xs).
Proof.
  intros.
  specialize (merge_pairs_length' xs).
  intros [H _].
  apply H.
Qed.

(* Now I'm going to define my merge_iter function.  Since it's
   not structurally recursive, but rather, defined using a measure,
   I first need to import a couple of libraries. *)
Require Import Program.
Require Import Wf.
Require Import Recdef.

(* The [Program Fixpoint] construct is similar to the [Fixpoint]
   construct.  The big difference is that I'm required to state
   a [{measure ...}] clause to convince Coq as to what's going
   down.  In this case, the length of the argument list is always
   going down when we do a recursive call.
*)
Function merge_iter (xs : list (list nat)) {measure length} :
  list nat :=
  match xs with
   | nil => nil
    | h::nil => h
    | h1::h2::xs' => merge_iter (merge_pairs (h1::h2::xs'))
  end.
intros.
apply merge_pairs_length.
Defined.

Print merge_iter.

(* If we print out merge_iter... *)
Print merge_iter.
(* ...we see that the [Program Fixpoint] did a lot of work for us
   to translate our definition into the real core of Coq.  It's
   using a special function Fix_sub, along with some other hidden
   definitions that you can print out if you like. *)
Print Fix_sub.
(* Fix_sub is defined in terms of Fix_F_sub. *)
Print Fix_F_sub.
(* Fix_F_sub is defined to be:

   fun (A : Type) (R : A -> A -> Prop) (P : A -> Type)
     (F_sub : forall x : A, (forall y : {y : A | R y x}, P (` y)) -> P x) =>
       fix Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x :=
       F_sub x

  If you look carefully, this is proceeding by (structural) induction
  on r and is just a seemingly infinite loop.  But since r must be
  getting smaller each time around the loop, the loop actually
  terminates.

  What is r?  It's a proof that the value x is "accessible" (Acc) with
  respect to the relation R.  In our case, R is essentially the
  relation between the length of the original input
  the length of the list we are recursing on (a < relation on the
  lengths of the lists.)  The "accessible" notion is capturing the
  idea that our relation has no infinite descending chains.  In the
  case of <, there is a least element, namely 0.  So if we are always
  going down in the relation, we will eventually get to 0.

  TL;DR:  You don't need to understand all of this.  You just need
  to be able to use the [Program Fixpoint ... {measure ...}] construct
  to write functions and argue that the generated obligations are
  met (i.e., that your measure really is decreasing.)
*)

(* Once we've defined our merge_iter, we can finally define
   our merge_sort: *)
Definition merge_sort (xs:list nat) :=
  merge_iter (make_lists xs).

(* Let's test that it's working... *)
Eval compute in merge_sort [7;8;3;5;1;2;6;4].
Eval compute in merge_sort [3;2;7;8].

(* Exercises:

1. Show that

   a. sorted xs -> sorted ys -> sorted (merge xs ys)

*)

Lemma merge_list_all : forall P xs ys, list_all P xs -> list_all P ys -> list_all P (merge xs ys).
intros P xs.
induction xs; intros.
simpl. assumption.
simpl merge.
induction ys.
assumption.
remember (nat_lte a a0) as cond. destruct cond.
simpl. destruct H. split. assumption. eapply IHxs; assumption.
destruct H0. apply IHys in H1.
simpl. split; assumption.
Qed.

Lemma list_all_le : forall a n ys, a <= n -> list_all (le n) ys -> list_all (le a) ys.
intros.
induction ys.
simpl. reflexivity.
destruct H0.
apply IHys in H1.
simpl. split. rewrite H0 in H. assumption.
assumption.
Qed.

Theorem merged_sorted : forall xs ys, sorted xs -> sorted ys -> sorted (merge xs ys).
  intro xs.
  induction xs; intros.
  simpl. assumption.
  induction ys. assumption.
  simpl merge.
  destruct (nat_lte a a0); simpl; split.
  (* a <= a0 *)
      eapply IHxs.
      crush. crush.
      eapply merge_list_all.
      crush.
      simpl.
      split. assumption. apply list_all_le with (n:=a0); crush.
  (* a > a0 *)
    simpl in H0.
    destruct H0.
    apply IHys in H0.
    simpl in H0.
    assumption.
    simpl in H0.
    eapply merge_list_all with (P:=(le a0)) (xs:=(a :: xs)) (ys:= ys); intros.
    simpl.
    split.
    crush.
    simpl in H. destruct H. apply list_all_le with (n:=a); crush.
    crush.
Qed.

(*
   b. (length xs + length ys) = length (merge xs ys)
*)

Require Import Arith.

Theorem merge_adds : forall xs ys, (length xs + length ys) = length (merge xs ys).
  induction xs. crush.
  induction ys. crush.
  simpl. destruct (nat_lte a a0).
  simpl. rewrite <- IHxs with (ys:=(a0 :: ys)).
  crush. simpl in *. rewrite <- IHys. crush.
Qed.

(*
   c. In x xs \/ In x ys <-> In (merge xs ys)
*)

Theorem merged_in : forall x xs ys, In x xs \/ In x ys <-> In x (merge xs ys).
  induction xs. crush.
  induction ys. crush.
  simpl. destruct (nat_lte a a0).
  simpl. rewrite <- IHxs with (ys:=(a0 :: ys)). crush.
  simpl in *. rewrite <- IHys. crush.
Qed.

(*

2. Show that

   a. list_all sorted xs -> list_all sorted (merge_pairs xs)

*)

Require Import Arith.Even.

Lemma length0 : forall A (xs : list A), length xs = 0 <-> xs = [].
induction xs. crush. simpl. split; crush.
Qed.

Lemma length0' : forall A (xs : list A), 0 = length xs <-> xs = [].
induction xs. crush. simpl. split; crush.
Qed.

Lemma not_odd_and_even : forall n, odd n -> even n -> False.
crush. apply not_even_and_odd with (n:=n); assumption.
Qed.

Lemma oddS : forall m, odd (S m) -> even m.
intros. destruct m.
crush. specialize even_odd_dec with (n:=(S m)).
intros. destruct H0. assumption. contradict H.
intro. apply not_even_and_odd with (n:=(S (S m))).
constructor. assumption. assumption.
Qed.

Lemma evenS : forall m, even (S m) -> odd m.
intros. induction m.
contradict H. crush. assert (odd 1). crush.
apply not_even_and_odd with (n:=1); assumption.
specialize even_odd_dec with (n:=(S m)).
intros. destruct H0. apply IHm in e.
contradict H. intro. apply not_even_and_odd with (n:=(S (S m))).
assumption. constructor. constructor. assumption. assumption.
Qed.

Lemma evenSn: forall m, (even m -> (exists n, m = 2*n)) /\ (odd m -> exists n, m = S(2*n)).
induction m.
split. intros. exists 0. simpl. reflexivity.
intro. contradict H. crush. assert (even 0). crush.
apply not_even_and_odd with (n:=0); assumption.
split. destruct IHm.
intro. apply evenS in H1. apply H0 in H1.
destruct H1. rewrite H1. exists (S x). crush.
destruct IHm. intro. apply oddS in H1. apply H in H1.
destruct H1. rewrite H1. exists x. crush.
Qed.

Lemma evenSn2: forall m, (exists n, m = 2*n) -> even m.
intros. destruct H. simpl in H. assert( x + (x + 0) = x+x). crush. rewrite H0 in H. clear H0.
specialize even_odd_dec with (n:=x).
intros. rewrite H. destruct H0.
apply even_even_plus; assumption.
apply odd_even_plus; assumption.
Qed.

Lemma test: forall A (xs: list A), even (length xs) -> (length xs <> 0) -> (exists a b t, (xs = a :: b :: t) /\ (even (length t))).
intros.
destruct xs. contradict H0.
simpl. reflexivity.
destruct xs.
contradict H.
simpl. intro.
assert (odd 1). crush.
apply not_even_and_odd with (n:=1); assumption.
exists a. exists a0. exists xs. split. reflexivity.
simpl in H. apply evenS in H. apply oddS in H. assumption.
Qed.

Lemma neq : forall n, n<>0 <-> exists m, n = S m.
crush. destruct n. crush. exists n. reflexivity. Qed.

Lemma list_all_tail : forall A P (l:A) (r: list A), list_all P r /\ P l <-> list_all P (r ++ [l]).
intros. induction r; simpl; crush.
Qed.

Lemma app_cons : forall A (x:A) xs, x :: xs = [x] ++ xs.
crush.
Qed.

Lemma merge_pairs_app: forall xs l, even (length xs) -> merge_pairs (xs ++ [l]) = (merge_pairs xs) ++ [l].
  Lemma merge_pairs_app': forall n xs l, (n*2) = length xs -> merge_pairs (xs ++ [l]) = (merge_pairs xs) ++ [l].
    induction n.
    intros. simpl in H. apply eq_sym in H. rewrite length0 in H. rewrite H.
    simpl. reflexivity.
    intros.
    pose proof test.
    assert (even (length xs)). apply evenSn2. exists (S n).
    rewrite mult_comm. apply eq_sym. assumption.
    specialize H0 with (xs:=xs).
    apply H0 in H1. destruct H1. destruct H1. destruct H1.
    destruct H1. rewrite H1. simpl.
    assert (merge_pairs x1 ++ [l] = merge_pairs (x1 ++ [l])).
    apply eq_sym. apply IHn.
    rewrite H1 in H. simpl in H. injection H. intros. assumption.
    rewrite H3. reflexivity.
    apply neq. rewrite <- H. simpl. exists (S (n * 2)). reflexivity.
  Qed.
  intros. apply evenSn in H. destruct H.
  apply merge_pairs_app' with (n:=x). crush.
Qed.

Lemma odd0 : odd 0 -> False. intro. assert (even 0). crush. apply not_even_and_odd with (n:=0); assumption. Qed.

Ltac mymagic := match goal with
  | [ H: odd 0 |- _ ] => apply odd0 in H; crush
  | [ H: odd (length []) |- _ ] => simpl in H; apply odd0 in H; crush
  | [ H: context[ _ + length [_]] |- _ ] => simpl length in H; rewrite plus_comm in H; simpl plus in H
  | [ H: context[(length (_ ++ [_]))] |- _ ] => rewrite app_length in H; mymagic
  | [ H: 0 = length ?xs |- _ ] => apply eq_sym in H; apply length0 in H
end.

Lemma evenSn' : forall A (Q: list A -> Prop), (forall n (xs : list A), 2*n = length xs -> Q xs) <-> (forall (xs : list A), (even (length xs)) -> Q xs).
  intros. split.
  intros. apply evenSn in H0.  destruct H0. apply eq_sym in H0. apply H in H0. assumption.
  intros. eapply H. apply evenSn2. exists n. crush.
Qed.

Lemma list_odd : forall A (xs:list A), (odd (length xs)) -> (exists (ys:list A) (t:A), xs = ys ++ [t] /\ even (length ys)).
  intros.
  assert (xs <> []). crush. mymagic.
  exists (removelast xs). apply exists_last in H0.
  destruct H0. destruct s. exists x0. rewrite e. rewrite removelast_app. simpl.
  rewrite app_nil_r. split. reflexivity.
  rewrite e in H. mymagic. apply oddS in H. assumption. crush.
Qed.

Ltac third := let HH:=fresh in let H2:=fresh "X" in intro n; induction n; [
        (* Base Case *)
        simpl mult; try (split; intros x HH); try rewrite length0' in HH; subst; simpl in *; [ crush; try mymagic; crush | .. ]; try assumption |
        (* Start of Recursive Case *)
        intros xs Hy;
        remember (2 * S n) as m;
        assert (even m /\ m <> 0) as Hx; [ split; [ apply evenSn2; exists (S n); assumption | crush ] | ];
        specialize test with (xs:=xs); intros Hm; rewrite <- Hy in Hm;
        destruct Hx; destruct Hm as [x H2]; [ assumption | assumption | .. ] ];
        destruct H2 as [y H2]; destruct H2 as [z H2]; destruct H2; subst.

Theorem merge_pairs_sorted : forall xs, list_all sorted xs -> list_all sorted (merge_pairs xs).
  Lemma merge_pairs_sorted_even : forall xs, (even (length xs)) -> list_all sorted xs -> list_all sorted (merge_pairs xs).
    erewrite <- evenSn'. third. crush. apply merged_sorted; assumption.

  Qed.
  intros.
  remember (length xs) as n.
  specialize even_odd_dec with (n:=n). intros Hx. destruct Hx.
   + apply merge_pairs_sorted_even; [ crush | .. ]; try assumption.
   + specialize list_odd with (xs:=xs). intros Hy. subst. apply Hy in o.
     destruct o eqn:Hz. destruct Hz eqn:Ha. destruct e eqn:Hb. crush.
     rewrite merge_pairs_app; [ | assumption ].
     (* apply eq_sym. rewrite fold_right_app. *)
     rewrite H1 in H. apply list_all_tail in H. destruct H.
     apply list_all_tail; (try split); try assumption.
     apply merge_pairs_sorted_even. assumption. assumption.
Qed.

(*
   b. (sum of lengths of lists in xs) =
        (sum of lengths of lists in merge_pairs xs)
*)

Definition sum_length (a:list nat) (b:nat) := (plus (length a) b).

Hint Unfold sum_length.

Theorem sum_merge_pairs : forall (xs: list (list nat)), (fold_right sum_length 0 xs) = (fold_right sum_length 0 (merge_pairs xs)).
  Lemma sum_merge_pairs_even : forall d xs, (even (length xs)) -> (fold_right sum_length d xs) = (fold_right sum_length d (merge_pairs xs)).
    intro d. erewrite <- evenSn'.
    third. crush. unfold sum_length. fold sum_length. rewrite <- merge_adds. erewrite <- IHn; [ | crush]. crush.
  Qed.
  intros.
  remember (length xs) as n.
  specialize even_odd_dec with (n:=n). intros Hx. destruct Hx.
   + apply sum_merge_pairs_even; [ crush | .. ]; try assumption.
   + specialize list_odd with (xs:=xs). intros Hy. subst. apply Hy in o.
     destruct o eqn:Hz. destruct Hz eqn:Ha. destruct e eqn:Hb.
     destruct a as [aa ab]. rewrite aa.
     rewrite merge_pairs_app; [ | assumption ].
     (* End Generic Skeleton *)
     rewrite fold_right_app. apply eq_sym. rewrite fold_right_app.
     rewrite <- sum_merge_pairs_even; [ | assumption ].
     subst. reflexivity.
Qed.

(*
   c. (x is in one of the lists in xs) <->
        (x is in one of the lists in merge_pairs xs)

*)
Definition InOneOf (x:nat) (xs: list (list nat)) : Prop :=
 exists subl, (In x subl) /\ (In subl xs).

Hint Unfold InOneOf.

Lemma In_app : forall A (x: A) xs ys, In x (xs ++ ys) <-> In x xs \/ In x ys.
  intros. induction xs; crush.
Qed.

Lemma InOneOf_app : forall x xs ys, InOneOf x (xs ++ ys) <-> InOneOf x xs \/ InOneOf x ys.
  intros. unfold InOneOf.
  split; intros.
  do 2 destruct H; rewrite In_app in H0.
  { destruct H0.
    + left. exists x0. split; assumption.
    + right. exists x0. split; assumption.
  }
  do 2 destruct H; exists x0; rewrite In_app; crush.
Qed.

Lemma InOneOf_one : forall x y, InOneOf x [y] <-> In x y.
  crush. unfold InOneOf in H. crush. unfold InOneOf. exists y. crush.
Qed.

Lemma InOneOf_cons : forall x xs y, InOneOf x (y :: xs) <-> In x y \/ InOneOf x xs.
  intros. rewrite app_cons. rewrite <- InOneOf_one. eapply InOneOf_app.
Qed.

Theorem InPairs : forall (x:nat) (xs: list (list nat)), InOneOf x xs <-> InOneOf x (merge_pairs xs).
  Lemma InPairs_even : forall x xs, (even (length xs)) -> (InOneOf x xs <-> InOneOf x (merge_pairs xs)).
     intro d. erewrite <- evenSn'. third.
     simpl merge_pairs. repeat rewrite InOneOf_cons.
     rewrite <- merged_in. rewrite IHn; [ | crush ].
     crush.
  Qed.
  intros.
  remember (length xs) as n.
  specialize even_odd_dec with (n:=n). intros Hx. destruct Hx.
   + apply InPairs_even; [ crush | .. ]; try assumption.
   + specialize list_odd with (xs:=xs). intros Hy. subst. apply Hy in o.
     destruct o eqn:Hz. destruct Hz eqn:Ha. destruct e eqn:Hb.
     destruct a as [aa ab]. rewrite aa.
     rewrite merge_pairs_app; [ | assumption ].
     (* End Generic Skeleton *)
     rewrite InOneOf_app. apply iff_sym. rewrite InOneOf_app.
     rewrite InPairs_even with (xs:=x0); [ | assumption ].
     reflexivity.
Qed.

(*

3. Show that

   a. list_all sorted xs -> sorted (merge_iter xs)

*)

Theorem merge_iter_sorted : forall xs, list_all sorted xs -> sorted (merge_iter xs).
intros.
functional induction (merge_iter xs).
crush. crush. apply merge_pairs_sorted in H. apply IHl in H. assumption.
Qed.

(*
   b. (sum of lengths of lists in xs) = length of (merge_iter xs)
*)

Theorem merge_iter_length : forall xs, (fold_right sum_length 0 xs) = length (merge_iter xs).
intros.
functional induction (merge_iter xs).
crush. crush. unfold sum_length. crush.
rewrite sum_merge_pairs. assumption.
Qed.

(*
   c. (x is in one of the lists in xs) <-> In x (merge_iter xs)
*)

Theorem merge_iter_in : forall x xs, InOneOf x xs <-> In x (merge_iter xs).
intros.
functional induction (merge_iter xs).
crush. unfold InOneOf in H. destruct H. crush.
crush. unfold InOneOf in H. crush.
unfold InOneOf. exists h. crush.
rewrite InPairs. assumption.
Qed.

(*
4.  Show that
    a. make_lists xs is sorted
    b. In x xs <-> (x is in one of the lists in make_lists xs)
    c. length xs = (sum of the lengths of the lists in make_lists xs)
*)

Theorem make_lists_sorted : forall xs, list_all sorted (make_lists xs).
induction xs. crush. simpl. crush.
Qed.

Theorem make_lists_in : forall x xs, In x xs <-> InOneOf x (make_lists xs).
intros. induction xs.
crush. unfold InOneOf in H. destruct H. crush.
simpl. rewrite app_cons. rewrite InOneOf_app.
split. intros.
destruct H. left. rewrite H. unfold InOneOf. exists [x]. crush.
apply IHxs in H. right. assumption.
intros. destruct H. left. unfold InOneOf in H. destruct H. crush. crush.
Qed.

Theorem make_lists_length : forall xs, length xs = (fold_right sum_length 0 (make_lists xs)).
intros. induction xs. crush.
simpl. unfold sum_length. fold sum_length. crush.
Qed.

 (*

5.  Show that sort_corr xs (merge_sort xs)

*)

Theorem merge_corr: forall xs, sort_corr xs (merge_sort xs).
crush. unfold sort_corr. unfold merge_sort.
split. apply merge_iter_sorted. apply make_lists_sorted.
split. unfold sublist. intros.
apply merge_iter_in. apply make_lists_in. assumption.
rewrite <- merge_iter_length. apply make_lists_length.
Qed.

(*

6.  Define a better definition of correctness for sorts (sort_corr').

*)

Require Import Permutation.

Definition sort_corr' (xs ys:list nat) : Prop :=
  sorted ys /\ Permutation xs ys.

(* This is better because *)
Goal sort_corr ([1;1;2;2;3;3]) ([1;1;2;2;2;3]).
  unfold sort_corr.
  unfold sorted.
  unfold sublist.
  simpl.
  crush.
Qed.

Goal ~ sort_corr' ([1;1;2;2;3;3]) ([1;1;2;2;2;3]).
  unfold sort_corr'. crush. clear -H1.
  repeat apply Permutation_cons_inv in H1.
  apply Permutation_length_2_inv in H1.
  destruct H1; crush.
Qed.

(* Let's show that this is a stronger condition *)
Theorem sort_corr'_strong : forall xs ys, sort_corr' xs ys -> sort_corr xs ys.
  intros. unfold sort_corr. unfold sort_corr' in H. crush.
  - unfold sublist. intros. apply Permutation_in with (l:=xs); assumption.
  - apply Permutation_length; assumption.
Qed.

(* And let's show that merge still satisfies this *)
Fixpoint flatten {A: Type} (xs: list (list A)) : list A :=
  match xs with
   | [] => []
   | A::B => (app A (flatten B))
  end.

Lemma flatten_app : forall x (xs: list (list nat)), flatten (xs ++ [x]) = (flatten xs) ++ x.
  intros. induction xs; crush.
Qed.

Lemma make_lists_inv : forall xs, xs = (flatten (make_lists xs)).
  induction xs. crush. crush.
Qed.

Theorem merge_pairs_permutation : forall xs, Permutation (flatten xs) (flatten (merge_pairs xs)).
Lemma merge_pairs_permutation_even : forall xs, even (length xs) -> Permutation (flatten xs) (flatten (merge_pairs xs)).
  Lemma merge_pairs_permutation_even' : forall n xs, 2*n=length xs -> Permutation (flatten xs) (flatten (merge_pairs xs)).
    Lemma merge_permutation : forall xs ys, Permutation (xs++ys) (merge xs ys).
      induction xs. crush.
      induction ys.
      - crush. apply perm_skip. specialize IHxs with (ys:=[]).
        rewrite app_nil_r in IHxs. apply Permutation_sym. assumption.
      - simpl. destruct (nat_lte a a0).
        apply perm_skip. eapply IHxs.
        apply Permutation_trans with (l' := (a0 :: a :: xs ++ ys)).
        + admit.
        + unfold merge in IHxs. fold merge in IHxs. apply perm_skip. apply IHys.
    Qed.
    third.
    specialize IHn with (xs:=z).
    assert (2*n = length z). crush.
    apply IHn in H1. clear IHn.
    crush.
    rewrite app_assoc.
    apply Permutation_app.
    apply merge_permutation.
    assumption.
  Qed.
  erewrite <- evenSn'. apply merge_pairs_permutation_even'.
  Qed.
  Show.
  intros.
  remember (length xs) as n.
  specialize even_odd_dec with (n:=n). intros Hx.
  destruct Hx. apply merge_pairs_permutation_even. crush.
  specialize list_odd with (xs:=xs). intros Hy. subst. apply Hy in o.
  destruct o eqn:Hz. destruct Hz eqn:Ha. destruct e eqn:Hb. crush.
  rewrite merge_pairs_app.
  remember (fold_right sum_length 0 (x1 ++ [x2])).
  do 2 rewrite flatten_app.
  apply Permutation_app_tail.
  apply merge_pairs_permutation_even. assumption.
  assumption.
Qed.

Theorem merge_iter_perm : forall xs, Permutation (merge_iter xs) (flatten xs).
  crush. functional induction (merge_iter xs).
  crush. crush. rewrite app_nil_r. apply Permutation_refl.
  apply Permutation_trans with (l' := flatten (merge_pairs (h1 :: h2 :: xs'))).
  assumption.
  apply Permutation_sym. apply merge_pairs_permutation.
Qed.

Theorem sort_corr'_merge : forall xs, sort_corr' xs (merge_sort xs).
  intros. unfold sort_corr'.
  specialize merge_corr with (xs:=xs).
  split. unfold sort_corr in H. crush.
  unfold merge_sort.
  unfold sort_corr in H.
  unfold merge_sort.
  destruct (merge_sort xs).
  crush. apply length0 in H2. crush.
  rewrite make_lists_inv with (xs:=xs) at 1.
  apply Permutation_sym.
  apply merge_iter_perm.
Qed.

author: Keno


text:
(*
Exercise: 3 stars (binary)
Consider a different, more efficient representation of natural numbers using a binary rather
than unary system. That is, instead of saying that each natural number is either zero or the
successor of a natural number, we can say that each binary number is either

    zero,
    twice a binary number, or
    one more than twice a binary number.

(a) First, write an inductive definition of the type bin corresponding to this description of
binary numbers.

(Hint: Recall that the definition of nat from class,
    Inductive nat : Type :=
      | O : nat
      | S : nat → nat.

says nothing about what O and S "mean." It just says "O is in the set called nat, and if n is
in the set then so is S n." The interpretation of O as zero and S as successor/plus one comes
from the way that we use nat values, by writing functions to do things with them, proving
things about them, and so on. Your definition of bin should be correspondingly simple; it is
the functions you will write next that will give it mathematical meaning.)

(b) Next, write an increment function for binary numbers, and a function to convert binary
numbers to unary numbers.
(c) Write some unit tests for your increment and binary-to-unary functions. Notice that
incrementing a binary number and then converting it to unary should yield the same result as
first converting it to unary and then incrementing.

 *)

author: kisom

repo: sf

save_path: github-repos/coq/kisom-sf