Require Import Arith.

Parameters (prime_divisor : nat -> nat)
           (prime : nat -> Prop)
           (divides : nat -> nat -> Prop).

Open Scope nat_scope.

Check (prime (prime_divisor 220)).
Check (divides (prime_divisor 220) 20).

Check (divides 3).

Parameter binary_word : nat -> Set.

Definition short : Set := binary_word 32.
Definition long : Set := binary_word 64.

(* I have a hard time understanding the difference between Prop and Set.
I currently have the sense that Prop is the sort used for logic. While Set is the sort
used for programs.
Which, would mean that "not" could not be applied to Set. Which makes sense:
what's the negation of a program?
*)

Check not.

Check (let d := prime_divisor 220 in prime d /\ divides d 220).

Require Import List.

Parameters (decomp1 : nat -> list nat)
           (decomp2 : nat -> nat*nat).

Check (decomp1 220).
Check list nat.
Check (decomp2 2123).

(* OK. The type of pair is A*B while the term of pairs uses the "standard" notation
(A,B). *)
Check (4,2).

(* I guess prod is the non infix operator version of *? but only on the type level? *)
Check prod.
Check (prod nat nat).

(* How can I check what the * type operator is then? *)

Check pair.
Check (pair 4 3).
Check (pair 4 3 : prod nat nat).

Check le_n.
Check le_S.
Check (le_n 36).
Definition le_36_37 := le_S 36 36 (le_n 36).
Check le_36_37.
Definition le_36_38 := le_S 36 37 le_36_37.
Check le_36_38.
Check (le_S _ _ (le_S _ _ (le_n 36))).

Parameter iterate : forall A:Set, (A->A) -> nat -> A -> A.
Check (iterate nat).
Check (iterate _ (mult 2)).

(* twice if a function that applies a function twice to a given value.
We have to explicitly account for the application of the type to the function.
 *)

Definition twice : forall A:Set, (A->A) -> A -> A
  := fun A f a => f (f a).

Check mult.
Check (mult 2).
Check (twice nat (mult 2)).

Eval compute in
    (twice nat (mult 2) 2).
Eval compute in
    (twice _ (twice _ (mult 2)) 2).
Eval compute in
    (twice (nat->nat) (fun f x => f (f x)) (mult 3) 1).

Theorem le_i_SSi : forall i : nat, i <= S (S i).
  Proof (fun i:nat => le_S _ _ (le_S _ _ (le_n i))).

Definition compose : forall A B C : Set, (A->B) -> (B->C) -> A -> C
  := fun A B C f g x => g (f x).

Print compose.

Require Import ZArith.

Check (fun (A:Set) (f: Z-> A) => compose _ _ _ Z_of_nat f).

Check (compose _ _ _ Zabs_nat (plus 32) (-45)%Z).

Eval compute in
    (compose _ _ _ Zabs_nat (plus 32) (-45)%Z).

Check (le_i_SSi 1515).

Check (le_S _ _ (le_i_SSi 1515)).

(* The book claims that this will fail. In the version of Coq I'm using, 8.4, the
joker is replaced by an existential variable. At least that's what I think is happening
I'm not entirely sure...
*)
Check (iterate _ (fun x => x) 23).

(* With at least Coq 8.4 the implicit argument system is much improved IMO.
Implicit arguments can be defined a priori by surrounding the arguments with curly
brackets. The book was written when this was the standard method:

Implicit Arguments compose [A B C].

Which is an posteriori method. With at least coq 8.4 there is a new posteriori method.
This method better matches the a priori method of curly brackets IMO.
*)
Arguments compose {A B C} f g x.
Check (compose Zabs_nat (plus 34)).

Eval compute in
    (compose Zabs_nat (plus 34) 223%Z).

(* how nice! *)

Check (compose (C := Z) S).

(* The follow also works with coq 8.4 but inserts an existential variable *)
Check (compose S).

(* I wonder how to use these existential variables? *)

(* Lets try with.. *)
Reset compose.
Set Implicit Arguments.

Definition compose (A B C : Set) (f : A -> B) (g : B -> C) (a:A) := g (f a).
Definition thrice (A:Set) (f:A->A) := compose f (compose f f ).
Unset Implicit Arguments.

Print compose.

(* Ah neat! The print tells me which arguments are implicit!.
Lets try using the curly bracket method.
*)
Reset compose.
Definition compose {A B C} (f : A->B) (g : B->C) (a:A) := g (f a).
Print compose.

(* Well, that was almost the same but A B C are "maximally inserted".
I presume this means that the types are the upper bounds of the inferred sort?
Does the Arguments square brackets for implicit arguments which are not maximally
inserted work as well?
*)
Reset compose.
(* nope! The following does not compile.
Definition compose [A B C] (f : A->B) (g : B->C) (a:A) := g (f a).
*)

Definition compose {A B C : Set} (f : A->B) (g : B->C) (a:A) := g (f a).
Print compose.

(* Well, that was the same as before when I didn't specify : Set *)

(* Strange... I've already imported ZArith. I had to import ZArith again. Perhaps
due to the previous Reset?
*)
Require Import ZArith.
Check (list Z). (* sort Set *)

Section A_declared.
  Variables (A:Set)(P Q:A -> Prop)(R:A->A->Prop).

  Theorem all_perm : (forall a b :A, R a b) -> forall a b:A, R b a.
    intro.
    exact (fun a b : A => H b a).
  Qed.

  Theorem all_imp_dist : (forall a:A, P a -> Q a) -> (forall a:A, P a) -> forall a:A, Q a.
    intros H0 H1.
    exact (fun a : A => H0 a (H1 a)).
  Qed.

  Theorem all_delta : (forall a b:A, R a b) -> (forall a:A, R a a).
    intros H0.
    exact (fun a : A => H0 a a).
  Qed.
End A_declared.

Definition my_plus : nat->nat->nat := iterate nat S.
Eval compute in (my_plus 3 4).

(* We never defined iterate. Just declared it. So Eval resulted in
"iterate nat S 3 4"
which is as good as we can do with just a declaration.
Neat!
*)

Definition my_mult (n p:nat) : nat := iterate nat (my_plus n) p 0.
Eval compute in (my_mult 3 4).

Definition my_expo (x n:nat) : nat := iterate nat (my_mult x) n 1.

Definition ackermann (n:nat) : nat -> nat :=
  iterate (nat -> nat)
          (fun (f:nat -> nat) (p:nat) => iterate nat f (S p) 1)
          n
          S.

(* Well, now I do some strange stuff. I want to check that a term when interpreted as a proposition
has a given type.
So I define the term. Then check that the term as a proposition has a type.
Then I prove the term can be inhabited.
This is weird, but hey, it works. I'm sure there is a better way.
*)
Section Exercise_4_4.
  Definition id := forall A:Set, A -> A.
  Check (id -> Prop) : Type.
  Theorem id_spec : id.
  Proof.
    unfold id.
    intros.
    apply H.
  Qed.

  Print id_spec.

  Definition diag := forall A B:Set, (A->A->B)->A->B.

  Check (diag -> Prop) : Type.

  Theorem diag_spec : diag.
  Proof.
    unfold diag.
    exact (fun (A B : Set) (f : A->A->B) A => f A A).
  Qed.

  Definition permute := forall A B C:Set, (A->B->C)->B->A->C.
  Check (permute -> Prop) : Type.

  Theorem permute_spec : permute.
  Proof.
    unfold permute.
    exact (fun (A B C:Set) (f : A->B->C) B A => f A B).
  Qed.

  Print permute_spec.

End Exercise_4_4.

Check (forall P:Prop, P->P).
Check (fun (P:Prop) (p:P) => p).

Section Exercise_4_5.
  Definition all_perm_def := forall (A:Type) (P:A->A->Prop), (forall x y:A, P x y)
                                                             -> forall x y:A, P y x.

  Theorem all_perm_4_5 : all_perm_def.
  Proof.
    unfold all_perm_def.
    intros H_A H_P H_0.
    exact (fun (x y:H_A) => H_0 y x).
  Qed.

  Print all_perm_4_5.

  Definition resolution_def :=
    forall (A:Type) (P Q R S:A -> Prop), (forall a:A, Q a -> R a -> S a)
                                           -> (forall b:A, P b -> Q b)
                                                -> (forall c:A, P c -> R c -> S c).

  Theorem resolution_4_5 : resolution_def.
  Proof.
    unfold resolution_def.
    intros.
    apply H.
    apply H0.
    assumption.
    assumption.
  Qed.

  Print resolution_4_5.
End Exercise_4_5.

Theorem thirty_six : 9*4=6*6.
  apply (refl_equal 36).
Qed.

Print thirty_six.


Require Import SfLib.
Require Import Maps.
Require Import Types.
Require Import STLCWA.

Module SubTest.

Inductive ty : Type :=
    | TNat : ty
    | TTop : ty
    | TProd : ty -> ty -> ty
    | TArrow : ty -> ty -> ty.

Reserved Notation "x '<:' y" (at level 40).

Inductive subtype_of : ty -> ty -> Prop :=
    | refl_sub : forall x, x <: x
    | trans_sub : forall x y z,
                        x <: y ->
                        y <: z ->
                        x <: z
    | prod_sub : forall x x' y y',
                    x <: x' ->
                    y <: y' ->
                    (TProd x y) <: (TProd x' y')
    | arrow_sub : forall x x' y y',
                    x' <: x ->
                    y <: y' ->
                    (TArrow x y) <: (TArrow x' y')
    | sub_top : forall x,
                    x <: TTop
    where "x '<:' y " := (subtype_of x y).

Hint Constructors subtype_of.

Parameter (S T U V A B C: ty).

Parameter (Rule1 : S <: T) (Rule2 : U <: V).

Hint Resolve Rule1 Rule2 : example_database1.

Example
    ex1_1:
        TArrow S T <: TArrow S T.
    eauto.

Qed.

Example ex1_2 :
        TArrow TTop U <: TArrow S TTop.

    eauto.
Qed.

Example ex1_3 :
        TArrow (TArrow C C) (TProd A B) <: TArrow (TArrow C C) (TProd TTop B).
        eauto.
Qed.

Example ex1_4 :
        TArrow T (TArrow T U) <: TArrow S (TArrow S V).
        eauto with example_database1.
Qed.

Theorem subtype_dec :
    forall A B,
        {A <: B} + {~ A <: B}.

    intro A; induction A; intro B; induction B; eauto.
    destruct IHB1; destruct IHB2.
    right; intro. inversion H; subst. inversion H0; subst.
Abort.

(* I think this definition has some problem. Because it's not decidable. *)

Example ex1_5:
    ~TArrow (TArrow T T) U <: TArrow (TArrow S S) V.

    Abort.

Example ex1_6:
    TArrow (TArrow (TArrow T S) T) U <:
    TArrow (TArrow (TArrow S T) S) V.
    eauto with example_database1.
Qed.

Example ex1_7:
    ~TProd S V <: TProd T U.
    Abort.

Parameter (Student Person : ty).
Parameter (Rule3 : Student <: Person).

Hint Resolve Rule3 : example1_database.
Example ex2:
        (TArrow TTop Student) <:
        (TArrow Person Student) /\
        (TArrow Person Student) <:
        (TArrow Student Person) /\
        (TArrow Student Person) <:
        (TArrow Student TTop) /\
        (TArrow Student TTop) <:
        TTop.
        repeat (split; eauto with example1_database).
Qed.

Example ex3:
    ~(forall S T,
        S <: T ->
        (TArrow S S) <: (TArrow T T)).
Admitted.

Example ex3_2:
    ~(forall S,
        S <: (TArrow A A) ->
        exists T,
            S = TArrow T T /\ T <: A).
Admitted.

Example ex3_3:
    forall S T1 T2,
        (S <: TArrow T1 T2) ->
        exists S1 S2,
            S = TArrow S1 S2 /\
            T1 <: S1 /\
            S2 <: T2.

    intros S T1 T2 h.
    remember S as s.
    remember (TArrow T1 T2) as q.
    generalize Heqs. induction h; subst.
    eauto.

    intros.
    Abort.

Example ex3_4:
    ~(exists S,
        S <: (TArrow S S)).
Admitted.

Example ex3_5:
    exists S,
        (TArrow S S) <: S.
    exists TTop; eauto.
Qed.

Example ex3_6:
    forall S T1 T2,
        S <: (TProd T1 T2) ->
        exists S1 S2,
            S = (TProd S1 S2) /\
            S1 <: T1 /\
            S2 <: T2.
Admitted.

(** **** Exercise: 2 stars (small_large_4)  *)
(**
   - What is the _smallest_ type [T] that makes the following
     assertion true?
       exists S,
         empty |- (\p:(A*T). (p.snd) (p.fst)) : S
   ?????
   - What is the _largest_ type [T] that makes the same
     assertion true?
   ?????
[] *)

(** **** Exercise: 2 stars (smallest_1)  *)
(** What is the _smallest_ type [T] that makes the following
    assertion true?
      exists S, exists t,
        empty |- (\x:T. x x) t : S
    ?????
]]
[] *)

(** **** Exercise: 3 stars, optional (count_supertypes)  *)
(** How many supertypes does the record type [{x:A, y:C->C}] have?  That is,
    how many different types [T] are there such that [{x:A, y:C->C} <:
    T]?  (We consider two types to be different if they are written
    differently, even if each is a subtype of the other.  For example,
    [{x:A,y:B}] and [{y:B,x:A}] are different.) *)

End SubTest.


Require Import QArith.

(** ##############################################################################
QARITH LEMMAS
################################################################################*)

Lemma Qplus_neg: forall a b, a - b == a + (-b).
Proof.
  intros.
  ring.
Qed.

Lemma Qplus_opp_l : forall q, -q + q == 0.
Proof. intros; ring. Qed.

Lemma Qdiv_mult_inv: forall a b, a / b == a * /b.
Proof.
  intros.
  auto with qarith.
Qed.

Lemma Qmult_neg_1: forall a, a * -(1) == -a.
Proof.
  intros.
  ring.
Qed.

Lemma Qmult_inv_l: forall a, ~ a == 0 -> /a * a == 1.
Proof.
  intros.
  rewrite Qmult_comm.
  rewrite Qmult_inv_r; auto with qarith.
Qed.

Lemma Qplus_double: forall a, a + a == (2 # 1)*a.
Proof.
  intros.
  ring.
Qed.

Lemma Qplus_half: forall a, a/(2#1) + a/(2#1) == a.
Proof.
  intros.
  rewrite Qplus_double.
  rewrite Qmult_div_r; [|unfold Qeq]; auto with qarith.
Qed.

Lemma Qneg_0: - 0 == 0.
Proof.
  ring.
Qed.

Lemma Qeq_neg : forall a b, - a == b <-> a == -b.
Proof.
  intros.
  split; intros;
    rewrite <- Qmult_neg_1;
    apply Qmult_inj_r with (z:=-(1)); auto with qarith;
    rewrite !Qmult_neg_1, Qopp_opp; trivial.
Qed.

Lemma Qdiv_neg_l: forall a b, (-a)/b == -(a/b).
Proof.
  intros.
  rewrite Qdiv_mult_inv.
  rewrite <- Qmult_neg_1.
  rewrite <- Qmult_assoc.
  rewrite Qmult_comm.
  rewrite <- Qmult_assoc.
  rewrite Qmult_comm.
  rewrite Qmult_neg_1.
  rewrite Qmult_comm.
  rewrite Qdiv_mult_inv.
  reflexivity.
Qed.

Lemma Qmult_neg_l: forall a b, (-a)*b == -(a*b).
Proof.
  intros *.
  rewrite <- Qmult_neg_1, Qmult_comm, Qmult_assoc, Qmult_neg_1, Qmult_comm.
  reflexivity.
Qed.

Lemma Qopp_lt_compat : forall p q, p<q -> -q < -p.
Proof.
  intros (a1,a2) (b1,b2); unfold Qlt; simpl.
  rewrite !Z.mul_opp_l. omega.
Qed.

Lemma Qlt_0_neg_lt_not_r: forall a, 0 < -a -> ~ 0 < a.
Proof.
  intros.
  intuition.
  apply Qopp_lt_compat in H0.
  rewrite Qneg_0 in H0.
  apply Qlt_trans with (x:=0) (y:=-a) (z:=0) in H; trivial.
  apply Qlt_irrefl in H as G.
  contradiction.
Qed.

Lemma Qlt_0_pos_lt_not_l: forall a, a < 0 -> ~ -a < 0.
Proof.
  intros.
  intuition.
  apply Qopp_lt_compat in H0.
  rewrite Qneg_0 in H0.
  rewrite Qopp_opp in H0.
  apply Qlt_trans with (x:=0) (y:=a) (z:=0) in H; trivial.
  apply Qlt_irrefl in H as G.
  contradiction.
Qed.

Lemma Qlt_0_neg_lt_not_l: forall a, -a < 0 -> ~ a < 0.
Proof.
  intros.
  intuition.
  apply Qopp_lt_compat in H0.
  rewrite Qneg_0 in H0.
  apply Qlt_trans with (x:=0) (y:=-a) (z:=0) in H; trivial.
  apply Qlt_irrefl in H as G.
  contradiction.
Qed.

Lemma Qlt_not_lt: forall a b, a < b -> ~ b < a.
Proof.
  intros.
  auto with qarith.
Qed.

Lemma Qmult_lt_0 : forall a b, b > 0 -> a * b < 0 <-> a < 0.
Proof.
  intros * Hb.
  split; intros H.
  {
    apply Qmult_lt_r with (z:=/b) in H.
    - rewrite <- !Qdiv_mult_inv, Qdiv_mult_l in H; auto with qarith.
      rewrite Qdiv_mult_inv, Qmult_0_l in H; trivial.
    - apply Qinv_lt_0_compat; trivial.
  }
  apply Qmult_lt_r with (z:=/b).
  - apply Qinv_lt_0_compat; trivial.
  - rewrite <- !Qdiv_mult_inv, Qdiv_mult_l; auto with qarith.
    rewrite Qdiv_mult_inv, Qmult_0_l; trivial.
Qed.

Lemma Qmult_0_lt : forall a b, b > 0 -> a * b > 0 <-> a > 0.
Proof.
  intros * Hb.
  split; intros H.
  {
    apply Qmult_lt_r with (z:=/b) in H.
    - rewrite <- !Qdiv_mult_inv, Qdiv_mult_l in H; auto with qarith.
      rewrite Qdiv_mult_inv, Qmult_0_l in H; trivial.
    - apply Qinv_lt_0_compat; trivial.
  }
  apply Qmult_lt_r with (z:=/b).
  - apply Qinv_lt_0_compat; trivial.
  - rewrite <- !Qdiv_mult_inv, Qdiv_mult_l; auto with qarith.
    rewrite Qdiv_mult_inv, Qmult_0_l; trivial.
Qed.

Lemma Qmult_eq_0_l : forall a b, b > 0 -> a * b == 0 <-> a == 0.
Proof.
  intros * Hb.
  split; intros H.
  {
    apply Qmult_inj_r with (z:=b); auto with qarith.
    rewrite Qmult_0_l; trivial.
  }
  apply Qmult_inj_r with (z:=b) in H; auto with qarith.
  rewrite Qmult_0_l in H; trivial.
Qed.

Lemma Qeq_by_elim : forall a, ~ a < 0 -> ~ 0 < a -> a == 0.
Proof.
  intros.
  destruct (Q_dec (a) 0) as [[? | ?] | ?]; try contradiction.
  trivial.
Qed.

Lemma Qeq_0_by_eq_neg : forall a b, - a == b -> a == b -> a == 0.
Proof.
  intros * Hn He.
  rewrite He in Hn.
  destruct (Q_dec (b) 0) as [[C | C] | C].
  - apply Qlt_not_lt in C as C0.
    rewrite <- Hn in C.
    apply Qlt_0_neg_lt_not_l in C.
    apply Qeq_by_elim in C; trivial.
    rewrite <- He in C; trivial.
  - apply Qlt_not_lt in C as C0.
    rewrite <- Hn in C.
    apply Qlt_0_neg_lt_not_r in C.
    apply Qeq_by_elim in C; trivial.
    rewrite <- He in C; trivial.
  - rewrite <- He in C; trivial.
Qed.

Lemma Qplus_l_equ_sub_r: forall a b c, a + b == c <-> a == c - b.
Proof.
  intros.
  split; intros H.
  - rewrite <- Qplus_inj_r with (x:=a) (y:=c-b) (z:=b).
    rewrite Qplus_neg.
    rewrite <- Qplus_assoc with (x:=c) (y:=-b) (z:= b).
    rewrite Qplus_opp_l.
    rewrite Qplus_0_r.
    exact H.
  - rewrite <- Qplus_inj_r with (x:=a+b) (y:=c) (z:=-b).
    rewrite <- Qplus_assoc with (x:=a) (y:=b) (z:=-b).
    rewrite Qplus_opp_r.
    rewrite Qplus_0_r.
    rewrite <- Qplus_neg.
    exact H.
Qed.

Lemma Qplus_l_equ_sub_l: forall a b c, a + b == c <-> b == c - a.
Proof.
  intros.
  split; intros H.
  - apply Qplus_l_equ_sub_r.
    rewrite Qplus_comm.
    exact H.
  - apply Qplus_l_equ_sub_r in H.
    rewrite Qplus_comm in H.
    exact H.
Qed.

Lemma Qplus_r_equ_sub_r: forall a b c, c == a + b <-> c - b == a.
Proof.
  intros.
  split; intros H; apply Qeq_sym; apply Qeq_sym in H; apply Qplus_l_equ_sub_r; exact H.
Qed.

Lemma Qplus_r_equ_sub_l: forall a b c, c == a + b <-> c - a == b.
Proof.
  intros.
  split; intros H; apply Qeq_sym; apply Qeq_sym in H; apply Qplus_l_equ_sub_l; exact H.
Qed.

Lemma Qplus_l_lt_sub_r: forall a b c, a + b < c <-> a < c - b.
Proof.
  intros.
  split; intros H.
  - apply Qplus_lt_le_compat with (z:=-b) (t:=-b) in H; auto with qarith.
    rewrite <- Qplus_assoc in H.
    rewrite Qplus_opp_r in H.
    rewrite Qplus_0_r in H.
    rewrite Qplus_neg.
    assumption.
  - apply Qplus_lt_le_compat with (z:=b) (t:=b) in H; auto with qarith.
    rewrite Qplus_neg in H.
    rewrite <- Qplus_assoc in H.
    rewrite Qplus_opp_l in H.
    rewrite Qplus_0_r in H.
    assumption.
Qed.

Lemma Qplus_l_lt_sub_l: forall a b c, a + b < c <-> b < c - a.
Proof.
  intros.
  split; intros H.
  - apply Qplus_l_lt_sub_r.
    rewrite Qplus_comm.
    exact H.
  - apply Qplus_l_lt_sub_r in H.
    rewrite Qplus_comm in H.
    exact H.
Qed.

Lemma Qlt_r_sub_le_weak_l : forall a a' b c, c < a - b -> a <= a' -> c < a' - b.
Proof.
  intros * H H0.
  apply Qplus_le_compat with (z:=-b) (t:=-b) in H0; auto with qarith.
  rewrite <- !Qplus_neg in H0.
  apply Qlt_le_trans with (y:=a - b); trivial.
Qed.

Lemma Qlt_l_plus_le_weak_l: forall a a' b c, a + b < c -> a' <= a -> a' + b < c.
Proof.
  intros * H H0.
  apply Qplus_le_compat with (z:=b) (t:=b) in H0; auto with qarith.
  apply Qle_lt_trans with (z:=c) in H0; trivial.
Qed.

Lemma Qlt_l_plus_le_weak_r: forall a b b' c, a + b < c -> b' <= b -> a + b' < c.
Proof.
  intros * H H0.
  rewrite Qplus_comm.
  apply Qlt_l_plus_le_weak_l with (a:=b); trivial.
  rewrite Qplus_comm; trivial.
Qed.

Lemma Qlt_r_plus_le_weak_l: forall a a' b c, c < a + b -> a <= a' -> c < a' + b.
Proof.
  intros * H H0.
  apply Qplus_le_compat with (z:=b) (t:=b) in H0; auto with qarith.
  apply Qlt_le_trans with (z:=a'+b) in H; trivial.
Qed.

Lemma Qlt_r_plus_le_weak_r: forall a b b' c, c < a + b -> b <= b' -> c < a + b'.
Proof.
  intros * H H0.
  rewrite Qplus_comm.
  apply Qlt_r_plus_le_weak_l with (a:=b); [rewrite Qplus_comm|]; trivial.
Qed.

Lemma Qplus_neg_half_l: forall a, -a + a/(2#1) == -(a/(2#1)).
Proof.
  intros.
  rewrite Qplus_l_equ_sub_r.
  rewrite Qplus_neg.
  apply Qeq_sym.
  rewrite <- Qdiv_neg_l.
  rewrite Qplus_half.
  reflexivity.
Qed.

Lemma Qmult_l_equ_div_r: forall a b c, ~ b == 0 -> a * b == c <-> a == c/b.
Proof.
  intros * Hb.
  split; intros H.
  - rewrite <- Qmult_inj_r with (x:=a) (y:=c/b) (z:=b); trivial.
    rewrite Qmult_comm with (x:=c/b).
    rewrite Qmult_div_r; trivial.
  - rewrite <- Qmult_inj_r with (x:=a) (y:=c/b) (z:=b) in H; trivial.
    rewrite Qmult_comm with (x:=c/b) in H.
    rewrite Qmult_div_r in H; trivial.
Qed.

Lemma Qdiv_inj: forall a b c, ~ c == 0 -> a == b <-> a/c == b/c.
Proof.
  intros * Hc.
  split; intros Heq.
  - rewrite <- Qmult_inj_l with (z:=c); [rewrite Qmult_div_r; [rewrite Qmult_div_r|]|]; trivial.
  - rewrite <- Qmult_inj_l with (z:=c) in Heq; [rewrite Qmult_div_r in Heq; [rewrite Qmult_div_r in Heq|]|]; trivial.
Qed.

Lemma Qmult_dist_div: forall a b c, c * (a / b) == ((c*a)/b).
Proof.
  intros.
  apply Qeq_sym.
  rewrite Qdiv_mult_inv.
  rewrite <- Qmult_assoc.
  rewrite <- Qdiv_mult_inv.
  reflexivity.
Qed.

Lemma Qsquare: forall a, a ^ 2 == a * a.
Proof.
  intros.
  auto with qarith.
Qed.

Lemma Qdiv_squared: forall a b, (a / b) ^ 2 == (a*a)/(b*b).
Proof.
  intros.
  rewrite Qsquare.
  rewrite Qdiv_mult_inv.
  rewrite Qmult_assoc.
  rewrite <- Qmult_assoc with (n:=a) (m:=/b) (p:=a).
  rewrite Qmult_comm with (x:=/b) (y:=a).
  rewrite Qmult_assoc with (n:=a) (m:=a) (p:=/b).
  rewrite <- Qmult_assoc.
  rewrite <- Qinv_mult_distr.
  reflexivity.
Qed.

Lemma Qdiv_dist_mult: forall a b, a / b  == /(/a*b).
Proof.
  intros.
  rewrite Qinv_mult_distr.
  rewrite Qinv_involutive.
  rewrite Qdiv_mult_inv.
  reflexivity.
Qed.

Lemma Qdiv_div: forall a b c, a / b / c == a/(b*c).
Proof.
  intros.
  rewrite Qdiv_mult_inv.
  rewrite Qdiv_mult_inv.
  rewrite <- Qmult_assoc.
  rewrite <- Qinv_mult_distr.
  rewrite <- Qdiv_mult_inv.
  reflexivity.
Qed.

Lemma Qpoly2_sub_dist: forall a b, (a - b)*(a - b) == a*a - (2#1)*a*b + b*b.
Proof. intros. ring. Qed.

Lemma Qmult_sum2_dist_l: forall a b c, c*(a + b) == a*c + b*c.
Proof. intros. ring. Qed.

Lemma Qmult_sum2_dist_r: forall a b c, (a + b)*c == a*c + b*c.
Proof. intros. ring. Qed.

Lemma Qmult_sub2_dist_l: forall a b c, c*(a - b) == a*c - b*c.
Proof. intros. ring. Qed.

Lemma Qmult_sub2_dist_r: forall a b c, (a - b)*c == a*c - b*c.
Proof. intros. ring. Qed.

Lemma Qdiv_sum2_dist_r: forall a b c, (a + b)/c == a/c + b/c.
Proof.
  intros.
  rewrite Qdiv_mult_inv.
  rewrite Qmult_sum2_dist_r.
  rewrite <- Qdiv_mult_inv.
  rewrite <- Qdiv_mult_inv.
  reflexivity.
Qed.

Lemma Qdiv_diff2_dist_r: forall a b c, (a - b)/c == a/c - b/c.
Proof.
  intros.
  rewrite Qplus_neg.
  rewrite Qplus_neg.
  rewrite Qdiv_sum2_dist_r.
  rewrite Qdiv_neg_l.
  reflexivity.
Qed.

Lemma Qmult_sum3_dist_r: forall a b c d, (a + b + c)*d == a*d + b*d + c*d.
Proof. intros. ring. Qed.

Lemma Qmult_sub_sum3_dist_r: forall a b c d, (a - b + c)*d == a*d - b*d + c*d.
Proof. intros. ring. Qed.

Lemma Qdiv_sub_sum3_dist_r: forall a b c d, (a - b + c)/d == a/d - b/d + c/d.
Proof.
  intros.
  rewrite Qdiv_mult_inv.
  rewrite Qmult_sub_sum3_dist_r.
  rewrite <- Qdiv_mult_inv.
  rewrite <- Qdiv_mult_inv.
  rewrite <- Qdiv_mult_inv.
  reflexivity.
Qed.

Lemma Qdiv_mult3_cancel_1: forall a b c, ~ a == 0 -> (a*b*c)/a == b*c.
Proof.
  intros.
  rewrite Qdiv_mult_inv.
  rewrite <- Qmult_assoc.
  rewrite <- Qmult_comm.
  rewrite Qmult_assoc.
  rewrite <- Qmult_comm.
  rewrite <- Qmult_assoc with (n:=c).
  rewrite  Qmult_comm with (x:=/a) (y:= a).
  rewrite Qmult_inv_r; trivial.
  rewrite Qmult_1_r.
  reflexivity.
Qed.

Lemma Qdiv_mult4_cancel_1: forall a b c d, ~ a == 0 -> (a*b*c*d)/a == b*c*d.
Proof.
  intros.
  rewrite <- Qmult_assoc.
  rewrite Qdiv_mult3_cancel_1; trivial.
  rewrite Qmult_assoc.
  reflexivity.
Qed.

Ltac plus_minus :=
  repeat match goal with
  | |- context[?x + ?y] =>
      match y with
      | context[-x] =>
          match y with
          | -x => rewrite (Qplus_assoc x (-x))
          | -x + _ => rewrite (Qplus_assoc x (-x))
          | ?a + ?z => rewrite (Qplus_assoc x a), (Qplus_comm x a), <- (Qplus_assoc a x)
          end
      end
  end.
Ltac minus_plus :=
  repeat match goal with
  | |- context[-?x + ?y] =>
      match y with
      | context[x] =>
          match y with
          | x => rewrite (Qplus_assoc (-x) x)
          | x + _ => rewrite (Qplus_assoc (-x) x)
          | ?a + ?z => rewrite (Qplus_assoc (-x) a), (Qplus_comm (-x) a), <- (Qplus_assoc a (-x))
          end
      end
  end.
Ltac plus_opp_simpl :=
  first [progress plus_minus | progress minus_plus]; rewrite ?Qplus_opp_l, ?Qplus_opp_r, ?Qplus_0_r, ?Qplus_0_l.

(*Hint Resolve*)

Hint Rewrite
  Qplus_neg
  Qdiv_mult_inv
  Qmult_neg_1
  Qmult_inv_l
  Qplus_double
  Qplus_half
  Qdiv_neg_l
  Qplus_l_equ_sub_r
  Qplus_l_equ_sub_l
  Qplus_r_equ_sub_r
  Qplus_r_equ_sub_l
  Qplus_neg_half_l
  Qmult_l_equ_div_r
  Qdiv_inj
  Qmult_dist_div
  Qsquare
  Qdiv_squared
  Qdiv_dist_mult
  Qdiv_div
  Qpoly2_sub_dist
  Qmult_sum2_dist_l
  Qmult_sum2_dist_r
  Qmult_sub2_dist_l
  Qmult_sub2_dist_r
  Qdiv_sum2_dist_r
  Qdiv_diff2_dist_r
  Qmult_sum3_dist_r
  Qmult_sub_sum3_dist_r
  Qdiv_sub_sum3_dist_r
  Qdiv_mult4_cancel_1
  Qdiv_mult3_cancel_1 : q_math_hints.

Ltac q_math := ring || autorewrite with q_math_hints; auto with qarith.


Add Rec LoadPath "../src/" as evm_compute.
Add ML Path "../src/".

Require Evm_compute.
Require Import ZArith.

(* factorisation as an example of non-trivial computation *)

Section fold.
  Variable A : Type.
  Variable f : Z -> A -> A.
  Fixpoint fold n acc:= match n with
                          | 0 => acc
                          | S k => fold k (f (Z.of_nat k) acc)
                        end.
End fold.

Open Scope Z_scope.

Definition divide x y :=
  Z.modulo x y =? 0 .

Definition try n z acc :=
  match acc with
    | None =>
      if z <? 2 then
        None
      else if divide n z then
             Some (z,Z.div n z)
           else None
    | Some x => acc
  end.

Definition factor n :=
  match fold _ (try (Z.of_nat n)) n None with
    | Some x => x
    | None => (Z.of_nat n,1)
  end.

Eval compute in factor 9.

Remark factorisable :  forall x:nat, (let (a,b) := factor x in (a * b)%Z) = Z.of_nat x.
Admitted.

Definition k : nat := 1111%nat. Definition ka := 101. Definition kb := 11.

Require Import String.

Check ("evm_compute without witnesses")%string.
Goal exists e1 e2, Z.of_nat k = e1 * e2.
intros. eexists. eexists.
rewrite <- factorisable.
Time evm blacklist [Zmult;].   reflexivity.
Time Qed.

Check ("evm_compute in H")%string.
Goal exists e1 e2, (Z.of_nat k = e1 * e2 -> e1 * e2 = ka * kb).
intros. eexists. eexists. intros H.
rewrite <- factorisable in H.
Time evm in H blacklist [Zmult;].
apply H.
Time Qed.

Check ("vm_compute with witnesses")%string.
Goal exists e1 e2, Z.of_nat k = e1 * e2.
intros.  exists ka. exists kb.
Time vm_compute; reflexivity.
Time Qed.

Check ("cbv with witnesses")%string.
Goal exists e1 e2, Z.of_nat k = e1 * e2.
intros.  exists ka.  exists kb.
Time cbv; reflexivity.
Time Qed.

(* it works even if there are lets in the hyps *)
Goal exists e1 e2, Z.of_nat k = e1 * e2.
intros. eexists.   eexists.
 match goal with |- _ = ?x * ?y =>
                 let Hx := fresh in
                 let Hy := fresh in
                 set (Hx:=x);
                 set (Hy:=y) end.
(* Fail vm_compute. *)
rewrite <- factorisable.
evm blacklist [Zmult].
unfold H, H0. reflexivity.
Qed.

(* An example of a proof that blows up at Qed time, because the proof term does not provide enough information *)
(*
Check ("cbv without witnesses")%string.
Goal exists e1 e2, Z.of_nat k = e1 * e2.
intros. eexists. eexists.
rewrite <- factorisable.
set (f :=Z.mul).
Time cbv - [f]; unfold f;  reflexivity. (* 4 s *)
Time Qed.                               (* 154 s !! *)
*)

Fixpoint nexists n P :=
  match n with
    | 0 => P
    | S n => exists x, nexists n (P /\ x = 1)
  end%nat.

Check ("cbv with witnesses")%string.
Goal exists e1 e2, nexists 10  (Z.of_nat k = e1 * e2).
unfold nexists; do 12 eexists.
rewrite <- (factorisable).
evm blacklist [Zmult].
repeat split.
Time Qed.


(*********************)
(** * Bool data type *)
(*********************)
Inductive bool := true | false.

(*********************)
(** * Bool function  *)
(*********************)
Definition inverse(b : bool) : bool := match b with
    | true  => false
    | false => true
    end.

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

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

(*********************)
(** * Bool notation  *)
(*********************)
Notation "¬ a" := (inverse a) (at level 50) : type_scope.
Notation "a ∧ b" := (and a b) (at level 50) : type_scope.
Notation "a ∨ b" := (or a b) (at level 50) : type_scope.

(*********************)
(** * Bool Theorem   *)
(*********************)
Theorem basic_bool_theorem: forall a b : bool,
    (a ∧ b) ∨ (¬(a ∧ b)) = true.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Test for matrix.
  author    : ZhengPu Shi
  date      : 2021.12
*)

From FCS Require Export MatrixAll.

(** 以 【 实数 + MLL实现 】 为例 *)
Module Test_Mat_R_MLL.
  Import MatrixAllR.MLL.
  Open Scope R.

  Check T.
  Check 3 : T.

  Parameter m1 : mat 3 4.
  Parameter m2 : mat 3 4.
  Check m1 == m2.

  (* 构造具体的矩阵 *)
  Definition ex_m_1_1 : mat 1 1 := mat_1_1 2.
  Definition ex_m_3_3 : mat 3 3 := mat_3_3 1 2 3 4 5 6 7 8 9.
  Compute ex_m_1_1.
  Compute ex_m_3_3.

  (* 零矩阵和单位矩阵 *)
  Compute mat0 3 4.
  Compute mat1 3.

  (* 矩阵映射 *)
  Compute mmap (fun x => x * 2) (ex_m_3_3).
  Compute mmap2 (Rminus) ex_m_3_3 ex_m_3_3.

  (* 矩阵加法 *)
  Check madd m1 m2.
  Compute madd ex_m_3_3 ex_m_3_3.
  Example ex_madd : forall r c (m1 m2 : mat r c), madd m1 m2 == madd m2 m1.
  intros. apply madd_comm. Qed.

  (* 矩阵减法 *)
  Compute msub ex_m_3_3 (mat1 3).

  (* 矩阵数乘 *)
  Compute mcmul 3 ex_m_3_3.
  Compute mmulc ex_m_3_3 3.

  (* 矩阵转置 *)
  Compute mtrans ex_m_3_3.

  (* 矩阵乘法 *)
  Compute mmul ex_m_3_3 (mtrans ex_m_3_3).
  Compute mmul ex_m_3_3 ex_m_3_3.

  (* 坐标转换的一个例子 *)

(*   Import List.
  Import ListNotations. *)

  Section coordinate_transform_test.
    Variable θ ψ φ : R.
    Definition Rx (α : R) : mat 3 3 := mat_3_3
      1         0           0
      0         (cos α)     (sin α)
      0         (-sin α)    (cos α).

    Definition Ry (β : R) : mat 3 3 := mat_3_3
      (cos β)   0           (-sin β)
      0         1           0
      (sin β)   0           (cos β).

    Definition Rz (γ : R) : mat 3 3 := mat_3_3
      (cos γ)   (sin γ)   0
      (-sin γ)  (cos γ)   0
      0         0         1.

    Definition R_b_e_direct : mat 3 3 := mat_3_3
      (cos θ * cos ψ)
      (cos ψ * sin θ * sin φ - sin ψ * cos φ)
      (cos ψ * sin θ * cos φ + sin φ * sin ψ)

      (cos θ * sin ψ)
      (sin ψ * sin θ * sin φ + cos ψ * cos φ)
      (sin ψ * sin θ * cos φ - cos ψ * sin φ)

      (-sin θ)
      (sin φ * cos θ)
      (cos φ * cos θ).

    Open Scope M.
    Opaque cos sin.
    Lemma Rx_Ry_Rz_eq_Rbe : (Rz ψ)⊤ × (Ry θ)⊤ × (Rx φ)⊤ == R_b_e_direct.
    Proof. lma. Qed.

  End coordinate_transform_test.

End Test_Mat_R_MLL.


(* Software Foundations *)
(* Exercice 3 stars, gen_dep_practice *)
Fixpoint index{X: Type}(n: nat)(l: list X):=
    match l with
    |nil      => None
    |cons h t => if Nat.eqb n 0 then Some h else index (pred n) t
    end.

Theorem index_after_last: forall (n : nat) (X : Type) (l : list X ),
    length l =n  ->index n l = None.
Proof.
    intros.
    generalize dependent n.
    induction l as [|l'].
    intros. simpl. reflexivity.
    intros. simpl. destruct n as [|n'].
    simpl. inversion H.
    simpl. apply IHl. simpl in H. inversion H. reflexivity.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.
Require Import utils_tac utils_list sums php.

Set Implicit Arguments.

Local Notation "∑" := (msum plus 0).

Section nat_swap.

  Variables (i j : nat).

  Definition swap n := if eq_nat_dec n i then j else
                       if eq_nat_dec n j then i else n.

  Fact swap_spec_i : swap i = j.
  Proof. unfold swap; destruct (eq_nat_dec i i); auto; omega. Qed.

  Fact swap_spec_j : swap j = i.
  Proof.
    unfold swap.
    destruct (eq_nat_dec j i); auto.
    destruct (eq_nat_dec j j); auto; omega.
  Qed.

  Fact swap_spec n : n <> i -> n <> j -> swap n = n.
  Proof.
    unfold swap; intros.
    destruct (eq_nat_dec n i); try omega.
    destruct (eq_nat_dec n j); omega.
  Qed.

  Fact swap_involutive n : swap (swap n) = n.
  Proof.
    destruct (eq_nat_dec n i).
    { subst n; rewrite swap_spec_i, swap_spec_j; auto. }
    destruct (eq_nat_dec n j).
    { subst n; rewrite swap_spec_j, swap_spec_i; auto. }
    { do 2 (rewrite swap_spec; auto). }
  Qed.

  Fact swap_inj n m : swap n = swap m -> n = m.
  Proof.
    intros; rewrite <- (swap_involutive n), H.
    apply swap_involutive.
  Qed.

End nat_swap.

Opaque swap.

Section php_fun.

  Variable (n : nat) (f : nat -> nat) (Hf : forall i, i <= n -> f i < n).

  Theorem php_fun : exists i j, i < j <= n /\ f i = f j.
  Proof.
    destruct PHP_rel with (S := fun x y => y = f x) (l := list_an 0 (S n)) (m := list_an 0 n)
      as (a & i & b & j & c & v & H1 & H2 & H3 & H4).
    + intros x; rewrite list_an_spec; simpl; intros [ _ H ].
      exists (f x); split; auto; rewrite list_an_spec; simpl; split; try omega.
      apply Hf; omega.
    + do 2 rewrite list_an_length; auto.
    + exists i, j; split; try omega.
      generalize H1; intros G1.
      apply list_an_app_inv in G1.
      destruct G1 as (G0 & G1); simpl in G1.
      injection G1; clear G1; intros G1 G2.
      symmetry in G1; apply list_an_app_inv in G1.
      destruct G1 as (G3 & G1); simpl in G1.
      injection G1; clear G1; intros G4 G1.
      apply f_equal with (f := @length _) in H1.
      revert H1; rew length; intros H1.
      omega.
  Qed.

End php_fun.

Section split_interval.

  (* [0,i[ U {i} U ]i,n] ~~ [0,n[ U {n} *)

  Variables (n i : nat) (Hi : i <= n).

  Let g j := if le_lt_dec (S n) j then j else     (* j > n  *)
             if le_lt_dec i j then
             if le_lt_dec j i then n              (* j = i *)
             else j-1                             (* i < j <= n *)
             else j.                              (* j < i *)

  Let h j := if le_lt_dec (S n) j then j else     (* j > n  *)
             if le_lt_dec n j then i else         (* j = n  *)
             if le_lt_dec i j then j+1            (* i <= j < n *)
             else j.                              (* j < i *)

  Let Hg1 : forall j, j <= n -> g j <= n.
  Proof.
    intros j Hj; unfold g.
    destruct (le_lt_dec (S n) j); try omega.
    destruct (le_lt_dec i j); try omega.
    destruct (le_lt_dec j i); omega.
  Qed.

  Let Hg2 j : n < j -> g j = j.
  Proof.
    unfold g; destruct (le_lt_dec (S n) j); intros; omega.
  Qed.

  Let Hh1 : forall j, j <= n -> h j <= n.
  Proof.
    intros j Hj; unfold h.
    destruct (le_lt_dec (S n) j); try omega.
    destruct (le_lt_dec n j); try omega.
    destruct (le_lt_dec i j); omega.
  Qed.

  Let Hh2 j : n < j -> h j = j.
  Proof.
    unfold h; destruct (le_lt_dec (S n) j); intros; omega.
  Qed.

  Ltac mydestruct H :=
    match goal with
      |- if ?c then _ else _ = _ => destruct c as [ H | H ]; try omega; auto
    end.

  Theorem split_interval : { g : nat -> nat & { h | (forall j, j <= n -> g j <= n)
                                                 /\ (forall j, j <= n -> h j <= n)
                                                 /\ (forall j, g (h j) = j)
                                                 /\ (forall j, h (g j) = j)
                                                 /\ g i = n } }.
  Proof.
    exists g, h.
    split; [ | split; [ | split; [ | split ] ] ]; auto.
    + intros j; unfold h.
      destruct (le_lt_dec (S n) j) as [ | H1 ]; auto.
      destruct (le_lt_dec n j) as [ H2 | H2 ].
      { unfold g.
        destruct (le_lt_dec (S n) i); try omega.
        destruct (le_lt_dec i i); omega. }
      destruct (le_lt_dec i j) as [ H3 | H3 ].
      { unfold g.
        destruct (le_lt_dec (S n) (j+1)); try omega.
        destruct (le_lt_dec i (j+1)); try omega.
        destruct (le_lt_dec (j+1) i); omega. }
      { unfold g.
        destruct (le_lt_dec (S n) j); try omega.
        destruct (le_lt_dec i j); try omega. }
    + intros j; unfold g.
      destruct (le_lt_dec (S n) j) as [ | H1 ]; auto.
      destruct (le_lt_dec i j) as [ H2 | H2 ].
      destruct (le_lt_dec j i) as [ H3 | H3 ].
      { unfold h.
        destruct (le_lt_dec (S n) n); try omega.
        destruct (le_lt_dec n n); omega. }
      { unfold h.
        destruct (le_lt_dec (S n) (j-1)); try omega.
        destruct (le_lt_dec n (j-1)); try omega.
        destruct (le_lt_dec i (j-1)); omega. }
      { unfold h.
        destruct (le_lt_dec (S n) j); try omega.
        destruct (le_lt_dec n j); try omega.
        destruct (le_lt_dec i j); omega. }
    + unfold g.
      destruct (le_lt_dec (S n) i); try omega.
      destruct (le_lt_dec i i); omega.
  Qed.

End split_interval.

Definition find_max_fun n f : { i | i <= n /\ forall j, j <= n -> f j <= f i }.
Proof.
  revert f; induction n as [ | n IHn ]; intros f.
  + exists 0; split; auto.
    intros [ | ]; auto; omega.
  + destruct (IHn f) as (i & H1 & H2).
    destruct (le_lt_dec (f i) (f (S n))) as [ H | H ].
    * exists (S n); split; auto.
      intros j Hj.
      destruct (le_lt_dec j n) as [ H0 | H0 ].
      - apply le_trans with (2 := H); auto.
      - cutrewrite (j = S n); auto; omega.
    * exists i; split; auto.
      intros j Hj.
      destruct (le_lt_dec j n) as [ H0 | H0 ]; auto.
      cutrewrite (j = S n); auto; omega.
Qed.

Section sum_bounded_permutation.

  Let sigma_sum_split i n f : i < n -> ∑ (S n) f = f i + f n + ∑ i f + ∑ (n-S i) (fun j => f (S i+j)).
  Proof.
    intros Hi.
    replace (S n) with (i+1+(n- S i)+1) by omega.
    repeat (rewrite msum_plus; auto).
    do 2 rewrite msum_S, msum_0.
    repeat rewrite <- plus_assoc.
    rewrite (plus_comm).
    repeat rewrite <- plus_assoc.
    f_equal.
    { f_equal; omega. }
    simpl.
    rewrite (plus_comm).
    repeat rewrite <- plus_assoc.
    f_equal.
    { f_equal; omega. }
    f_equal.
    apply msum_ext.
    intros; f_equal; omega.
  Qed.

  Let sum_permutation_1 n i j g f :
            i < j < n
         -> g i = j
         -> g j = i
         -> (forall k, k <> i -> k <> j -> k < n -> g k = k)
         -> ∑ n f = ∑ n (fun i => f (g i)).
  Proof.
    revert i j g; induction n as [ | n IHn ]; intros i j g (H1 & H2) H3 H4 H5.
    + do 2 rewrite msum_0; auto.
    + destruct (eq_nat_dec j n) as [ H7 | H7 ].
      * rewrite H7 in *; clear j H7 H2.
        do 2 rewrite sigma_sum_split with (1 := H1).
        rewrite H3, H4; f_equal; [ f_equal | ]; try omega;
          apply msum_ext; intros; symmetry; f_equal; apply H5; omega.
      * do 2 (rewrite msum_plus1; auto); f_equal.
        - apply IHn with i j; auto; split; auto; omega.
        - symmetry; f_equal; apply H5; omega.
  Qed.

  Inductive bounded_permut n (i j : nat) g : Prop :=
    | in_nat_perm :
          i < n -> j < n -> g i = j -> g j = i
       -> (forall k, k <> i -> k <> j -> k < n -> g k = k)
       -> bounded_permut n i j g.

  Hint Resolve swap_spec_i swap_spec_j swap_spec.

  Fact swap_bounded_permut n i j : i < n -> j < n -> bounded_permut n i j (swap i j).
  Proof. constructor; auto. Qed.

  Inductive composed_permutation n g : Prop :=
    | in_cp_0 : (forall i, i < n -> g i = i) -> composed_permutation n g
    | in_cp_1 : forall i j f h,
                                bounded_permut n i j f
                             -> composed_permutation n h
                             -> (forall i, i < n -> g i = h (f i))
                             -> composed_permutation n g.

  Fact composed_permutation_ext n f g :
       (forall i, i < n -> f i = g i) -> composed_permutation n f -> composed_permutation n g.
  Proof.
    intros H1 H2; revert H2 g H1.
    induction 1 as [ f Hg | f i j p q H1 H2 IH2 H3 ]; intros g H4.
    + constructor 1; intros; rewrite <- H4; auto.
    + constructor 2 with i j p q; auto.
      intros; rewrite <- H4; auto.
  Qed.

  Let flat n f i := if le_lt_dec n i then n else f i.

  Let flat_left n f i : i < n -> flat n f i = f i.
  Proof. unfold flat; intro; destruct (le_lt_dec n i); auto; omega. Qed.

  Let flat_right n f i : n <= i -> flat n f i = n.
  Proof. unfold flat; intro; destruct (le_lt_dec n i); auto; omega. Qed.

  Fact composed_permutation_extends n f g :
         (forall i, i < n -> f i = g i) -> g n = n -> composed_permutation n f -> composed_permutation (S n) g.
  Proof.
    intros H1 H2 H3; revert H3 g H1 H2.
    induction 1 as [ f Hg | f i j p q H1 H2 IH2 H3 ]; intros g H4 H5.
    + constructor 1; intros j Hj.
      destruct (eq_nat_dec j n); subst; auto.
      rewrite <- H4, Hg; auto; omega.
    + constructor 2 with i j (flat n p) (flat n q).
      * destruct H1 as [ G1 G2 G3 G4 G5 ]; constructor; try omega.
        - rewrite flat_left; auto; omega.
        - rewrite flat_left; auto; omega.
        - intros k ? ? ?.
          destruct (eq_nat_dec k n); subst.
          ++ rewrite flat_right; auto.
          ++ rewrite flat_left, G5; omega.
      * apply IH2.
        - intros l Hl; rewrite flat_left; auto.
        - rewrite flat_right; omega.
      * intros k Hk.
        destruct (eq_nat_dec k n); subst.
        - rewrite (flat_right p), flat_right; omega.
        - rewrite (flat_left p); try omega.
          rewrite flat_left, <- H4; try omega.
          ++ apply H3; omega.
          ++ destruct H1 as [ G1 G2 G3 G4 G5 ].
             destruct (eq_nat_dec k i).
             { subst; auto. }
             destruct (eq_nat_dec k j).
             { subst k; omega. }
             rewrite G5; omega.
  Qed.

  Fact composed_permutation_S n g : g n = n -> composed_permutation n g -> composed_permutation (S n) g.
  Proof. intro; apply  composed_permutation_extends; auto. Qed.

  Inductive bounded_injective n f : Prop :=
    | in_bounded_inj : (forall i, i < n -> f i < n)
                    -> (forall i j, i < n -> j < n -> f i = f j -> i = j)
                    -> bounded_injective n f.

  Fact injective_composed_permutation n f : bounded_injective n f
                                         -> composed_permutation n f.
  Proof.
    intros [ H1 H2 ].
    revert f H1 H2; induction n as [ | n IHn ]; intros f H1 H2.
    + constructor 1; intros; omega.
    + destruct (find_max_fun n f) as (i & H3 & H4).
      destruct (le_lt_dec n (f i)) as [ C | C ].
      - assert (f i = n) as Hf1.
        { apply le_antisym; auto; apply le_S_n, H1; omega. }
        assert (forall j, j <= n -> j <> i -> f j < n) as Hf2.
        { intros j G1 G2.
          destruct (eq_nat_dec (f j) n).
          + contradict G2; apply H2; omega.
          + specialize (H1 j); omega. }
        specialize (IHn (fun x => f (swap i n x))).
        spec in IHn.
        { intros j Hj.
          destruct (eq_nat_dec j i).
          + subst j; rewrite swap_spec_i; apply Hf2; omega.
          + rewrite swap_spec; try omega; apply Hf2; omega. }
        spec in IHn.
        { intros u v G1 G2 G3.
          apply H2 in G3.
          + revert G3; apply swap_inj.
          + destruct (eq_nat_dec u i).
            - subst; rewrite swap_spec_i; omega.
            - rewrite swap_spec; omega.
          + destruct (eq_nat_dec v i).
            - subst; rewrite swap_spec_i; omega.
            - rewrite swap_spec; omega. }
        apply composed_permutation_S in IHn.
        2: rewrite swap_spec_j, Hf1; auto.
        generalize (@swap_bounded_permut (S n) i n); intros G.
        do 2 (spec in G; try omega).
        constructor 2 with (1 := G) (2 := IHn).
        intros; rewrite swap_involutive; auto.
      - destruct (@php_fun n f) as (u & v & G1 & G2).
        { intros; apply le_lt_trans with (2 := C); auto. }
        apply H2 in G2; omega.
  Qed.

  Theorem sum_bounded_permutation n i j g f : bounded_permut n i j g -> ∑ n f = ∑ n (fun i => f (g i)).
  Proof.
    intros [ H1 H2 H3 H4 H5 ].
    destruct (lt_eq_lt_dec i j) as [ [ G1 | G1 ] | G1 ].
    + apply sum_permutation_1 with i j; auto; split; auto.
    + apply msum_ext; rewrite <- G1 in *; clear j G1.
      intros j Hj; f_equal.
      destruct (eq_nat_dec j i); subst; auto.
      rewrite H5; auto.
    + apply sum_permutation_1 with j i; auto; split; auto.
  Qed.

  Theorem sum_composed_permutation n f g : composed_permutation n g -> ∑ n f = ∑ n (fun i => f (g i)).
  Proof.
    induction 1 as [ g Hg | g i j p q H1 H2 IH2 H3 ].
    + symmetry; apply msum_ext; intros; f_equal; apply Hg; auto.
    + rewrite IH2, sum_bounded_permutation with (1 := H1).
      symmetry; apply msum_ext; intros; f_equal; auto.
  Qed.

  Theorem sum_injective n f g : bounded_injective n g -> ∑ n f = ∑ n (fun i => f (g i)).
  Proof.
    intros; apply sum_composed_permutation, injective_composed_permutation; trivial.
  Qed.

End sum_bounded_permutation.

Section sum_bijection.

  Inductive bijection n g h : Type :=
    | in_bij : (forall i, i < n -> g i < n)
            -> (forall i, i < n -> h i < n)
            -> (forall i, i < n -> g (h i) = i)
            -> (forall i, i < n -> h (g i) = i)
           -> bijection n g h.

  Theorem sum_bijection n f g h : bijection n g h -> ∑ n f = ∑ n (fun i => f (g i)).
  Proof.
    intros [ H1 H2 H3 H4 ].
    apply sum_injective.
    constructor; auto.
    intros i j G1 G2 G3; rewrite <- (H4 i), G3; auto.
  Qed.

  Inductive triangle_bijection n k g h : Prop :=
    | in_tb : (forall i j, j < i < n -> h (i,j) < k /\ g (h (i,j)) = (i,j))
           -> (forall q, q < k -> snd (g q) < fst (g q) < n /\ h (g q) = q)
           -> triangle_bijection n k g h.

  Fact sum_triangle_bijection n f k g h :
         triangle_bijection n k g h
      -> ∑ n (fun i => ∑ i (fun j => f i j)) = ∑ k (fun i => f (fst (g i)) (snd (g i))).
  Proof.
  Admitted.

  (* ∑ n (fun i => ∑ i (fun j => f i j * power (e i j) r) = ∑ k *)

End sum_bijection.


(* Exercise coq_list_06 *)

(* Those are the definitions from the previous exercise: *)

Inductive natlist : Set :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Fixpoint append (l m : natlist) {struct l} : natlist :=
  match l with
  | nil => m
  | cons x xs => cons x (append xs m)
  end.

Fixpoint length (l : natlist) : nat :=
  match l with
  | nil => 0
  | cons ele rem => 1 + (length rem)
  end.

Fixpoint reverse (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons ele rem => append (reverse rem) (cons ele nil)
  end.

(* Now let us prove that reverse does not change the length
   of a list *)

(* For this we may need a result proven in one of the previous
   exercises and some results about natural numbers (remember
   the exercises concerning natural numbers?) *)
Axiom append_length : forall l m,
  length (append l m) = length l + length m.
Require Import Arith.

Lemma reverse_length : forall l,
  length l = length (reverse l).

Proof.
  intros.
  induction l.
  simpl; reflexivity.
  simpl.
  rewrite append_length.
  simpl.
  rewrite Nat.add_1_r.
  rewrite IHl.
  reflexivity.
Qed.


Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split.
  - split.
    -- apply HP.
    -- apply HQ.
  - apply HR.
Qed.


Require Import Coq.ZArith.ZArith.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

Hint Rewrite <- nat_compare_lt : hints.
Hint Rewrite <- nat_compare_gt : hints.
Hint Rewrite Nat.compare_eq_iff : hints.
Hint Rewrite <- Nat.compare_eq_iff : hints.

Ltac autorewrite_nat_compare :=
  autorewrite with hints.

Lemma nat_compare_eq_refl : forall x, Nat.compare x x = Eq.
  intros; apply Nat.compare_eq_iff; trivial.
Qed.

Lemma nat_compare_consistent :
  forall n0 n1,
    { Nat.compare n0 n1 = Lt /\ Nat.compare n1 n0 = Gt }
    + { Nat.compare n0 n1 = Eq /\ Nat.compare n1 n0 = Eq }
    + { Nat.compare n0 n1 = Gt /\ Nat.compare n1 n0 = Lt }.
Proof.
  intros n0 n1;
  destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ];
  [ constructor 1; constructor 1  | constructor 1; constructor 2 | constructor 2 ];
  split;
  autorewrite_nat_compare;
  intuition.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (z : natural) (x : natural) : natural :=
  mult z (plus (Succ x) y).


(* week-13_fib.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of Fri 10 Nov 2017 *)

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

(* Paraphernalia: *)

Ltac unfold_tactic name := intros; unfold name; (* fold name; *) reflexivity.

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

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

(* Specialized induction principle: *)

Lemma nat_ind2 :
  forall P : nat -> Prop,
    P 0 ->
    P 1 ->
    (forall i : nat,
      P i -> P (S i) -> P (S (S i))) ->
    forall n : nat,
      P n.
Proof.
  intros P H_bc0 H_bc1 H_ic n.
  assert (H_Pn_PSn : P n /\ P (S n)).
    induction n as [ | n' [IH_n' IH_Sn']].

    split.

      apply H_bc0.

    apply H_bc1.

    split.

      apply IH_Sn'.

    apply (H_ic n' IH_n' IH_Sn').

  destruct H_Pn_PSn as [H_Pn _].
  apply H_Pn.
Qed.

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

Definition specification_of_fibonacci (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall n'' : nat,
    fib (S (S n'')) = fib (S n'') + fib n''.

Theorem there_is_only_one_fibonacci :
  forall fib1 fib2 : nat -> nat,
    specification_of_fibonacci fib1 ->
    specification_of_fibonacci fib2 ->
    forall n : nat,
      fib1 n = fib2 n.
Proof.
  intros fib1 fib2.
  unfold specification_of_fibonacci.
  intros [H_fib1_bc0 [H_fib1_bc1 H_fib1_ic]]
         [H_fib2_bc0 [H_fib2_bc1 H_fib2_ic]]
         n.
  induction n as [ | | n'' IHn'' IHSn''] using nat_ind2.

  rewrite -> H_fib2_bc0.
  apply H_fib1_bc0.

  rewrite -> H_fib2_bc1.
  apply H_fib1_bc1.

  rewrite -> H_fib1_ic.
  rewrite -> IHSn''.
  rewrite -> IHn''.
  rewrite <- H_fib2_ic.
  reflexivity.
Qed.

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

(* Standard unit-test function: *)

Definition test_fib (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8)
  &&
  (candidate 7 =n= 13)
  &&
  (candidate 8 =n= 21)
  .

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

(* The fibonacci function in direct style: *)

Fixpoint fib_ds (n : nat) : nat :=
  match n with
    | 0 => 0
    | S n' => match n' with
                | 0 => 1
                | S n'' => fib_ds n' + fib_ds n''
              end
  end.

Compute (test_fib fib_ds).

(* Associated unfold lemmas: *)

Lemma unfold_fib_ds_0 :
  fib_ds 0 = 0.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_ds_1 :
  fib_ds 1 = 1.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_ds_SS :
  forall n'' : nat,
    fib_ds (S (S n'')) = fib_ds (S n'') + fib_ds n''.
Proof.
  unfold_tactic fib_ds.
Qed.

(* Main definition: *)

Definition fib_v1 (n : nat) : nat :=
  fib_ds n.

Compute (test_fib fib_v1).

(* Associated unfold lemma: *)

Lemma unfold_fib_v1 :
  forall n : nat,
    fib_v1 n = fib_ds n.
Proof.
  unfold_tactic fib_v1.
Qed.

(* The main definition satisfies the specification: *)

Theorem fib_v1_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v1.
Proof.
  unfold specification_of_fibonacci.
  split.

    rewrite -> unfold_fib_v1.
    apply unfold_fib_ds_0.

  split.

    rewrite -> unfold_fib_v1.
    apply unfold_fib_ds_1.

  intro n''.
  rewrite -> unfold_fib_v1.
  apply unfold_fib_ds_SS.
Qed.

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

(* The fibonacci function in continuation-passing style: *)

Fixpoint fib_cps (ans : Type) (n : nat) (k : nat -> ans) : ans :=
  match n with
    | 0 => k 0
    | S n' =>
      match n' with
        | 0 => k 1
        | S n'' =>
          fib_cps ans n' (fun v1 =>
                            fib_cps ans n'' (fun v2 =>
                                               k (v1 + v2)))
      end
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fib_cps_0 :
  forall (ans : Type) (k : nat -> ans),
    fib_cps ans 0 k = k 0.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_cps_1 :
  forall (ans : Type) (k : nat -> ans),
    fib_cps ans 1 k = k 1.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_cps_SS :
  forall (ans : Type) (n'' : nat) (k : nat -> ans),
    fib_cps ans (S (S n'')) k =
    fib_cps ans (S n'') (fun v1 => fib_cps ans n'' (fun v2 => k (v1 + v2))).
Proof.
  unfold_tactic fib_ds.
Qed.

(* Lemma about resetting the continuation: *)

Lemma about_fib_cps :
  forall (n : nat) (ans: Type) (k : nat -> ans),
    fib_cps ans n k = k (fib_cps nat n (fun a => a)).
Proof.
  intro n.
  induction n as [ | | n' IHn' IHn''] using nat_ind2.
  intros ans k.
  rewrite ->2 unfold_fib_cps_0.
  reflexivity.

  intros ans k.
  rewrite ->2 unfold_fib_cps_1.
  reflexivity.

  intros ans k.
  rewrite ->2 unfold_fib_cps_SS.
  rewrite -> IHn''.
  rewrite -> IHn'.
  rewrite -> (IHn'' nat (fun v1 : nat => fib_cps nat n' (fun v2 : nat => v1 + v2))).
  rewrite -> (IHn' nat (fun v2 : nat => fib_cps nat (S n') (fun a : nat => a) + v2)).
  reflexivity.
Qed.

(* Main definition: *)

Definition fib_v2 (n : nat) : nat :=
  fib_cps nat n (fun v => v).

Compute (test_fib fib_v2).

(* Associated unfold lemma: *)

Lemma unfold_fib_v2 :
  forall n : nat,
    fib_v2 n = fib_cps nat n (fun v => v).
Proof.
  unfold_tactic fib_v2.
Qed.

(* The main definition satisfies the specification: *)

Theorem fib_v2_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v2.
Proof.
Abort.

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

(* The fibonacci function with an accumulator: *)

Fixpoint fib_acc (n a1 a0 : nat) : nat :=
  match n with
    | 0 => a0
    | S n' => fib_acc n' (a1 + a0) a1
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fib_acc_0 :
  forall a1 a0 : nat,
    fib_acc 0 a1 a0 = a0.
Proof.
  unfold_tactic fib_acc.
Qed.

Lemma unfold_fib_acc_S :
  forall n' a1 a0 : nat,
    fib_acc (S n') a1 a0 = fib_acc n' (a1 + a0) a1.
Proof.
  unfold_tactic fib_acc.
Qed.

(* Main definition: *)

Definition fib_v3 (n : nat) : nat :=
  fib_acc n 1 0.

Compute (test_fib fib_v3).

(* Associated unfold lemma: *)

Lemma unfold_fib_v3 :
  forall n : nat,
    fib_v3 n = fib_acc n 1 0.
Proof.
  unfold_tactic fib_v3.
Qed.

(* Eureka lemma: *)

Lemma about_fib_acc :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall j i : nat,
      fib_acc j (fib (S i)) (fib i) = fib (j + i).
Proof.
Abort.

(* The main definition satisfies the specification: *)

Theorem fib_v3_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v3.
Proof.
Abort.

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

(* The fibonacci function with an accumulator in CPS: *)

Fixpoint fib_acc_cps (ans : Type) (n a1 a0 : nat) (k : nat -> ans) : ans :=
  match n with
    | 0 => k a0
    | S n' => fib_acc_cps ans n' (a1 + a0) a1 k
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fib_acc_cps_0 :
  forall (ans: Type)
         (a1 a0 : nat)
         (k : nat -> ans),
    fib_acc_cps ans 0 a1 a0 k = k a0.
Proof.
  unfold_tactic fib_acc_cps.
Qed.

Lemma unfold_fib_acc_cps_S :
  forall (ans: Type)
         (n' a1 a0 : nat)
         (k : nat -> ans),
    fib_acc_cps ans (S n') a1 a0 k =
    fib_acc_cps ans n' (a1 + a0) a1 k.
Proof.
  unfold_tactic fib_acc_cps.
Qed.

(* Main definition: *)

Definition fib_v4 (n : nat) : nat :=
  fib_acc_cps nat n 1 0 (fun a => a).

Compute (test_fib fib_v4).

(* Associated unfold lemma: *)

Lemma unfold_fib_v4 :
  forall (n : nat),
    fib_v4 n = fib_acc_cps nat n 1 0 (fun a => a).
Proof.
  unfold_tactic fib_v4.
Qed.

(* Eureka lemma: *)

Lemma about_fib_acc_cps :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall (ans : Type)
           (j i : nat)
           (k : nat -> ans),
      fib_acc_cps ans j (fib (S i)) (fib i) k =
      k (fib (j + i)).
Proof.
Abort.

(* The main definition satisfies the specification: *)

Theorem fib_v4_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v4.
Proof.
Abort.

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

(* The fibonacci function with a co-accumulator: *)

Fixpoint fib_co_acc (n : nat) : nat * nat :=
  match n with
    | O => (1, 0)
    | S n' => let (a1, a0) := fib_co_acc n'
              in (a1 + a0, a1)
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fib_co_acc_0 :
  fib_co_acc 0 = (1, 0).
Proof.
  unfold_tactic fib_co_acc.
Qed.

Lemma unfold_fib_co_acc_S :
  forall n' : nat,
    fib_co_acc (S n') = let (a1, a0) := fib_co_acc n'
                        in (a1 + a0, a1).
Proof.
  unfold_tactic fib_co_acc.
Qed.

(* Main definition: *)

Definition fib_v5 (n : nat) : nat :=
  let (a1, a0) := fib_co_acc n
  in a0.

Compute (test_fib fib_v5).

(* Associated unfold lemmas: *)

Lemma unfold_fib_v5 :
  forall n : nat,
    fib_v5 n =
    let (a1, a0) := fib_co_acc n
  in a0.
Proof.
  unfold_tactic fib_v5.
Qed.

(* Eureka lemma: *)

Lemma about_fib_co_acc :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      fib_co_acc n = (fib (S n), fib n).
Proof.
Abort.

(* The main definition satisfies the specification: *)

Theorem fib_v5_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v5.
Proof.
Abort.

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

(* The fibonacci function with a co-accumulator in CPS: *)

Fixpoint fib_co_acc_cps (ans : Type) (n : nat) (k : nat * nat -> ans) : ans :=
  match n with
    | O =>
      k (1, 0)
    | S n' =>
      fib_co_acc_cps ans
                     n'
                     (fun p =>
                        match p with
                          | (a1, a0) =>
                            k (a1 + a0, a1)
                        end)
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fib_co_acc_cps_0 :
  forall (ans : Type)
         (k : nat * nat -> ans),
    fib_co_acc_cps ans 0 k = k (1, 0).
Proof.
  unfold_tactic fib_co_acc_cps.
Qed.

Lemma unfold_fib_co_acc_cps_S :
  forall (ans : Type)
         (n' : nat)
         (k : nat * nat -> ans),
    fib_co_acc_cps ans (S n') k =
    fib_co_acc_cps ans
                   n'
                   (fun p =>
                      match p with
                        | (a1, a0) =>
                          k (a1 + a0, a1)
                      end).
Proof.
  unfold_tactic fib_co_acc_cps.
Qed.

(* Main definition: *)

Definition fib_v6 (n : nat) : nat :=
  fib_co_acc_cps nat
                 n
                 (fun p =>
                    match p with
                    | (a1, a0) =>
                      a0
                    end).

Compute (test_fib fib_v6).

(* Associated unfold lemmas: *)

Lemma unfold_fib_v6_0 :
  fib_v6 0 = 0.
Proof.
  unfold_tactic fib_v6.
Qed.

Lemma unfold_fib_v6_S :
  forall n' : nat,
    fib_v6 (S n') =
    fib_co_acc_cps nat
                   n'
                   (fun p =>
                      match p with
                        | (a1, a0) =>
                          a1
                      end).
Proof.
  unfold_tactic fib_v6.
Qed.

(* Eureka lemma: *)

Lemma about_fib_co_acc_cps :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall (ans : Type)
           (n : nat)
           (k : nat * nat -> ans),
      fib_co_acc_cps ans n k =
      k (fib (S n), fib n).
Proof.
Abort.

(* The main definition satisfies the specification: *)

Theorem fib_v6_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v6.
Proof.
Abort.

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

(* The fibonacci function with a co-accumulator in CPS with a curried continuation: *)

Fixpoint fib_co_acc_cps' (ans : Type) (n : nat) (k : nat -> nat -> ans) : ans :=
  match n with
    | O =>
      k 1 0
    | S n' =>
      fib_co_acc_cps' ans
                     n'
                     (fun a1 a0 =>
                        k (a1 + a0) a1)
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fib_co_acc_cps'_0 :
  forall (ans : Type)
         (k : nat -> nat -> ans),
    fib_co_acc_cps' ans 0 k = k 1 0.
Proof.
  unfold_tactic fib_co_acc_cps'.
Qed.

Lemma unfold_fib_co_acc_cps'_S :
  forall (ans : Type)
         (n' : nat)
         (k : nat -> nat -> ans),
    fib_co_acc_cps' ans (S n') k =
    fib_co_acc_cps' ans
                   n'
                   (fun a1 a0 =>
                      k (a1 + a0) a1).
Proof.
  unfold_tactic fib_co_acc_cps'.
Qed.

(* Main definition: *)

Definition fib_v7 (n : nat) : nat :=
  match n with
    | O => 0
    | S n' =>
      fib_co_acc_cps' nat
                     n'
                     (fun a1 a0 =>
                        a1)
  end.

Compute (test_fib fib_v7).

(* Associated unfold lemmas: *)

Lemma unfold_fib_v7_0 :
  fib_v7 0 = 0.
Proof.
  unfold_tactic fib_v7.
Qed.

Lemma unfold_fib_v7_S :
  forall n' : nat,
    fib_v7 (S n') =
    fib_co_acc_cps' nat
                   n'
                   (fun a1 a0 =>
                      a1).
Proof.
  unfold_tactic fib_v7.
Qed.

(* Eureka lemma: *)

Lemma about_fib_co_acc_cps' :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall (ans : Type)
           (n : nat)
           (k : nat -> nat -> ans),
      fib_co_acc_cps' ans n k =
      k (fib (S n)) (fib n).
Proof.
Abort.

(* The main definition satisfies the specification: *)

Theorem fib_v7_fits_the_specification_of_fibonacci :
  specification_of_fibonacci fib_v7.
Proof.
Abort.

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

(* end of week-13_fib.v *)


(** * Selection:  Selection Sort, With Specification and Proof of Correctness*)
(**
  This sorting algorithm works by choosing (and deleting) the smallest
  element, then doing it again, and so on.  It takes O(N^2) time.

  You should never* use a selection sort.  If you want a simple
  quadratic-time sorting algorithm (for small input sizes) you should
  use insertion sort.  Insertion sort is simpler to implement, runs
  faster, and is simpler to prove correct.   We use selection sort here
  only to illustrate the proof techniques.

     *Well, hardly ever.  If the cost of "moving" an element is _much_
  larger than the cost of comparing two keys, then selection sort is
  better than insertion sort.  But this consideration does not apply in our
  setting, where the elements are  represented as pointers into the
  heap, and only the pointers need to be moved.

  What you should really never use is bubble sort.  Bubble sort
  would be the wrong way to go.  Everybody knows that!
  https://www.youtube.com/watch?v=k4RRi_ntQc8
*)

(* ################################################################# *)
(** * The Selection-Sort Program  *)

Require Export Coq.Lists.List.
From VFA Require Import Perm.

(** Find (and delete) the smallest element in a list. *)

Fixpoint select (x: nat) (l: list nat) : nat * list nat :=
match l with
|  nil => (x, nil)
|  h::t => if x <=? h
               then let (j, l') := select x t in (j, h::l')
               else let (j,l') := select h t in (j, x::l')
end.

(** Now, selection-sort works by repeatedly extracting the smallest element,
   and making a list of the results. *)

(* Uncomment this function, and try it.
Fixpoint selsort l :=
match l with
| i::r => let (j,r') := select i r
               in j :: selsort r'
| nil => nil
end.
*)

(** _Error: Recursive call to selsort has principal argument equal
  to [r'] instead of [r]_.  That is, the recursion is not _structural_, since
  the list r' is not a structural sublist of (i::r).  One way to fix the
  problem is to use Coq's [Function] feature, and prove that
  [length(r')<length(i::r)].  Later in this chapter, we'll show that approach.

  Instead, here we solve this problem is by providing "fuel", an additional
  argument that has no use in the algorithm except to bound the
  amount of recursion.  The [n] argument, below, is the fuel. *)

Fixpoint selsort l n {struct n} :=
match l, n with
| x::r, S n' => let (y,r') := select x r
               in y :: selsort r' n'
| nil, _ => nil
| _::_, O => nil  (* Oops!  Ran out of fuel! *)
end.

(** What happens if we run out of fuel before we reach the end
   of the list?  Then WE GET THE WRONG ANSWER. *)

Example out_of_gas: selsort [3;1;4;1;5] 3 <> [1;1;3;4;5].
Proof.
simpl.
intro. inversion H.
Qed.

(** What happens if we have have too much fuel?  No problem. *)

Example too_much_gas: selsort [3;1;4;1;5] 10 = [1;1;3;4;5].
Proof.
simpl.
auto.
Qed.

(** The selection_sort algorithm provides just enough fuel. *)

Definition selection_sort l := selsort l (length l).

Example sort_pi: selection_sort [3;1;4;1;5;9;2;6;5;3;5] = [1;1;2;3;3;4;5;5;5;6;9].
Proof.
unfold selection_sort.
simpl.
reflexivity.
Qed.

(** Specification of correctness of a sorting algorithm:
   it rearranges the elements into a list that is totally ordered. *)

Inductive sorted: list nat -> Prop :=
 | sorted_nil: sorted nil
 | sorted_1: forall i, sorted (i::nil)
 | sorted_cons: forall i j l, i <= j -> sorted (j::l) -> sorted (i::j::l).

Definition is_a_sorting_algorithm (f: list nat -> list nat) :=
  forall al, Permutation al (f al) /\ sorted (f al).

(* ################################################################# *)
(** * Proof of Correctness of Selection sort *)

(** Here's what we want to prove. *)

Definition selection_sort_correct : Prop :=
    is_a_sorting_algorithm selection_sort.

(** We'll start by working on part 1, permutations. *)

(** **** Exercise: 3 stars (select_perm)  *)
Lemma select_perm: forall x l,
  let (y,r) := select x l in
   Permutation (x::l) (y::r).
Proof.

(** NOTE: If you wish, you may [Require Import Multiset] and use the  multiset
  method, along with the theorem [contents_perm].  If you do,
  you'll still leave the statement of this theorem unchanged. *)

intros x l; revert x.
induction l; intros; simpl in *.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (selection_sort_perm)  *)
Lemma selsort_perm:
  forall n,
  forall l, length l = n -> Permutation l (selsort l n).
Proof.

(** NOTE: If you wish, you may [Require Import Multiset] and use the  multiset
  method, along with the theorem [same_contents_iff_perm]. *)

(* FILL IN HERE *) Admitted.

Theorem selection_sort_perm:
  forall l, Permutation l (selection_sort l).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (select_smallest)  *)
Lemma select_smallest_aux:
  forall x al y bl,
    Forall (fun z => y <= z) bl ->
    select x al = (y,bl) ->
    y <= x.
Proof.
(* Hint: no induction needed in this lemma.
   Just use existing lemmas about select, along with [Forall_perm] *)
(* FILL IN HERE *) Admitted.

Theorem select_smallest:
  forall x al y bl, select x al = (y,bl) ->
     Forall (fun z => y <= z) bl.
Proof.
intros x al; revert x; induction al; intros; simpl in *.
 (* FILL IN HERE *) admit.
bdestruct (x <=? a).
*
destruct (select x al) eqn:?H.
 (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (selection_sort_sorted)  *)
Lemma selection_sort_sorted_aux:
  forall  y bl,
   sorted (selsort bl (length bl)) ->
   Forall (fun z : nat => y <= z) bl ->
   sorted (y :: selsort bl (length bl)).
Proof.
 (* Hint: no induction needed.  Use lemmas selsort_perm and Forall_perm.*)
 (* FILL IN HERE *) Admitted.

Theorem selection_sort_sorted: forall al, sorted (selection_sort al).
Proof.
intros.
unfold selection_sort.
(* Hint: do induction on the [length] of al.
    In the inductive case, use [select_smallest], [select_perm],
    and [selection_sort_sorted_aux]. *)
 (* FILL IN HERE *) Admitted.
(** [] *)

(** Now we wrap it all up.  *)

Theorem selection_sort_is_correct: selection_sort_correct.
Proof.
split. apply selection_sort_perm. apply selection_sort_sorted.
Qed.

(* ################################################################# *)
(** * Recursive Functions That are Not Structurally Recursive *)

(** [Fixpoint] in Coq allows for recursive functions where some
  parameter is structurally recursive: in every call, the argument
  passed at that parameter position is an immediate substructure
  of the corresponding formal parameter.  For recursive functions
  where that is not the case -- but for which you can still prove
  that they terminate -- you can use a more advanced feature of
  Coq, called [Function]. *)

Require Import Recdef.  (* needed for [Function] feature *)

Function selsort' l {measure length l} :=
match l with
| x::r => let (y,r') := select x r
               in y :: selsort' r'
| nil => nil
end.

(** When you use [Function] with [measure], it's your
  obligation to prove that the measure actually decreases,
  before you can use the function. *)

Proof.
intros.
pose proof (select_perm x r).
rewrite teq0 in H.
apply Permutation_length in H.
simpl in *; omega.
Defined.  (* Use [Defined] instead of [Qed], otherwise you
  can't compute with the function in Coq. *)

(** **** Exercise: 3 stars (selsort'_perm)  *)
Lemma selsort'_perm:
  forall n,
  forall l, length l = n -> Permutation l (selsort' l).
Proof.

(** NOTE: If you wish, you may [Require Import Multiset]
  and use the  multiset method, along with the
  theorem [same_contents_iff_perm]. *)

(** Important!  Don't unfold [selsort'], or in general, never
  unfold anything defined with [Function]. Instead, use the
  recursion equation [selsort'_equation] that is automatically
  defined by the [Function] command. *)

(* FILL IN HERE *) Admitted.
(** [] *)

Eval compute in selsort' [3;1;4;1;5;9;2;6;5].

(** $Date$ *)


Module Type GROUP.
    Parameter G   : Set.
    Parameter f   : G -> G -> G.
    Parameter e   : G.
    Parameter i   : G -> G.
    Axiom assoc   : forall (a b c:G), f (f a b) c = f a (f b c).
    Axiom ident   : forall (a:G), f e a = a.   (* left identity enough ? *)
    Axiom inverse : forall (a:G), f (i a) a = e.    (* left side enough ? *)
End GROUP.

Module Type GROUP_THEOREMS.
    Declare Module M : GROUP.
    Import M.
    Axiom ident' : forall (a:M.G), M.f a (M.e) = a.
    Axiom inverse' : forall (a:G), f a (i a) = e.   (* Import M !! *)
    Axiom unique_e : forall e', (forall a, f e' a = a) -> e' = e.
End GROUP_THEOREMS.

Module GROUP_PROOFS (M:GROUP) : GROUP_THEOREMS with Module M := M.
Module M := M.
Import M.
Theorem inverse' : forall a, f a (i a) = e.
Proof.
    intros a.
    rewrite <- (ident (f a (i a))).
    remember (f e (f a (i a))) as x eqn:E.
    rewrite <- (inverse (f a (i a))) in E.
    rewrite assoc in E.
    rewrite assoc in E.
    rewrite <- (assoc (i a) a (i a)) in E.
    rewrite inverse in E.
    rewrite ident in E.
    rewrite inverse in E.
    assumption.
Qed.

Theorem ident' : forall (a:G), f a e = a.
Proof.
    intros a.
    rewrite <- (inverse a).
    rewrite <- assoc.
    rewrite inverse'.
    rewrite ident.
    reflexivity.
Qed.

Theorem unique_e : forall (e':G), (forall (a:G), f e' a = a) -> e' = e.
Proof.
    intros e' H. rewrite <- (ident' e'), H. reflexivity.
Qed.
End GROUP_PROOFS.

Require Import ZArith.
Open Scope Z_scope.
Module INT.
    Definition G := Z.
    Definition f x y := x + y.
    Definition e := 0.
    Definition i x := -x.
    Theorem assoc : forall a b c, f (f a b) c = f a (f b c).
    Proof. intros a b c. unfold f. ring. Qed.
    Theorem ident : forall a, f e a = a.
    Proof. intros a. unfold f. unfold e. ring. Qed.
    Theorem inverse : forall a, f (i a) a = e.
        intros a. unfold f, i, e. ring. Qed.
End INT.

Module INT_PROOFS := GROUP_PROOFS(INT).
Import INT_PROOFS.

Check unique_e.


(* Chap 9 ProofObjects *)
(* The Curry-Howard Correspondence *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

Print even.

Check ev_SS.

Print ev_4.

Check (ev_SS 2 (ev_SS 0 ev_0)).

Theorem ev_4': even 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

(* Chap 9.1 Proof Scripts *)
Theorem ev_4'': even 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

Definition ev_4''': even 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

Print ev_4.
Print ev_4'.
Print ev_4''.
Print ev_4'''.

Theorem ev_8: even 8.
Proof.
  apply (ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0)))).
Qed.

Definition ev_8': even 8 :=
  (ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0)))).

(* Chap 9.2 Quantifiers, Implications, Functions *)
Theorem ev_plus4: forall n, even n -> even (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

Definition ev_plus4': forall n, even n -> even (4 + n) :=
  fun (n: nat) => fun (H: even n) => ev_SS (S (S n)) (ev_SS n H).

Definition ev_plus2: Prop :=
  forall n, forall (E: even n), even (n + 2).

Definition ev_plus2': Prop :=
  forall n, forall (_: even n), even (n + 2).

Definition ev_plus2'': Prop :=
  forall n, even n -> even (n + 2).

(* Chap 9.3 Programming with Tactics *)
Definition add1: nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n.
Show Proof.
Defined.

Print add1.

(* Chap 9.4 Logical Connectives as Inductive Types *)
Module Props.

(* Chap 9.4.1 Conjunction *)
Module And.

Inductive and (P Q: Prop) : Prop :=
  | conj: P -> Q -> and P Q.

End And.

Print prod.

Lemma and_comm: forall P Q: Prop, P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
Qed.

Definition and_comm'_aux P Q (H: P /\ Q) : Q /\ P :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q: P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(* Exercise conj_fact *)
Definition conj_fact: forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun (P Q R: Prop) (H1: P /\ Q) (H2: Q /\ R) =>
  match H1, H2 with
  | conj p q, conj q' r => conj p r
  end.

(* Chap 9.4.2 Disjunction *)
Module Or.

Inductive or (P Q: Prop) : Prop :=
  | or_introl: P -> or P Q
  | or_intror: Q -> or P Q.

End Or.

(* Exercise op_commut'' *)
Definition or_comm: forall P Q, P \/ Q -> Q \/ P :=
  fun (P Q: Prop) (H: P \/ Q) =>
  match H with
  | or_introl P => or_intror P
  | or_intror P => or_introl P
  end.

(* Chap 9.4.3 Existential Quantification *)
Module Ex.

Inductive ex {A: Type} (P: A -> Prop) :=
  | ex_intro: forall x: A, P x -> ex P.

End Ex.

Check ex (fun n => even n).

Definition some_nat_is_even: exists n, even n :=
  ex_intro even 4 (ev_SS 2 (ev_SS 0 ev_0)).

(* Exercise ex_ev_Sn *)
Definition ex_ev_Sn: ex (fun n => even (S n)) :=
  ex_intro (fun n => even (S n)) 1 (ev_SS 0 ev_0).

(* Chap 9.4.4 True and False *)
Inductive True : Prop :=
  | I: True.

Inductive False: Prop := .

End Props.

(* Chap 9.5 Equality *)
Module MyEquality.

Inductive eq {X: Type}: X -> X -> Prop :=
  | eq_refl: forall x, eq x x.

Notation "x == y" := (eq x y)
  (at level 70, no associativity) : type_scope.

Lemma four: 2 + 2 == 1 + 3.
Proof.
  apply eq_refl.
Qed.

Definition four': 2 + 2 == 1 + 3 := eq_refl 4.

Definition singleton: forall (X: Type) (x: X),
  [] ++ [x] == x :: [] :=
  fun (X: Type) (x: X) => eq_refl [x].

(* Exercise equality__leibniz_equality *)
Lemma equality__leibniz_equality: forall (X: Type) (x y: X),
  x == y -> forall P: X -> Prop, P x -> P y.
Proof.
  intros X x y.
  intros.
  inversion H.
  rewrite H2 in H0.
  apply H0.
Qed.

(* Exercise leibniz_equality__equality *)
Lemma leibniz_equality__equality: forall (X: Type) (x y: X),
  (forall P: X -> Prop, P x -> P y) -> x == y.
Proof.
  intros.
  assert(I: x = x -> x = y).
  { apply H. }
  replace y with x.
  apply eq_refl.
  apply I.
  reflexivity.
Qed.

End MyEquality.


From LF Require Export exercise3.
From LF Require Export exercise2.
From LF Require Export exercise1.

Inductive list (X: Type) : Type :=
  | nil
  | cons (x: X) (l : list X).

Arguments nil {X}.
Arguments cons {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Definition mynil := @nil nat.
Check mynil.
Fail Definition mynil' := nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** **** Exercise: 2 stars, standard (poly_exercises)
Here are a few simple exercises, just like ones in the Lists chapter, for practice with polymorphism. Complete the proofs below. *)
Theorem app_nil_r : forall (X : Type), forall l : list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l as [| n l' H].
  - reflexivity.
  - simpl. rewrite H. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n : list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros. induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Lemma app_length : forall (X : Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

(** **** Exercise: 2 stars, standard (more_poly_exercises) *)
(* Here are some slightly more interesting ones... *)
Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. induction l1.
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros. induction l.
  - reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  | pair (x : X) (y : Y).
Arguments pair {X} {Y}.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.
Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
  : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(* Prints @pair: forall X Y, Type, X -> Y -> X * Y. *)
Check @pair.
(* Prints  [(1, false); (2, false)] *)
Compute (combine [1;2] [false;false;true;true]).

(** **** Exercise: 2 stars, standard, especially useful (split) *)
(* The function split is the right inverse of combine: it takes a list of pairs and returns a pair of lists. In many functional languages, it is called unzip. *)
(* Fill in the definition of split below. Make sure it passes the given unit test. *)
Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: l' => ((x :: fst (split l')), (y :: snd (split l')))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. simpl. reflexivity. Qed.

Fixpoint filter {X : Type} (pred : X -> bool) (l : list X) : list X :=
  match l with
  | nil => nil
  | h :: t =>
    if pred h then h :: (filter pred t)
    else (filter pred t)
  end.

Example test_filter2:
  filter (fun l => (length l) =? 1 )
         [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. simpl. reflexivity. Qed.

(** **** Exercise: 3 stars, standard (partition) *)
(* Use filter to write a Coq function partition:
      partition : ∀ X : Type,
                  (X → bool) → list X → list X × list X
Given a set X, a predicate of type X → bool and a list X, partition should return a pair of lists. The first
member of the pair is the sublist of the original list containing the elements that satisfy the test, and the
second is the sublist containing those that fail the test. The order of elements in the two sublists should be
the same as their order in the original list. *)
Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  match l with
  | [] => ([], [])
  | _ => ((filter test l), (filter (fun X => negb (test X)) (l)))
  end.

Example test_partition1: partition odd [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. simpl. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. simpl. reflexivity. Qed.

(* It takes a function f and a list l = [n1, n2, n3, ...] and returns the list [f n1, f n2, f n3,...]. *)
Fixpoint map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

(** **** Exercise: 3 stars, standard (map_rev) *)
(* Show that map and rev commute. You may need to define an auxiliary lemma. *)
Lemma map_f_assoc: forall (X Y: Type) (f : X -> Y) (l1 l2: list X),
  map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros. induction l.
  - reflexivity.
  - simpl. rewrite <- IHl. rewrite -> map_f_assoc. reflexivity.
Qed.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  end.

(** **** Exercise: 2 stars, standard, especially useful (flat_map) *)
(* The function map maps a list X to a list Y using a function of type X → Y. We can define a similar function,
flat_map, which maps a list X to a list Y using a function f of type X → list Y. Your definition should work by
'flattening' the results of f, like so:
        flat_map (fun n ⇒ [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12]. *)
Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : list Y :=
  match l with
  | [] => []
  | h :: t => ((f h) ++ (flat_map f t))
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. simpl. reflexivity. Qed.

Fixpoint fold {X Y: Type} (f : X -> Y -> Y) (l : list X) (b : Y)
                         : Y :=
  match l with
  | [] => b
  | h :: t => f h (fold f t b)
  end.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf2 : natural) (x : natural) : natural :=
  plus y (mult x (Succ y)).


Require Export Shared.Prelim.

Definition reduces X Y (p : X -> Prop) (q : Y -> Prop) := exists f : X -> Y, forall x, p x <-> q (f x).
Notation "p ⪯ q" := (reduces p q) (at level 50).

Lemma reduces_reflexive X (p : X -> Prop) : p ⪯ p.
Proof. exists (fun x => x); tauto. Qed.

Lemma reduces_transitive X Y Z (p : X -> Prop) (q : Y -> Prop) (r : Z -> Prop) :
  p ⪯ q -> q ⪯ r -> p ⪯ r.
Proof.
  intros [f ?] [g ?]. exists (fun x => g (f x)). firstorder.
Qed.


Require Export TopologicalSpaces.
Require Export Continuity.

Inductive homeomorphism {X Y:TopologicalSpace}
  (f:point_set X -> point_set Y) : Prop :=
| intro_homeomorphism: forall g:point_set Y -> point_set X,
  continuous f -> continuous g ->
  (forall x:point_set X, g (f x) = x) ->
  (forall y:point_set Y, f (g y) = y) -> homeomorphism f.

Lemma homeomorphism_is_invertible: forall {X Y:TopologicalSpace}
  (f:point_set X -> point_set Y),
  homeomorphism f -> invertible f.
Proof.
intros.
destruct H as [g].
exists g; trivial.
Qed.

Definition open_map {X Y:TopologicalSpace}
  (f:point_set X -> point_set Y) : Prop :=
forall U:Ensemble (point_set X), open U -> open (Im U f).

Lemma homeomorphism_is_open_map: forall {X Y:TopologicalSpace}
  (f:point_set X -> point_set Y),
  homeomorphism f -> open_map f.
Proof.
intros.
destruct H as [g].
red; intros.
assert (Im U f = inverse_image g U).
apply Extensionality_Ensembles; split; red; intros.
destruct H4.
rewrite H5.
constructor.
rewrite H1; trivial.
destruct H4.
exists (g x); trivial.
symmetry; apply H2.
rewrite H4; apply H0; trivial.
Qed.

Lemma invertible_open_map_is_homeomorphism: forall {X Y:TopologicalSpace}
  (f:point_set X -> point_set Y),
  invertible f -> continuous f -> open_map f -> homeomorphism f.
Proof.
intros.
destruct H as [g].
exists g; trivial.
red; intros.
assert (inverse_image g V = Im V f).
apply Extensionality_Ensembles; split; red; intros.
destruct H4.
exists (g x); trivial.
symmetry; apply H2.
destruct H4.
constructor.
rewrite H5.
rewrite H; trivial.
rewrite H4; apply H1; trivial.
Qed.

Inductive homeomorphic (X Y:TopologicalSpace) : Prop :=
| intro_homeomorphic: forall f:point_set X -> point_set Y,
    homeomorphism f -> homeomorphic X Y.

Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.

Lemma homeomorphic_equiv: equivalence homeomorphic.
Proof.
constructor.
red; intros X.
exists (fun x:point_set X => x).
exists (fun x:point_set X => x); trivial;
  apply continuous_identity.

red; intros X Y Z ? ?.
destruct H as [f [finv]].
destruct H0 as [g [ginv]].
exists (fun x:point_set X => g (f x)).
exists (fun z:point_set Z => finv (ginv z)); (congruence ||
  apply continuous_composition; trivial).

red; intros X Y ?.
destruct H as [f [finv]].
exists finv; exists f; trivial.
Qed.


(* A typeclass representing an upper semilattice. A small number
   of useful lemmas are proven that we end up using in
   type_system.v to show non-interference *)

(* See poset.v for more discussion around typeclasses and what
   we use them for. *)

(* TODO: move these citations to poset.v? *)

(* lattice stuff influenced by A reflection-based
proof tactic for lattices in Coq by Daniel James
and Ralf Hinze *)

(* also: A Gentle Introducton to Type Classes and
    Relations in Coq by Pierre Casteran *)

(* An upper semilattice is a poset with additional properties *)

Require Import poset.

Class UpperSemilattice
  {A} {precedes} (P : Poset A precedes)
  (join : A -> A -> A) (bottom : A) := {
    join_commutative : forall a b, join a b = join b a;
    join_associative : forall a b c,
      join (join a b) c = join a (join b c);
    join_idempotent : forall a, join a a = a;
    bottom_prop : forall a, join bottom a = a;
    order_induction : forall a b, precedes a b <-> join a b = b
}.

Lemma precedes_join
  {A} {precedes} {P : Poset A precedes}
  {join} {bottom} {USL : UpperSemilattice P join bottom}
  a b :
  precedes a (join a b).
Proof.
  apply order_induction.
  rewrite <- join_associative. now rewrite join_idempotent.
Qed.

Lemma precedes_join2
  {A} {precedes} {P : Poset A precedes}
  {join} {bottom} {USL : UpperSemilattice P join bottom}
  a b c :
  precedes a b -> precedes a (join b c).
Proof.
  intros H. apply order_induction in H.
  apply order_induction.
  rewrite <- join_associative. now rewrite H.
Qed.

Lemma precedes_join3
  {A} {precedes} {P : Poset A precedes}
  {join} {bottom} {USL : UpperSemilattice P join bottom}
  a b c :
  precedes a c -> precedes a (join b c).
Proof.
  intros. apply order_induction. rewrite <- join_associative.
  assert (join a b = join b a) as Hab_comm by apply join_commutative.
  rewrite Hab_comm, join_associative.
  apply order_induction in H. now rewrite H.
Qed.


Require Export MoreLogic.

Theorem six_is_beautiful: beautiful 6.
Proof.
  apply b_sum with (n:=3) (m:=3).
  apply b_3.
  apply b_3.
Qed.

Definition six_is_beautiful': beautiful 6 :=
  b_sum 3 3 b_3 b_3.

Theorem nine_is_beautiful: beautiful 9.
Proof.
  apply b_sum with (n:=3) (m:=6).
  apply b_3.
  apply six_is_beautiful.
Qed.

Definition nine_is_beautiful': beautiful 9 :=
  b_sum 3 6 b_3 six_is_beautiful.

Theorem b_plus3: forall n, beautiful n -> beautiful (3+n).
Proof.
  intros n H.
  apply b_sum.
  apply b_3.
  apply H.
Qed.

Definition b_plus3': forall n, beautiful n -> beautiful (3+n) :=
  fun (n:nat) => fun (H:beautiful n) =>
                   b_sum 3 n b_3 H.

Definition b_plus3'' (n:nat) (H:beautiful n) : beautiful (3+n) :=
  b_sum 3 n b_3 H.

Definition b_times2' : forall n, beautiful n -> beautiful (2*n) :=
  fun (n:nat) => fun (H:beautiful n) =>
                   b_sum n (n + 0) H (b_sum n 0 H b_0).

Definition gorgeous_plus13_po : forall n, gorgeous n -> gorgeous (13 + n) :=
  fun (n:nat) => fun (H:gorgeous n) =>
                   g_plus3 (10 + n)
                           (g_plus5 (5 + n)
                                    (g_plus5 n H)).

Definition conj_fact : forall P Q R, P /\ Q  -> Q /\ R -> P /\ R :=
  fun (P Q R : Prop) (H1: P /\ Q) =>
    fun (H2: Q /\ R) =>
      match H1 with
        | conj HP HQ =>
          match H2 with
            | conj HQ HR => conj P R HP HR
          end
      end.

Definition beautiful_iff_gorgeous : forall n, beautiful n <-> gorgeous n :=
  fun (n:nat) =>
    conj (beautiful n -> gorgeous n)
         (gorgeous n -> beautiful n)
         (beautiful__gorgeous n)
         (gorgeous__beautiful n).

Definition or_commut'' : forall P Q, P \/ Q -> Q \/ P :=
  fun (P Q : Prop) =>
    fun (HPQ : P \/ Q) =>
      match HPQ with
        | or_introl HP => or_intror Q P HP
        | or_intror HQ => or_introl Q P HQ
      end.

Lemma plus_comm_r : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite (plus_comm b a).
  reflexivity.
Qed.

Lemma plus_comm_r' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite (plus_comm b).
  reflexivity.
Qed.

Lemma plus_comm_r'' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite (plus_comm _ a).
  reflexivity.
Qed.

Lemma plus_comm_r''' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite plus_comm with (n := b).
  reflexivity.
Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
                              [a;b] = [c;d] ->
                              [c;d] = [e;f] ->
                              [a;b] = [e;f].
Proof.
  intros a b c d e f H1 H2.
  apply (trans_eq _ _ [c;d]).
  apply H1.
  apply H2.
Qed.