(** * Some useful bounds N.

*)

Require Export BinNat.
Require Export NArith.
Hint Resolve N.le_refl
       N.le_le_succ_r
       N.lt_succ_diag_r
       N.lt_lt_succ_r
       N.size_gt
       N.le_trans
       N.lt_le_trans
       N.le_lt_trans
       N.le_0_l
       N.pow_nonzero
       N.add_le_mono
       N.add_lt_mono
       N.mul_le_mono
       N.mul_lt_mono
       N.pow_le_mono_r  : Nfacts.

Hint Rewrite
     N.sub_0_r N.sub_diag N.mod_0_l N.mod_mod
     N.div2_succ_double N.div2_double
     N.add_1_r N.add_1_l
     N.add_0_r N.add_0_l
     N.pow_add_r
     N.pow_succ_r
     N.add_sub
  : Nrewrites.

Ltac crush :=
  repeat (
      try intros;
      eauto with Nfacts;
      autorewrite with Nrewrites;
      try (simpl; f_equal);
      match goal with
      | [ _ : ?P |- ?P ] => assumption
      | [ |- (?n + ?p < ?m + ?q)%N ] => apply (N.add_lt_mono n m p q)
      | [ |- (?n * ?p < ?m * ?q)%N ] => apply (N.mul_lt_mono n m p q)
      | [ |- positive -> _ ] => let p := fresh "p" in intro p
      | [ |- N -> _ ] => let n := fresh "n" in intro n
      | [ p : positive |- _ ] => induction p
      | _ => idtac
      end; eauto with Nfacts).

Lemma of_nat_le_mono: forall a b, a <= b -> (N.of_nat a <= N.of_nat b)%N.
Proof.
  intros a b aleb.
  Hint Rewrite Nat2N.inj_succ : Nrewrites.
  induction aleb; crush.
Qed.

Hint Resolve of_nat_le_mono : Nfacts.

Lemma inj_size : forall x, N.of_nat (N.size_nat x) = N.size x.
Proof.
  intro x; induction x;
    assert (forall p, Pos.of_succ_nat (Pos.size_nat p) = Pos.succ (Pos.size p));
  crush.
Qed.

Lemma N_2_neq_0 : (2 <> 0)%N.
Proof.
  intro Hyp; inversion Hyp.
Qed.

Hint Resolve N_2_neq_0 : Nfacts.

Lemma N_pow_2_neq_0 : forall n, (2^n <> 0)%N.
Proof.
  crush.
Qed.

Lemma Npow_2_le_mono : forall a b, (a <= b -> 2^a <= 2^b)%N.
Proof.
  crush.
Qed.

Lemma Npow_2_le_mono_nat : forall a b, a <= b -> (2^(N.of_nat a) <= 2^(N.of_nat b))%N.
Proof.
  crush.
Qed.

Hint Resolve Npow_2_le_mono : Nfacts.

Lemma Nsize_pow_2 n x : (N.size x <= n -> x < 2^n)%N.
Proof.
  intros; assert (2^N.size x <= 2^n)%N;assert (x < 2^ N.size x)%N; crush.
Qed.

Hint Resolve Nsize_pow_2 : Nfacts.

Lemma Nsize_nat_pow_2  n x : N.size_nat x <= n -> (x < 2^(N.of_nat n))%N.
Proof.
  intros; assert (N.size x <= N.of_nat n)%N;
  try (rewrite <- inj_size);
  crush.
Qed.

Hint Resolve Nsize_nat_pow_2 : Nfacts.

Lemma Ndouble_twice : forall (x : N),  (x + x = 2 *x)%N.
  intro;
    apply N2Nat.inj.
  autorewrite with Nnat.
  crush.
Qed.

Lemma Nadd_bound n a b :  (N.size a <= n -> N.size b <= n
                           -> (a + b) < 2^(1+n))%N.
Proof.
  intros.
  Hint Resolve N.add_le_mono : Nfacts.
  autorewrite with Nrewrites.
  rewrite <- Ndouble_twice.
  crush.
Qed.

Lemma Nadd_bound_gen n m a b :  (n < m -> N.size a <= n -> N.size b <= n
                            -> (a + b) < 2^m)%N.
Proof.
  intros.
  Hint Resolve Npow_2_le_mono : Nfacts.
  Hint Resolve N.le_succ_l : Nfacts.
  Hint Resolve Nadd_bound : Nfacts.
  assert (a + b  < 2^(1+n))%N by eauto with Nfacts.
  assert (1+n <= m)%N by (crush; now apply N.le_succ_l).
  assert (2^(1+n) <= 2^m)%N by now apply (Npow_2_le_mono (1+n) m)%N.
  crush.
Qed.

Lemma Nadd_bound_nat n a b : N.size_nat a <= n -> N.size_nat b <= n
                               -> ((a + b) < 2^(N.of_nat (S n)))%N.
Proof.
  autorewrite with Nrewrites;
  try (rewrite <- Ndouble_twice);
  crush.
Qed.

Lemma Nadd_bound_nat_gen n m a b : n < m -> N.size_nat a <= n -> N.size_nat b <= n
                               -> ((a + b) < 2^(N.of_nat m))%N.
Proof.
  intros.
  Hint Resolve Npow_2_le_mono_nat : Nfacts.
  Hint Resolve Nadd_bound_nat : Nfacts.
  assert(a+b < 2^N.of_nat (S n))%N; crush.
Qed.

Lemma Nmul_bound n0 n1 a b :  (N.size a <= n0 -> N.size b <= n1
                               -> (a * b) < 2^(n0 + n1))%N.
Proof.
  crush.
Qed.

Lemma Nmul_bound_nat n0 n1 a b :  N.size_nat a <= n0 -> N.size_nat b <= n1
                               -> ((a * b) < 2^(N.of_nat (n0 + n1)))%N.
Proof.
  Hint Rewrite Nat2N.inj_add : Nrewrites.
  crush.
Qed.

Lemma div_mod_sub : forall a b, b <> 0%N ->  (a / b * b = a - a mod b)%N.
  intros a b Hbnz.
  rewrite N.mul_comm.
  set (lhs:= (b*(a/b))%N).
  set (amb := (a mod b)%N).
  rewrite (N.div_mod a b); trivial.
  crush.
Qed.

Lemma divide_add_mod_multiple : forall x m n p : N, n <> 0%N -> (n | m)%N ->  (x mod n = (m * p + x) mod n )%N.
Proof.
    intros x m n p.
    intro HnNz.
    intro HnDm.
    rewrite N.add_mod; trivial.
    rewrite N.mul_mod; trivial.
    assert (Hmnz : (m mod n = 0)%N) by (rewrite (N.mod_divide m n HnNz); trivial).
    rewrite Hmnz.
    crush.
Qed.

Lemma divide_mod_mod : forall (x m n : N), m <> 0%N ->  n <> 0%N -> (n | m)%N ->  ( (x mod m ) mod n = x mod n)%N.
  intros x m n.
  intros HmnZ HnnZ.
  intro HnDm.
  rewrite (divide_add_mod_multiple (x mod m) m n (x / m)); trivial.
  rewrite <- N.div_mod; trivial.
Qed.

(*
Hint Rewrite divide_mod_mod : localdb.
*)

Lemma divide_mod_le : forall (x m n : N), m <> 0%N -> n <> 0%N -> (n | m)%N  -> (n < m)%N ->  (x mod n <= x mod m)%N.
  intros x m n.
  intros HmNz HnNz HnDm HnLTm.
  rewrite <- (divide_mod_mod x m n); trivial.
  apply (N.mod_le (x mod m) n); trivial.
Qed.

Lemma add_sub_le : forall a b : N, (a <= b)%N -> (a + (b - a) = b)%N.
  intros a b HaLeB.
  rewrite N.add_sub_assoc; eauto.
  rewrite N.add_comm.
  apply N.add_sub.
Qed.


Require Import Arith.
Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.

Set Implicit Arguments.

Lemma leb_false_lt : forall m n, leb m n = false -> n < m.
Proof.
  induction m; intros.
  - discriminate.
  - simpl in *. break_match; subst; auto with arith.
Qed.

Lemma leb_true_le : forall m n, leb m n = true -> m <= n.
Proof.
  induction m; intros.
  - auto with arith.
  - simpl in *. break_match; subst; auto with arith.
    discriminate.
Qed.

Lemma ltb_false_le : forall m n, m <? n = false -> n <= m.
Proof.
  induction m; intros; destruct n; try discriminate; auto with arith.
Qed.

Lemma ltb_true_lt : forall m n, m <? n = true -> m < n.
  induction m; intros; destruct n; try discriminate; auto with arith.
Qed.

Ltac do_bool :=
  repeat match goal with
    | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true in H
    | [ H : beq_nat _ _ = false |- _ ] => apply beq_nat_false in H
    | [ H : andb _ _ = true |- _ ] => apply Bool.andb_true_iff in H
    | [ H : andb _ _ = false |- _ ] => apply Bool.andb_false_iff in H
    | [ H : orb _ _ = true |- _ ] => apply Bool.orb_prop in H
    | [ H : negb _ = true |- _ ] => apply Bool.negb_true_iff in H
    | [ H : negb _ = false |- _ ] => apply Bool.negb_false_iff in H
    | [ H : PeanoNat.Nat.ltb _ _ = true |- _ ] => apply ltb_true_lt in H
    | [ H : PeanoNat.Nat.ltb _ _ = false |- _ ] => apply ltb_false_le in H
    | [ H : leb _ _ = true |- _ ] => apply leb_true_le in H
    | [ H : leb _ _ = false |- _ ] => apply leb_false_lt in H
    | [ |- andb _ _ = true ]=> apply Bool.andb_true_iff
    | [ |- andb _ _ = false ] => apply Bool.andb_false_iff
    | [ |- leb _ _ = true ] => apply leb_correct
    | [ |-  _ <> false ] => apply Bool.not_false_iff_true
    | [ |- beq_nat _ _ = false ] => apply beq_nat_false_iff
    | [ |- beq_nat _ _ = true ] => apply beq_nat_true_iff
  end.

Definition null {A : Type} (xs : list A) : bool :=
  match xs with
    | [] => true
    | _ => false
  end.

Lemma null_sound :
  forall A (l : list A),
    null l = true -> l = [].
Proof.
  destruct l; simpl in *; auto; discriminate.
Qed.

Lemma null_false_neq_nil :
  forall A (l : list A),
    null l = false -> l <> [].
Proof.
  destruct l; simpl in *; auto; discriminate.
Qed.


(* Exercise done by David Braun under the supervision of Nicolas Magaud, cleaned up by Julien Narboux. *)

Require Export GeoCoq.Tarski_dev.Annexes.midpoint_theorems.
Section T_42.

Context `{TE:Tarski_euclidean}.

Lemma midpoint_thales : forall O A B C : Tpoint,
   ~ Col A B C ->
   Midpoint O A B ->
   Cong O A O C ->
   Per A C B.
Proof.
intros.
Name X the midpoint of C and A.
assert (Par_strict O X B C)
 by perm_apply (triangle_mid_par_strict_cong_simp C B A O X).
assert(Per O X A)
 by (exists C;split;finish).
assert_diffs.
assert_cols.
assert(Hid2 : Perp O X C A)
 by perm_apply (col_per_perp O X A C).
assert (Perp B C C A).
 apply (cop_par_perp__perp O X B C C A);finish.
apply perp_per_1;Perp.
Qed.

(* TODO cleanup *)

Lemma midpoint_thales_reci :
  forall a b c o: Tpoint,
   Per a c b ->
   Midpoint o a b ->
   Cong o a o b /\ Cong o b o c.
Proof.
intros.

induction (col_dec a b c).

induction (l8_9 a c b H);
treat_equalities;assert_congs_perm;try split;finish.
assert_diffs.
(* Demonstration Cong o a o b *)
assert_congs_perm.
split.
Cong.
(* Demonstration Cong o b o c *)
assert(Hmid := midpoint_existence a c).
(* Soit x Le milieu de a c *)
destruct Hmid.
(* Demonstration o x parallele à b c *)
assert(Hpar : Par c b x o).
apply (triangle_mid_par c b a o x);finish.
(* On doit effectuer Le changement d'angle perpendiculaire en appliquant par_perp_perp*)
(* Demonstration du sous but Perp pour appliquer par_perp_perp *)
assert(Hper : Perp c b c a)
 by (apply perp_left_comm;apply per_perp;Perp).
(* Demonstratin du sous but Cop pour appliquer par_perp_perp *)
assert(Hcop : Coplanar x o c a) by Cop.
(* Application de par_perp_perp *)
assert(HH := cop_par_perp__perp c b x o c a Hpar Hper).
assert(Hper2 : Perp c x o x).
  apply (perp_col c a o x x).
  assert_diffs.
  finish.
  Perp.
  assert_cols;Col.
(*Transformation de Perp c x o x en Per *)
assert_diffs.
assert (Per o x c)
 by (apply perp_per_2;Perp).

(* Depliage de Per pour obtenir Cong o b o c *)
unfold Per in H8.
destruct H8.
spliter.
apply l7_2 in H8.
assert(HmidU := l7_9 a x0 x c H2 H8).
subst.
unfold Midpoint in H2.
spliter.
eCong.
Qed.

End T_42.


Require Export P01.

(** **** Exercise: 2 stars, standard (orb_false_elim2)

    Prove the following claim, marking cases (and subcases) with
    bullets when you use [destruct]. *)

Theorem orb_false_elim2 : forall b c : bool,
  orb b c = false -> c = false.
Proof.
  exact FILL_IN_HERE.
Qed.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Coq.Lists.List.
Require Import Coq.Strings.Ascii.
Require Import Turing.Lang.
Require Import Turing.Regular.
Require Import Turing.Regex.
Require Import Turing.Util.
Require Import Omega.
Import ListNotations.
Import RegexNotations.
Import Lang.LangNotations.
Open Scope char_scope.
Open Scope lang_scope.
Open Scope regex_scope.

(* ---------------------- END OF PREAMBLE ------------------ *)

(**

  The objective of this homework assignment is to prove that
  language L5 is not regular, where L5 is a^n b^m where n < m.

  WARNING: DO NOT CHANGE DEFINITION L5, otherwise you will get 0 points for
  this assignment.

*)
Definition L5 : language := fun w => exists n m, w = pow1 "a" n ++ (pow1 "b" ((S m) + n)).

Lemma pow1_app_cons_inv_eq_1:
forall {T} (a b:T),
a <> b ->
forall x y v w,
pow1 a x ++ b :: y = pow1 a v ++ b :: w ->
x = v.
Proof.
intros ? a b.
induction x; intros. {
    simpl in *.
    destruct v; auto.
    simpl in *.
    inversion H0.
    subst.
    contradiction.
}
simpl in *.
destruct v; simpl in *. {
    inversion H0.
    subst.
    contradiction.
}
inversion H0; subst; clear H0.
apply IHx in H2.
subst; reflexivity.
Qed.

(* ---------------------------------------------------------------------------*)

(**

Easy. Show that the word that clogs is in L5.

 *)
Theorem l5_not_regular_1:
  forall p, In (pow1 "a" p ++ pow1 "b" (S p)) L5.
Proof.
  simpl.
  intros N.
  unfold In.
  unfold L5.
  exists N.
  exists 0.
  simpl.
  reflexivity.
Qed.

(**

Easy. Show that the clogged word has at least p-characters.

 *)
Theorem l5_not_regular_2:
  forall p, length (pow1 "a" p ++ pow1 "b" (S p)) >= p.
Proof.
  simpl.
  intros N.
  induction N.
  - simpl.
    intuition.
  - simpl.
    rewrite -> app_length.
    rewrite -> pow1_length.
    omega.
Qed.

(**

Difficult. The proof for Regular.Examples.l4_not_regular_alt is similar to what you should be doing. The only theorem you need to use is Regular.Examples.xyz_rw_ex.

 *)
Theorem l5_not_regular_4_1:
  forall p x y z n m, p >= 1 -> y <> [] -> pow1 "a" p ++ "b" :: pow1 "b" p = x ++ y ++ z -> length (x ++ y) <= p -> x ++ (y ++ y) ++ z = pow1 "a" n ++ pow1 "b" (S m + n) -> exists nx ny o,
    ny <> 0 /\
    pow1 "a" nx ++
    (pow1 "a" ny ++ pow1 "a" ny) ++
    pow1 "a" o ++
    "b" :: pow1 "b" (length (pow1 "a" nx ++ pow1 "a" ny) + o)
    =
    pow1 "a" n ++ pow1 "b" (S m + n).
Proof.
  simpl.
  intros N.
  intros M.
  intros O.
  intros P.
  intros Q.
  intros R.
  intros S.
  intros T.
  intros V.
  intros W.
  intros X.
  apply Regular.Examples.xyz_rw_ex in V.
  destruct V.
  destruct H.
  destruct H0.
  destruct H1.
  destruct H2.
  rewrite -> H1 in X.
  rewrite -> H2 in X.
  rewrite -> H3 in X.
  rewrite -> H in X.
  repeat rewrite app_assoc in *. (* l4_not_regular *)
  repeat rewrite pow1_plus in *.
  exists (length M), (length O), x.
  split.
  - simpl.
    intros Y.
    destruct O.
    + simpl.
      contradiction T.
    + simpl.
      inversion Y.
  - simpl.
    repeat rewrite app_assoc in *.
    repeat rewrite pow1_plus in *.
    rewrite -> pow1_length.
    rewrite -> app_length in X.
    rewrite -> X.
    simpl.
    reflexivity.
  - simpl.
    assumption.
Qed.

(**

Easy. Use rewriting rules (eg, app_assoc).

 *)
Theorem l5_not_regular_4_2:
  forall nx ny n m o, pow1 "a" nx ++ (pow1 "a" ny ++ pow1 "a" ny) ++ pow1 "a" o ++ "b" :: pow1 "b" (length (pow1 "a" nx ++ pow1 "a" ny) + o) = pow1 "a" n ++ pow1 "b" (S m + n) -> pow1 "a" (nx + ny + ny + o) ++ "b" :: pow1 "b" (nx + ny + o) = pow1 "a" n ++ "b" :: pow1 "b" (m + n).
Proof.
  simpl.
  intros N.
  intros M.
  intros O.
  intros P.
  intros Q.
  intros R.
  repeat rewrite app_assoc in R.
  repeat rewrite pow1_plus in R.
  repeat rewrite pow1_length in R.
  assumption.
Qed.

(**

Hard. This is the final step of the proof. You want to start by showing that the powers of "a" are equal (for which you'll need pow1_app_cons_inv_eq_1). After that you want to remove the left-hand side of the equality with app_inv_head. Your final step should be to conclude that both powers must be equal. Once you have an equality over naturals, then use `omega` to conclude.

 *)
Theorem l5_not_regular_4_3:
  forall nx ny o n m, ny <> 0 -> pow1 "a" (nx + ny + ny + o) ++ "b" :: pow1 "b" (nx + ny + o) <>
    pow1 "a" n ++ "b" :: pow1 "b" (m + n).
Proof.
  simpl.
  intros N.
  intros O.
  intros P.
  intros Q.
  intros R.
  intros S.
  intros T.
  inversion T.
  apply pow1_app_cons_inv_eq_1 in H0.
  - simpl.
    rewrite -> H0 in T.
    apply app_inv_head in T.
    inversion T.
    apply pow1_inv_eq in H1.
    omega.
  - simpl.
    intros V.
    inversion V.
Qed.

(**

Easy. Use the lemmas that start with l5_not_regular_4_

 *)
Theorem l5_not_regular_4:
  forall p m n x y z, p >= 1 -> y <> [] -> pow1 "a" p ++ "b" :: pow1 "b" p = x ++ y ++ z -> length (x ++ y) <= p -> x ++ (y ++ y) ++ z <> pow1 "a" n ++ pow1 "b" (S m + n).
Proof.
  simpl.
  intros N.
  intros O.
  intros P.
  intros Q.
  intros R.
  intros S.
  intros T.
  intros V.
  intros W.
  intros X.
  intros Y.
  apply l5_not_regular_4_1 with (p:= N) in Y.
  - simpl.
    destruct Y.
    destruct H.
    destruct H.
    destruct H.
    apply l5_not_regular_4_2 in H0.
    apply l5_not_regular_4_3 in H0.
    + simpl.
      assumption.
    + simpl.
      assumption.
  - simpl.
    omega.
  - simpl.
    assumption.
  - simpl.
    assumption.
  - simpl.
    assumption.
Qed.

(**

Easy. Show that a^p b^(p+1) clogs L5. Conclude the proof using Lemma l5_not_regular_4 to conclude.

 *)
Theorem l5_not_regular_3:
  forall p, p >= 1 -> In (pow1 "a" p ++ pow1 "b" (S p)) (Clogs L5 p).
Proof.
  - simpl.
    unfold In, Clogs.
    intros N.
    intros O.
    intros P.
    intros Q.
    intros R.
    intros S.
    intros T.
    intros V.
    exists 2.
    intros W.
    unfold In in W.
    unfold L5 in W.
    destruct W.
    destruct H.
    simpl in H.
    rewrite app_nil_r in H.
    apply l5_not_regular_4 with (p:=N) in H.
    + simpl.
      apply H.
    + simpl.
      assumption.
    + simpl.
      assumption.
    + simpl.
      assumption.
    + simpl.
      assumption.
Qed.

(**

Easy. Show that L5 is not regular.

 *)
Theorem l5_not_regular:
  ~ Regular L5.
Proof.
  simpl.
  unfold L5.
  apply not_regular.
  intros N.
  intros O.
  apply clogged_def with (w:=(pow1 "a" N ++ pow1 "b" (1 + N)) % list).
  - simpl.
    unfold In.
    unfold L5.
    exists N.
    exists 0.
    simpl.
    reflexivity.
  - simpl.
    induction N.
    + simpl.
      intuition.
    + simpl.
      rewrite -> app_length.
      rewrite -> pow1_length.
      omega.
  - simpl.
    unfold In, Clogs.
    intros P.
    intros Q.
    intros R.
    intros S.
    intros T.
    intros V.
    exists 2.
    intros W.
    unfold In in W.
    unfold L5 in W.
    destruct W.
    destruct H.
    simpl in H.
    rewrite app_nil_r in H.
    apply l5_not_regular_4 with (p:=N) in H.
    + simpl.
      apply H.
    + simpl.
      assumption.
    + simpl.
      assumption.
    + simpl.
      assumption.
    + simpl.
      assumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Sorted.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(* Made by Hugo Herbelin *)

(** This file defines two notions of sorted list:

  - a list is locally sorted if any element is smaller or equal than
    its successor in the list
  - a list is sorted if any element coming before another one is
    smaller or equal than this other element

  The two notions are equivalent if the order is transitive.
*)

Require Import List Relations Relations_1.

(** Preambule *)

Set Implicit Arguments.
Local Notation "[ ]" := nil (at level 0).
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0).
Implicit Arguments Transitive [U].

Section defs.

  Variable A : Type.
  Variable R : A -> A -> Prop.

  (** Locally sorted: consecutive elements of the list are ordered *)

  Inductive LocallySorted : list A -> Prop :=
    | LSorted_nil : LocallySorted []
    | LSorted_cons1 a : LocallySorted [a]
    | LSorted_consn a b l :
        LocallySorted (b :: l) -> R a b -> LocallySorted (a :: b :: l).

  (** Alternative two-step definition of being locally sorted *)

  Inductive HdRel a : list A -> Prop :=
    | HdRel_nil : HdRel a []
    | HdRel_cons b l : R a b -> HdRel a (b :: l).

  Inductive Sorted : list A -> Prop :=
    | Sorted_nil : Sorted []
    | Sorted_cons a l : Sorted l -> HdRel a l -> Sorted (a :: l).

  Lemma HdRel_inv : forall a b l, HdRel a (b :: l) -> R a b.
  Proof.
    inversion 1; auto.
  Qed.

  Lemma Sorted_inv :
    forall a l, Sorted (a :: l) -> Sorted l /\ HdRel a l.
  Proof.
    intros a l H; inversion H; auto.
  Qed.

  Lemma Sorted_rect :
    forall P:list A -> Type,
      P [] ->
      (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) ->
      forall l:list A, Sorted l -> P l.
  Proof.
    induction l; firstorder using Sorted_inv.
  Qed.

  Lemma Sorted_LocallySorted_iff : forall l, Sorted l <-> LocallySorted l.
  Proof.
    split; [induction 1 as [|a l [|]]| induction 1];
      auto using Sorted, LocallySorted, HdRel.
    inversion H1; subst; auto using LocallySorted.
  Qed.

  (** Strongly sorted: elements of the list are pairwise ordered *)

  Inductive StronglySorted : list A -> Prop :=
    | SSorted_nil : StronglySorted []
    | SSorted_cons a l : StronglySorted l -> Forall (R a) l -> StronglySorted (a :: l).

  Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) ->
    StronglySorted l /\ Forall (R a) l.
  Proof.
    intros; inversion H; auto.
  Defined.

  Lemma StronglySorted_rect :
    forall P:list A -> Type,
      P [] ->
      (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) ->
      forall l, StronglySorted l -> P l.
  Proof.
    induction l; firstorder using StronglySorted_inv.
  Defined.

  Lemma StronglySorted_rec :
    forall P:list A -> Type,
      P [] ->
      (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) ->
      forall l, StronglySorted l -> P l.
  Proof.
    firstorder using StronglySorted_rect.
  Qed.

  Lemma StronglySorted_Sorted : forall l, StronglySorted l -> Sorted l.
  Proof.
    induction 1 as [|? ? ? ? HForall]; constructor; trivial.
    destruct HForall; constructor; trivial.
  Qed.

  Lemma Sorted_extends :
    Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l.
  Proof.
    intros. change match a :: l with [] => True | a :: l => Forall (R a) l end.
    induction H0 as [|? ? ? ? H1]; [trivial|].
    destruct H1; constructor; trivial.
    eapply Forall_impl; [|eassumption].
    firstorder.
  Qed.

  Lemma Sorted_StronglySorted :
    Transitive R -> forall l, Sorted l -> StronglySorted l.
  Proof.
    induction 2; constructor; trivial.
    apply Sorted_extends; trivial.
    constructor; trivial.
  Qed.

End defs.

Hint Constructors HdRel.
Hint Constructors Sorted.

(* begin hide *)
(* Compatibility with deprecated file Sorting.v *)
Notation lelistA := HdRel (only parsing).
Notation nil_leA := HdRel_nil (only parsing).
Notation cons_leA := HdRel_cons (only parsing).

Notation sort := Sorted (only parsing).
Notation nil_sort := Sorted_nil (only parsing).
Notation cons_sort := Sorted_cons (only parsing).

Notation lelistA_inv := HdRel_inv (only parsing).
Notation sort_inv := Sorted_inv (only parsing).
Notation sort_rect := Sorted_rect (only parsing).
(* end hide *)


Require Import Coq.Classes.SetoidClass.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.
Require Import NatList.
Require Import MyInductions.
Require Setoid.
(*Require PeanoNat Le Gt Minus Bool Lt.*)
Require Init.Datatypes.
Require Import PartialMap.

Open Scope list_scope.

Module ProgrammingWithPropositions.

Fixpoint myeq_nat n m  :=
  match n, m with
    | O, O => true
    | O, S _ => false
    | S _, O => false
    | S n1, S m1 => myeq_nat n1 m1
  end.

Fixpoint In {A : Type} (x : A) (l : PartialMap.list A)  :=
  match l with
  | PartialMap.nil => False
  | (PartialMap.cons x' l') => (x' = x) \/ (In x l')
  end.

Definition l := (PartialMap.cons 2 (PartialMap.cons 4 PartialMap.nil)).

Example In_Example_1 : In 4 l.
Proof.
  simpl.
  right.
  left.
  reflexivity.
Qed.

Check l.

Example In_example_2 : forall n, In n l -> exists n', n = 2* n'.
Proof.
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : PartialMap.list A) ( x : A),
    In x l -> In (f x) (PartialMap.map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  - simpl. intros. assumption.
  - simpl. intros [H | H].
    + rewrite H. left. reflexivity.
    + right. apply IHl'. apply H.
Qed.

Lemma In_map_iff : forall (A B : Type) ( f : A -> B) (l : PartialMap.list A) (y : B),
    In y (PartialMap.map f l) <-> exists x, f x = y /\ In x l.
Proof.
  intros.


(**
プログラミング Coq 証明駆動開発入門(1)
http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt8.html

をSSReflectに書き直した。
Permutation は SSReflect の相当の補題を使っているため、
証明の詳細は原著と異なることに注意してください。
*)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Print All.

(* Permutation, seq.v *)
Check perm_eq (1::2::3::nil) (2::1::3::nil).
Eval compute in perm_eq (1::2::3::nil) (2::1::3::nil). (* true *)
Eval compute in perm_eq nil nil.                       (* true *)

(* ソート処理の定義 *)
Fixpoint insert (a : nat)(l : seq nat) : seq nat :=
  match l with
  | nil => a :: nil
  | x :: xs => if leq a x then a :: l else x :: insert a xs
  end.

Fixpoint insertion_sort (l : seq nat) : seq nat :=
  match l with
  | nil => nil
  | x :: xs => insert x (insertion_sort xs)
  end.

Eval compute in insert 1 nil.                      (* [:: 1] *)
Eval compute in insert 5 [:: 1; 4; 2; 9; 3].       (* [:: 1; 4; 2; 5; 9; 3] *)
Eval compute in insertion_sort [:: 2; 4; 1; 5; 3]. (* [:: 1; 2; 3; 4; 5] *)

(* 証明 *)
Lemma perm_iff : forall (m n : seq nat),
                   (forall l, perm_eq m l = perm_eq n l) <-> perm_eq m n.
Proof.
  move=> m n.
  split=> H.
  - by rewrite H.
  - by apply/perm_eqlP.
Qed.

Lemma perm_swap : forall (l l' : seq nat) (x a : nat),
                    perm_eq [:: x, a & l] l' = perm_eq [:: a, x & l] l'.
Proof.
  move=> l l' x a.
  apply perm_iff.
  Check cat1s.
  rewrite -[[:: x, a & l]]cat1s.
  rewrite -[[:: a & l]]cat1s.
  rewrite -[[:: a, x & l]]cat1s.
  rewrite -[[:: x & l]]cat1s.
  apply/perm_eqlP.
  by apply (perm_catCA [:: x] [:: a] l).
Qed.

Lemma insert_perm : forall (l : seq nat) (x : nat),
                      perm_eq (x::l) (insert x l).
Proof.
  elim=> [x | a l H x //=].
  - by [].
  - case: (x <= a) => [//= |].
    + apply perm_iff => l'.
      rewrite perm_swap.
      apply perm_iff.
      rewrite perm_cons.
      by [].
Qed.

Theorem isort_permutation : forall (l : seq nat), perm_eq l (insertion_sort l).
Proof.
  elim=> [| a l H //=].
  - by [].
  - apply perm_eq_trans with (a :: insertion_sort l).
    + by rewrite perm_cons.
    + by apply insert_perm.
Qed.

(*
Require Import path.

(* Sorted, path.v *)
Check sorted : forall T : eqType, rel T -> seq T -> bool.
Check leq : nat -> nat -> bool.
Check leq : nat -> nat -> Prop.
Check leq : rel nat : Type.
Check le : nat -> nat -> Prop.
Fail Check le : nat -> nat -> bool.
Fail Check le : rel nat.                    (* rel : Type -> Type *)

Check sorted ltn (1::2::3::nil).
Check sorted leq (1::2::3::nil).
Eval compute in sorted leq (1::2::3::nil). (* true *)
Eval compute in sorted leq (3::nil).       (* true *)
Eval compute in sorted leq nil.            (* true *)
Eval compute in sorted leq (2::1::3::nil). (* false *)
*)

Inductive LocallySorted (T : eqType) (R : rel T) : seq T -> Prop :=
| LSorted_nil : LocallySorted R nil
| LSorted_cons1 : forall a : T, LocallySorted R (a :: nil)
| LSorted_consn : forall (a b : T) (l : seq T),
                    LocallySorted R (b :: l) ->
                    R a b -> LocallySorted R (a :: b :: l).

Check leq : nat -> nat -> bool.
Check leq : nat -> nat -> Prop.
Check leq : rel nat : Type.
Check le : nat -> nat -> Prop.
Fail Check le : nat -> nat -> bool.
Fail Check le : rel nat.                    (* rel : Type -> Type *)
Check LocallySorted leq (1::2::3::nil) : Prop.
Fail Check LocallySorted le (1::2::3::nil) : Prop.

Lemma complete_conv : forall n m : nat, leq m n = false -> leq n m.
Proof.
  move=> n m.
  move/negbT.
  rewrite -ltnNge => H.
  by apply ltnW.
Qed.

Lemma insert_sorted : forall (a : nat) (l : seq nat),
                        LocallySorted leq l -> LocallySorted leq (insert a l).
Proof.
  move=> a.
  elim=> [H //= | a0 l IHl H //=].
  - by apply LSorted_cons1.
  - case Heqb : (leq a a0).                 (* remember *)
    + apply LSorted_consn.
      * by apply H.
      * by rewrite Heqb.
    + inversion H.
      * apply LSorted_consn.
        apply LSorted_cons1.
        by apply complete_conv.
      * subst; simpl in *.
        case H' : (leq a b).
        - apply LSorted_consn.
          + by rewrite H' in IHl; apply IHl. (* apply H2. *)
          + by apply complete_conv.
        - apply LSorted_consn.
          + by rewrite H' in IHl; apply IHl. (* apply H2. *)
          + by [].                           (* apply H3. *)
Qed.

Theorem isort_sorted : forall (l : seq nat),
                         LocallySorted leq (insertion_sort l).
Proof.
  elim=> [| a l H //=].
  - by apply LSorted_nil.
  - by apply insert_sorted.
Qed.

(* END *)


(** Support for atoms, i.e., objects with decidable equality.  We
    provide here the ability to generate an atom fresh for any finite
    collection, i.e., the lemma [atom_fresh_for_set].

    Original authors: Arthur Chargueraud and Brian Aydemir.
*)

Require Import List.
Require Import Max.
Require Import Le.
Require Peano_dec.

(* ********************************************************************** *)
(** * Definition *)

(** Atoms are structureless objects such that we can always generate
    one fresh from a finite collection.  Equality on atoms is [eq] and
    decidable.  We use Coq's module system to make abstract the
    implementation of atoms.  The [Export AtomImpl] line below allows
    us to refer to the type [atom] and its properties without having
    to qualify everything with "[AtomImpl.]". *)

Module Type ATOM.

  Parameter atom : Set.

  Parameter atom_fresh_for_list :
    forall (xs : list atom), {x : atom | ~ List.In x xs}.

  Parameter eq_atom_dec : forall x y : atom, {x = y} + {x <> y}.

End ATOM.

(** The implementation of the above interface is hidden for
    documentation purposes. *)

Module AtomImpl : ATOM.

  (* begin hide *)

  Definition atom := nat.

  Lemma max_lt_r : forall x y z,
    x <= z -> x <= max y z.
  Proof.
    intros. apply le_trans with (1:=H). apply le_max_r.
  Qed.

  Lemma nat_list_max : forall (xs : list nat),
    { n : nat | forall x, In x xs -> x <= n }.
  Proof.
    induction xs as [ | x xs [y H] ].
    (* case: nil *)
    exists 0. inversion 1.
    (* case: cons x xs *)
    exists (max x y). intros z J. simpl in J. destruct J as [K | K].
      subst. apply le_max_l.
      apply max_lt_r. auto.
  Qed.

  Lemma atom_fresh_for_list :
    forall (xs : list nat), { n : nat | ~ List.In n xs }.
  Proof.
    intros xs. destruct (nat_list_max xs) as [x H].
    exists (S x). intros J. specialize (H (S x) J).
    apply n_Sn with (n:=x).
    apply le_antisym. apply le_n_Sn. assumption.
  Qed.

  Definition eq_atom_dec := Peano_dec.eq_nat_dec.

  (* end hide *)

End AtomImpl.

Export AtomImpl.


Load FJ_tactics.
Require Import List.
Require Import FunctionalExtensionality.

Section Folds.

  (* ============================================== *)
  (* ALGEBRAS AND FOLDS                             *)
  (* ============================================== *)

  (* Ordinary Algebra *)
  Definition Algebra (F: Set -> Set) (A : Set) :=
    F A -> A.

  (* Mixin Algebra *)
  Definition Mixin (T: Set) (F: Set -> Set) (A : Set) :=
    (T -> A) -> F T -> A.

  (* Mendler Algebra *)
  Definition MAlgebra (F: Set -> Set) (A : Set) :=
    forall (R : Set), Mixin R F A.

   Definition Fix (F : Set -> Set) : Set :=
    forall (A : Set), MAlgebra F A -> A.

  Definition mfold {F : Set -> Set} : forall {A : Set}
    (f : MAlgebra F A), Fix F -> A:= fun A f e => e A f.

  Class Functor (F : Set -> Set) :=
    {fmap :
      forall {A B : Set} (f : A -> B), F A -> F B;
      fmap_fusion :
        forall (A B C: Set) (f : A -> B) (g : B -> C) (a : F A),
          fmap g (fmap f a) = fmap (fun e => g (f e)) a;
      fmap_id :
        forall (A : Set) (a : F A),
          fmap (@id A) a = a
    }.

  Definition in_t {F} : F (Fix F) -> Fix F :=
    fun F_e A f => f _ (mfold _ f) F_e.

  Definition fold_ {F : Set -> Set} {functor : Functor F} :
    forall (A : Set) (f : Algebra F A), Fix F -> A :=
      fun A f e => mfold _ (fun r rec fa => f (fmap rec fa)) e.

  Definition out_t {F : Set -> Set} {fun_F : Functor F} : Fix F -> F (Fix F) :=
    @fold_ F fun_F _ (fmap in_t).

  Fixpoint boundedFix {A: Set}
    {Exp: Set -> Set}
    {fun_F: Functor Exp}
    (n : nat)
    (fM: Mixin (Fix Exp) Exp A)
    (default: A)
    (e: Fix Exp): A :=
    match n with
      | 0   => default
      | S n => fM (boundedFix n fM default) (out_t e)
    end.

    (* Indexed Algebra *)
  Definition iAlgebra {I : Set} (F : (I -> Prop) -> I -> Prop) (A : I -> Prop) :=
    forall i, F A i -> A i.

    (* Indexed Mendler Algebra *)
  Definition iMAlgebra {I : Set} (F : (I -> Prop) -> I -> Prop) (A : I -> Prop) :=
    forall i (R : I -> Prop), (forall i, R i -> A i) -> F R i -> A i.

  Definition iFix {I : Set} (F : (I -> Prop) -> I -> Prop) (i : I) : Prop :=
    forall (A : I -> Prop), iMAlgebra F A -> A i.

  Definition imfold {I : Set} (F : (I -> Prop) -> I -> Prop) :
    forall {A : I -> Prop} (f : iMAlgebra F A) {i : I},
      iFix F i -> A i := fun A f i e => e A f.

  Class iFunctor {I : Set} (F : (I -> Prop) -> I -> Prop) :=
    {ifmap :
      forall {A B : I -> Prop} i (f : forall i, A i -> B i), F A i -> F B i;
      ifmap_fusion :
        forall (A B C: I -> Prop) i (f : forall i, A i -> B i) (g : forall i, B i -> C i) (a : F A i),
          ifmap i g (ifmap i f a) = ifmap i (fun i e => g _ (f i e)) a;
      ifmap_id :
        forall (A : I -> Prop) i (a : F A i),
          ifmap i (fun _ => id) a = a
    }.

  Definition in_ti {I : Set} {F} : forall i : I, F (iFix F) i -> iFix F i :=
    fun i F_e A f => f _ _ (imfold _ _ f) F_e.

  Definition ifold_ {I : Set} (F : (I -> Prop) -> I -> Prop) {iFun_F : iFunctor F} :
    forall {A : I -> Prop} (f : iAlgebra F A) {i : I},
      iFix F i -> A i := fun A f i e => imfold _ _ (fun i' r rec fa => f i' (ifmap i' rec fa)) i e.

  Definition out_ti {I : Set} {F} {fun_F : iFunctor F} : forall i : I, iFix F i -> F (iFix F) i :=
    @ifold_ I F fun_F _ (fun i => ifmap i in_ti).

  (* Universal Property of Mendler Folds *)

  Lemma Universal_Property (F : Set -> Set) (A : Set)
    (f : MAlgebra F A) :
      forall (h : Fix F -> A),
        h = mfold _ f -> forall e, h (in_t e) = f _ h e.
  Proof.
    intros; rewrite H. unfold in_t. unfold mfold.
    reflexivity.
  Qed.

  Class Universal_Property' {F} {Fun_F : Functor F} (e : Fix F) :=
    {E_UP' : forall (A : Set) (f : MAlgebra F A)
      (h : Fix F -> A),
      (forall e, h (in_t e) = f _ h e) ->
      h e = mfold _ f e}.

  Lemma Fix_id F {fun_F : Functor F} e {UP' : Universal_Property' e} :
    mfold _ (fun _ rec x => in_t (fmap rec x)) e = e.
  Proof.
    intros; apply sym_eq.
    fold (id e); unfold id at 2; apply (E_UP'); intros.
    unfold id.
    unfold in_t.
    eapply (@functional_extensionality_dep Set).
    intros; eapply @functional_extensionality_dep; intros.
    rewrite fmap_id.
    reflexivity.
  Defined.

  Definition MAlg_to_Alg {F : Set -> Set} {A : Set} :
    MAlgebra F A -> Algebra F A := fun MAlg f => MAlg A id f.

  (* Universal Property of regular folds. *)

  Lemma Universal_Property_fold (F : Set -> Set) {fun_F : Functor F} (B : Set)
    (f : Algebra F B) : forall (h : Fix F -> B), h = fold_ _ f ->
      forall e, h (in_t e) = f (fmap h e).
    intros; rewrite H; reflexivity.
  Qed.

  Class Universal_Property'_fold {F} {fun_F : Functor F} (e : Fix F) :=
    {E_fUP' : forall (B : Set) (f : Algebra F B) (h : Fix F -> B),
      (forall e, h (in_t e) = f (fmap h e)) ->
      h e = fold_ _ f e
    }.

  Lemma Fix_id_fold F {fun_F : Functor F} e {UP' : Universal_Property'_fold e} :
    fold_ _ (@in_t F) e = e.
    intros; apply sym_eq.
    fold (id e); unfold id at 2; apply (E_fUP'); intros.
    rewrite fmap_id.
    unfold id.
    reflexivity.
  Qed.

  Lemma Fusion F {fun_F : Functor F} e {e_UP' : Universal_Property'_fold e} :
    forall (A B : Set) (h : A -> B) (f : Algebra F A) (g : Algebra F B),
      (forall a, h (f a) = g (fmap h a)) ->
      (fun e' => h (fold_ _ f e')) e = fold_ _ g e.
    intros; eapply E_fUP'; try eassumption; intros.
    rewrite (Universal_Property_fold F _ f _ (refl_equal _)).
    rewrite H.
    rewrite fmap_fusion; reflexivity.
  Qed.

  Lemma in_out_inverse : forall (F : Set -> Set) (Fun_F : Functor F) (e : Fix F)
    {fUP' : Universal_Property'_fold e},
    in_t (out_t e) = e.
    intros.
    rewrite <- (@Fix_id_fold _ _ e fUP') at -1.
    eapply E_fUP' with (h := fun e => in_t (out_t e)).
    intro.
    cut (out_t (in_t e0) = fmap (fun e1 => in_t (out_t e1)) e0); intros.
    rewrite H; reflexivity.
    unfold out_t.
    rewrite Universal_Property with (f := (fun (R : Set) (rec : R -> F (Fix F)) (fp : F R) =>
      fmap (fun r : R => in_t (rec r)) fp)); eauto.
    unfold fold_; unfold mfold.
    eapply functional_extensionality; intro.
    cut ((fun (r : Set) (rec : r -> F (Fix F)) (fa : F r) =>
      fmap in_t (fmap rec fa)) =
      fun (R : Set) (rec : R -> F (Fix F)) (fp : F R) =>
      fmap (fun r : R => in_t (rec r)) fp).
    intro; rewrite H; reflexivity.
    eapply (@functional_extensionality_dep Set); intro.
    eapply functional_extensionality_dep; intro.
    eapply functional_extensionality_dep; intro.
    rewrite fmap_fusion; reflexivity.
  Qed.

  Definition in_t_UP' : forall (F : Set -> Set)
    (Fun_F : Functor F),
    F (sig (@Universal_Property'_fold F Fun_F)) ->
    sig (@Universal_Property'_fold F Fun_F).
    intros F Fun_F e.
    intros; constructor 1 with (x := in_t (fmap (@proj1_sig _ _) e)).
    constructor; intros.
    rewrite H.
    unfold fold_, mfold.
    unfold in_t.
    repeat rewrite fmap_fusion.
    assert ((fun e0 : sig Universal_Property'_fold => h (proj1_sig e0)) =
      (fun e0 : sig Universal_Property'_fold =>
         mfold B (fun (r : Set) (rec : r -> B) (fa : F r) => f (fmap rec fa))
           (proj1_sig e0))) by
    (eapply @functional_extensionality_dep; intros e'; destruct e' as [e' e'_UP'];
      simpl; eapply E_fUP'; eauto).
    rewrite H0; reflexivity.
  Defined.

  Definition out_t_UP' :
    forall (F : Set -> Set)
      (Fun_F : Functor F)
      (e : Fix F),
      F (sig (@Universal_Property'_fold F Fun_F)).
    intros.
    eapply fold_; try assumption.
    unfold Algebra; intros.
    eapply fmap.
    apply in_t_UP'.
    assumption.
  Defined.

  Lemma out_in_inverse : forall (F : Set -> Set)
    (Fun_F : Functor F)
    (e : F (sig (@Universal_Property'_fold F Fun_F))),
    out_t (in_t (fmap (@proj1_sig _ _) e)) = fmap (@proj1_sig _ _) e.
    intros.
    unfold out_t.
    erewrite Universal_Property_fold; try reflexivity.
    rewrite fmap_fusion.
    rewrite fmap_fusion.
    assert ((fun e0 : sig Universal_Property'_fold =>
      in_t (fold_ (F (Fix F)) (fmap in_t) (proj1_sig e0))) =
    @proj1_sig _ _) by
    (eapply functional_extensionality; intros;
      fold (out_t (proj1_sig x));
        rewrite in_out_inverse; destruct x; simpl; eauto).
    rewrite H; reflexivity.
  Qed.

  Lemma in_t_UP'_inject : forall (F : Set -> Set)
    (Fun_F : Functor F)
    (e e' : F (sig (@Universal_Property'_fold F Fun_F))),
    in_t (fmap (@proj1_sig _ _) e) = in_t (fmap (@proj1_sig _ _) e') ->
    fmap (@proj1_sig _ _) e = fmap (@proj1_sig _ _) e'.
    intros; apply (f_equal out_t) in H;
      repeat rewrite out_in_inverse in H; eauto.
  Qed.

  Lemma in_out_UP'_inverse : forall (H : Set -> Set)
    (Fun_H : Functor H)
    (h : Fix H),
    Universal_Property'_fold h ->
    proj1_sig (in_t_UP' H Fun_H (out_t_UP' H Fun_H h)) = h.
    intros; simpl.
    assert ((fmap (@proj1_sig _ _) (out_t_UP' H Fun_H h)) = out_t h).
    unfold out_t.
    eapply E_fUP' with (h0 := fun e => fmap (@proj1_sig _ _) (out_t_UP' H Fun_H e)).
    intros.
    rewrite fmap_fusion.
    assert (out_t_UP' H Fun_H (in_t e) =
      fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e).
    unfold out_t_UP' at 1.
    erewrite Universal_Property_fold with
      (f := (fun H2 : H (H (sig Universal_Property'_fold)) =>
        fmap (in_t_UP' H Fun_H) H2)) (fun_F := Fun_H); eauto.
    rewrite fmap_fusion; reflexivity.
    rewrite H1; rewrite fmap_fusion; simpl; reflexivity.
    rewrite H1.
    rewrite in_out_inverse; unfold mfold; eauto.
  Qed.

  Lemma out_in_fmap : forall (F : Set -> Set)
    (Fun_F : Functor F)
    (e : F (Fix F)),
    out_t_UP' F _ (in_t e) =
    fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e.
    intros; unfold out_t_UP' at 1.
    erewrite Universal_Property_fold with
    (f := (fun H2 : F (F (sig Universal_Property'_fold)) =>
      fmap (in_t_UP' F Fun_F) H2)) (fun_F := Fun_F); eauto.
    rewrite fmap_fusion; reflexivity.
  Qed.

  Definition UP'_P {F : Set -> Set} {Fun_F : Functor F}
    (P : forall e : Fix F, Universal_Property'_fold e -> Prop) (e : Fix F) :=
    sigT (P e).

  Definition UP'_P2 {F F' : Set -> Set}
    {Fun_F : Functor F} {Fun_F' : Functor F'}
    (P : forall e : (Fix F) * (Fix F'),
      Universal_Property'_fold (fst e) /\ Universal_Property'_fold (snd e) -> Prop)
    (e : (Fix F) * (Fix F')) := sig (P e).

  Definition UP'_F (F : Set -> Set) {Fun_F : Functor F} :=
    sig (Universal_Property'_fold (F := F)).

  Fixpoint boundedFix_UP {A: Set}
    {Exp: Set -> Set}
    {fun_F: Functor Exp}
    (n : nat)
    (fM: Mixin (UP'_F Exp) Exp A)
    (default: A)
    (e: UP'_F Exp): A :=
    match n with
      | 0   => default
      | S n => fM (boundedFix_UP n fM default) (out_t_UP' _ _ (proj1_sig e))
    end.

  Lemma bF_UP_in_out : forall {A: Set}
    {Exp: Set -> Set}
    {fun_F: Functor Exp}
    (n : nat)
    (fM: Mixin (UP'_F Exp) Exp A)
    (default: A)
    (e: Fix Exp)
    (e_UP' : Universal_Property'_fold e),
    boundedFix_UP n fM default (in_t_UP' _ _ (out_t_UP' _ _ e)) =
    boundedFix_UP n fM default (exist _ e e_UP').
  Proof.
    induction n; simpl; intros; eauto.
    generalize in_out_UP'_inverse as H0; intro; simpl in H0; rewrite H0; auto.
  Qed.

  (* ============================================== *)
  (* FUNCTOR COMPOSITION                            *)
  (* ============================================== *)

  Definition inj_Functor {F G : Set -> Set} {A : Set} : Set := sum (F A) (G A).

  Notation "A :+: B"  := (@inj_Functor A B) (at level 80, right associativity).

  Global Instance Functor_Plus G H {fun_G : Functor G} {fun_H : Functor H} : Functor (G :+: H).
    econstructor 1 with (fmap :=
      fun (A B : Set) (f : A -> B) (a : (G :+: H) A) =>
        match a with
          | inl G' => inl _ (fmap f G')
          | inr H' => inr _ (fmap f H')
        end).
    (* fmap_fusion *)
    intros; destruct a;
    rewrite fmap_fusion; reflexivity.
    (* fmap_id *)
    intros; destruct a;
    rewrite fmap_id; reflexivity.
  Defined.

  Class Sub_Functor (sub_F sub_G : Set -> Set) : Set :=
    { inj : forall {A : Set}, sub_F A -> sub_G A;
      prj : forall {A : Set}, sub_G A -> option (sub_F A);
      inj_prj : forall {A : Set} (ga : sub_G A) (fa : sub_F A),
        prj ga = Some fa -> ga = inj fa;
      prj_inj : forall {A : Set} (fa : sub_F A),
        prj (inj fa) = Some fa
    }.

  Notation "A :<: B"  := (Sub_Functor A B) (at level 80, right associativity).

  (* Need the 'Global' modifier so that the instance survives the Section.*)
  Global Instance Sub_Functor_inl (F G H : Set -> Set) (sub_F_G : F :<: G) :
    F :<: (G :+: H) :=
    {| inj :=  (fun (A : Set) (e : F A) => inl _ (@inj F G sub_F_G _ e));
       prj := fun (A: Set) (e : (G :+: H) A) =>
        match e with
         | inl e' => prj e'
         | inr _  => None
        end
     |}.
    intros; destruct ga; [rewrite (inj_prj _ _ H0); reflexivity | discriminate].
    intros; simpl; rewrite prj_inj; reflexivity.
  Defined.

  Global Instance Sub_Functor_inr (F G H : Set -> Set) (sub_F_H : F :<: H) :
    F :<: (G :+: H) :=
    {| inj := fun (A : Set) (e : F A) => inr _ (@inj F H sub_F_H _ e);
       prj := fun (A : Set) (e : (G :+: H) A) =>
        match e with
         | inl _  => None
         | inr e' => prj e'
        end
     |}.
    intros; destruct ga; [discriminate | rewrite (inj_prj _ _ H0); reflexivity ].
    intros; simpl; rewrite prj_inj; reflexivity.
  Defined.

  Global Instance Sub_Functor_id {F : Set -> Set} : F :<: F :=
    {| inj := fun A => @id (F A);
       prj := fun A => @Some (F A) |}.
    unfold id; congruence.
    reflexivity.
  Defined.

  (* ============================================== *)
  (* WELL-FORMEDNESS OF FUNCTORS                    *)
  (* ============================================== *)

  Class WF_Functor (F G: Set -> Set)
    (subfg: F :<: G)
    (Fun_F: Functor F)
    (Fun_G: Functor G): Set :=
    { wf_functor :
      forall (A B : Set) (f : A -> B) (fa: F A) ,
        fmap f (inj fa) (F := G) = inj (fmap f fa) }.

  Global Instance WF_Functor_id {F : Set -> Set} {Fun_F : Functor F} :
    WF_Functor F F Sub_Functor_id _ _.
    econstructor; intros; reflexivity.
  Defined.

  Global Instance WF_Functor_plus_inl {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {subfg : F :<: G}
    {WF_Fun_F : WF_Functor F _ subfg Fun_F Fun_G}
    :
    WF_Functor F (G :+: H) (Sub_Functor_inl F G H _ ) _ (Functor_Plus G H).
    econstructor; intros.
    simpl; rewrite wf_functor; reflexivity.
  Defined.

  Global Instance WF_Functor_plus_inr {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {subfh : F :<: H}
    {WF_Fun_F : WF_Functor F _ subfh Fun_F Fun_H}
    :
    WF_Functor F (G :+: H) (Sub_Functor_inr F G H _ ) _ (Functor_Plus G H).
    econstructor; intros.
    simpl; rewrite wf_functor; reflexivity.
  Defined.

  (* ============================================== *)
  (* INJECTION + PROJECTION                         *)
  (* ============================================== *)

  Definition inject' {F G: Set -> Set} {Fun_F : Functor F} {subGF: G :<: F} :
    G (sig (@Universal_Property'_fold F Fun_F)) -> (sig (@Universal_Property'_fold F Fun_F)) :=
    fun gexp => in_t_UP' _ _ (inj gexp).

  Definition inject {F G: Set -> Set} {Fun_F : Functor F} {subGF: G :<: F} :
    G (sig (@Universal_Property'_fold F Fun_F)) -> Fix F :=
      fun gexp => proj1_sig (in_t_UP' _ _ (inj gexp)).

  Definition project {F G: Set -> Set} {Fun_F: Functor F} {subGF : G :<: F } :
    Fix F -> option (G (sig (@Universal_Property'_fold F Fun_F))) :=
      fun exp => prj (out_t_UP' _ _ exp).

  Lemma project_inject : forall (G H : Set -> Set)
    (Fun_G : Functor G)
    (Fun_H : Functor H)
    (sub_G_H : G :<: H)
    (h : Fix H) (g : G (sig (@Universal_Property'_fold H Fun_H))),
    Universal_Property'_fold h ->
    project h = Some g -> h = inject g.
    intros.
    apply inj_prj in H1.
    unfold inject; rewrite <- H1.
    erewrite in_out_UP'_inverse; eauto.
  Qed.

  Lemma inject_project : forall (F G  : Set -> Set)
    (Fun_F : Functor F)
    (Fun_G : Functor G)
    (sub_G_F : G :<: F)
    (g : G (sig (@Universal_Property'_fold F Fun_F))),
    fmap (@proj1_sig _ _) (out_t_UP' _ _ (inject g)) =
    (fmap (@proj1_sig _ _) (inj g)).
    unfold inject; intros; simpl.
    rewrite out_in_fmap.
    rewrite fmap_fusion.
    assert (forall e : sig Universal_Property'_fold,
      proj1_sig (in_t_UP' F Fun_F (out_t_UP' F Fun_F (proj1_sig e))) = proj1_sig e).
    intros; eapply in_out_UP'_inverse.
    intros; destruct e as [e e_UP']; eassumption.
    rewrite fmap_fusion.
    rewrite (functional_extensionality _ _ H).
    reflexivity.
  Qed.

  Class Distinct_Sub_Functor {F G H : Set -> Set}
    (Fun_H : Functor H)
    (sub_F_H : F :<: H)
    (sub_G_H : G :<: H)
    : Set :=
    {inj_discriminate : forall A f g,
      inj (Sub_Functor := sub_F_H) (A := A) f <> inj (Sub_Functor := sub_G_H) (A := A) g}.

  Global Instance Distinct_Sub_Functor_plus
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_I : H :<: I)
    :
    @Distinct_Sub_Functor F H (G :+: I) _ _ _.
    econstructor; intros.
    unfold not; simpl; unfold id; intros.
    discriminate.
  Defined.

  Global Instance Distinct_Sub_Functor_plus'
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_I : H :<: I)
    :
    @Distinct_Sub_Functor F H (I :+: G) _ _ _.
    econstructor; intros.
    unfold not; simpl; unfold id; intros.
    discriminate.
  Defined.

  Global Instance Distinct_Sub_Functor_inl
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_G : H :<: G)
    (Dist_inl : @Distinct_Sub_Functor F H G Fun_G sub_F_G sub_H_G)
    :
    @Distinct_Sub_Functor F H (G :+: I) _ _ _.
    econstructor; intros.
    unfold not; intros.
    simpl in H0; injection H0; intros.
    eapply (inj_discriminate (Distinct_Sub_Functor := Dist_inl) _ f g H1).
  Defined.

  Global Instance Distinct_Sub_Functor_inr
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_G : H :<: G)
    (Dist_inl : @Distinct_Sub_Functor F H G Fun_G sub_F_G sub_H_G)
    :
    @Distinct_Sub_Functor F H (I :+: G) _ _ _.
    econstructor; intros.
    unfold not; intros.
    simpl in H0; injection H0; intros.
    eapply (inj_discriminate (Distinct_Sub_Functor := Dist_inl) _ f g H1).
  Defined.

  Lemma inject_discriminate : forall {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {sub_F_H : F :<: H}
    {sub_G_H : G :<: H}
    {WF_F : WF_Functor _ _ sub_F_H Fun_F Fun_H}
    {WF_G : WF_Functor _ _ sub_G_H Fun_G Fun_H},
    Distinct_Sub_Functor Fun_H sub_F_H sub_G_H ->
    forall f g, inject (subGF := sub_F_H) f <> inject (subGF := sub_G_H) g.
    unfold inject; simpl; intros.
    unfold not; intros H3; apply in_t_UP'_inject in H3.
    repeat rewrite wf_functor in H3.
    eapply (inj_discriminate _ _ _ H3).
  Qed.

  (* ============================================== *)
  (* INDEXED FUNCTOR COMPOSITION                    *)
  (* ============================================== *)

  Definition inj_iFunctor {I : Set} {F G : (I -> Prop) -> I -> Prop} {A : I -> Prop} : I -> Prop :=
    fun i => or (F A i) (G A i).

  Notation "A ::+:: B"  := (@inj_iFunctor _ A B) (at level 80, right associativity).

  Global Instance iFunctor_Plus {I : Set} (G H : (I -> Prop) -> I -> Prop)
    {fun_G : iFunctor G} {fun_H : iFunctor H} : iFunctor (G ::+:: H).
    econstructor 1 with (ifmap :=
      fun (A B : I -> Prop) (i : I) (f : forall i, A i -> B i) (a : (G ::+:: H) A i) =>
        match a with
          | or_introl G' => or_introl _ (ifmap i f G')
          | or_intror H' => or_intror _ (ifmap i f H')
        end).
    (* ifmap_fusion *)
    intros; destruct a;
    rewrite ifmap_fusion; reflexivity.
    (* ifmap_id *)
    intros; destruct a;
    rewrite ifmap_id; reflexivity.
  Defined.

  Class Sub_iFunctor {I : Set} (sub_F sub_G : (I -> Prop) -> I -> Prop) : Prop :=
    { inj_i : forall {A : I -> Prop} i, sub_F A i -> sub_G A i;
         prj_i : forall {A : I -> Prop} i, sub_G A i -> (sub_F A i) \/ True
    }.

  Notation "A ::<:: B"  := (Sub_iFunctor A B) (at level 80, right associativity).

  (* Need the 'Global' modifier so that the instance survives the Section.*)

  Global Instance Sub_iFunctor_inl {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (sub_F_G : F ::<:: G) :
    F ::<:: (G ::+:: H) :=
    {| inj_i :=  (fun (A : I' -> Prop) i (e : F A i) =>
      or_introl _ (@inj_i _ F G sub_F_G _ _ e));
    prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) =>
      match e with
        | or_introl e' => prj_i _ e'
        | or_intror _  => or_intror _ I
      end
    |}.

  Global Instance Sub_iFunctor_inr {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (sub_F_H : F ::<:: H) :
    F ::<:: (G ::+:: H) :=
    {| inj_i :=  (fun (A : I' -> Prop) i (e : F A i) =>
      or_intror _ (@inj_i _ F H sub_F_H _ _ e));
    prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) =>
      match e with
        | or_intror e' => prj_i _ e'
        | or_introl _  => or_intror _ I
      end
    |}.

  Global Instance Sub_iFunctor_id {I : Set} {F : (I -> Prop) -> I -> Prop} : F ::<:: F :=
    {| inj_i := fun A i e => e;
       prj_i := fun A i e => or_introl _ e |}.

  Definition inject_i {I : Set} {F G: (I -> Prop) -> I -> Prop} {subGF: Sub_iFunctor G F} :
    forall i, G (iFix F) i -> iFix F i:=
    fun i gexp => in_ti i (inj_i i gexp).

  Definition project_i {I : Set} {F G: (I -> Prop) -> I -> Prop}
    {fun_F: iFunctor F}
    {subGF: Sub_iFunctor G F} :
    forall i, iFix F i -> (G (iFix F) i) \/ True :=
      fun i fexp => prj_i i (out_ti i fexp).

End Folds.

Notation "A :+: B"  := (@inj_Functor A B) (at level 80, right associativity).
Notation "A :<: B"  := (Sub_Functor A B) (at level 80, right associativity).
Notation "A ::+:: B"  := (@inj_iFunctor _ A B) (at level 80, right associativity).
Notation "A ::<:: B"  := (Sub_iFunctor _ A B) (at level 80, right associativity).

Definition inj'' {F G : Set -> Set} (sub_F_G: F :<: G) {A : Set} := @inj F G sub_F_G A.

Section FAlgebra.

  (* ============================================== *)
  (* OPERATIONS INFRASTRUCTURE                      *)
  (* ============================================== *)

  Class FAlgebra (Name : Set) (T: Set) (A: Set) (F: Set -> Set) : Set :=
    { f_algebra : Mixin T F A }.

  (* Definition FAlgebra_Plus (Name: Set) (T: Set) (A : Set) (F G : Set -> Set)
    {falg: FAlgebra Name T A F} {galg: FAlgebra Name T A G} :
    FAlgebra Name T A (F :+: G) :=
    Build_FAlgebra Name T A _
    (fun f fga =>
      (match fga with
         | inl fa => f_algebra f fa
         | inr ga => f_algebra f ga
       end)). *)

  Global Instance FAlgebra_Plus (Name: Set) (T: Set) (A : Set) (F G : Set -> Set)
    {falg: FAlgebra Name T A F} {galg: FAlgebra Name T A G} :
    FAlgebra Name T A (F :+: G) | 6 :=
    {| f_algebra := fun f fga=>
         (match fga with
           | inl fa => f_algebra f fa
           | inr ga => f_algebra f ga
          end) |}.

  (* The | 6 gives the generated Hint a priority of 6. If this is
     less than that of other instances for FAlgebra, the
     typeclass inference algorithm will loop.
     *)

  Class WF_FAlgebra (Name T A: Set) (F G: Set -> Set)
    (subfg: F :<: G)
    (falg: FAlgebra Name T A F)
    (galg: FAlgebra Name T A G): Set :=
    { wf_algebra :
      forall rec (fa: F T),
        @f_algebra Name T A G galg rec (@inj F G subfg T fa) = @f_algebra Name T A F falg rec fa }.

  Global Instance WF_FAlgebra_id {Name T A : Set} {F} {falg: FAlgebra Name T A F}:
    WF_FAlgebra Name T A F F Sub_Functor_id falg falg.
      econstructor. intros.
      unfold inj.
      unfold Sub_Functor_id.
      unfold id.
      reflexivity.
  Defined.

  Global Instance WF_FAlgebra_inl
    {Name A T : Set}
    {F G H}
    {falg: FAlgebra Name T A F}
    {galg: FAlgebra Name T A G}
    {halg: FAlgebra Name T A H}
    {sub_F_G: F :<: G}
    {wf_F_G: WF_FAlgebra Name T A F G sub_F_G falg galg}
    :
    WF_FAlgebra Name T A F (G :+: H) (Sub_Functor_inl F G H sub_F_G) falg (@FAlgebra_Plus Name T A G H galg halg).
      econstructor. intros.
      unfold inj. unfold Sub_Functor_inl.
      simpl.
      rewrite (wf_algebra rec fa).
      reflexivity.
  Defined.

  Global Instance WF_FAlgebra_inr
    {Name T A : Set}
    {F G H}
    {falg: FAlgebra Name T A F}
    {galg: FAlgebra Name T A G}
    {halg: FAlgebra Name T A H}
    {sub_F_H: F :<: H}
    {wf_G_H: WF_FAlgebra Name T A F H sub_F_H falg halg}
    :
    WF_FAlgebra Name T A F (G :+: H) (Sub_Functor_inr F G H sub_F_H) falg (@FAlgebra_Plus Name T A G H galg halg).
      econstructor. intros.
      unfold inj.
      unfold Sub_Functor_inr.
      simpl.
      rewrite (wf_algebra rec fa).
      reflexivity.
    Defined.

End FAlgebra.

  (* ============================================== *)
  (* INDUCTION PRINCIPLES INFRASTRUCTURE            *)
  (* ============================================== *)

Section WF_Ind_FAlgebras.

  Class PAlgebra (Name : Set) (A: Set) (F: Set -> Set) : Set :=
    { p_algebra : Algebra F A}.

  (* Definition PAlgebra_Plus (Name: Set) (A : Set) (F G : Set -> Set)
    {falg: PAlgebra Name A F} {galg: PAlgebra Name A G} :
    PAlgebra Name A (F :+: G) :=
    Build_PAlgebra Name A _
    (fun fga =>
      (match fga with
         | inl fa => p_algebra fa
         | inr ga => p_algebra ga
       end)). *)

  Global Instance PAlgebra_Plus (Name: Set) (A : Set) (F G : Set -> Set)
    {falg: PAlgebra Name A F} {galg: PAlgebra Name A G} :
    PAlgebra Name A (F :+: G) | 6 :=
    {| p_algebra := fun fga =>
         (match fga with
           | inl fa => p_algebra fa
           | inr ga => p_algebra ga
          end) |}.

  Class WF_Ind {E F: Set -> Set} {Name : Set} {Fun_E : Functor E} {Fun_F : Functor F}
    {P : Fix E -> Prop} {sub_F_E : F :<: E}
    (F_Alg : PAlgebra Name (sig P) F) :=
    {proj_eq : forall e, proj1_sig (p_algebra (PAlgebra := F_Alg) e) =
      in_t (inj (Sub_Functor := sub_F_E) (fmap (@proj1_sig _ _) e))}.

  Definition Sub_Functor_inl' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) :
    F :<: H.
    econstructor 1 with
      (inj := fun (A : Set) (e : F A) => (@inj _ _ sub_F_G A (inl _ e)))
      (prj := fun (A : Set) (ha : H A) =>
        match @prj _ _ sub_F_G A ha with
          | Some (inl f) => Some f
          | Some (inr g) => None
          | None => None
        end).
    intros until fa; caseEq (prj ga);
      [rewrite (inj_prj _ _ H0); destruct i; congruence | discriminate].
    intros; rewrite prj_inj; reflexivity.
  Defined.

  Definition Sub_Functor_inr' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) :
    G :<: H.
    econstructor 1 with
      (inj := fun (A : Set) (e : G A) => (@inj _ _ sub_F_G A (inr _ e)))
      (prj := fun (A : Set) (H0 : H A) =>
          match @prj _ _ sub_F_G A H0 with
            | Some (inl f) => None
            | Some (inr g) => Some g
            | None => None
          end).
    intros until fa; caseEq (prj ga);
      [rewrite (inj_prj _ _ H0); destruct i; congruence | discriminate].
    intros; rewrite prj_inj; reflexivity.
  Defined.

  Global Instance WF_Ind_Plus_split {F G H}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {sub_F_G_H : (F :+: G) :<: H}
    {Name : Set}
    {P : Fix H -> Prop}
    {F_Alg: PAlgebra Name (sig P) F}
    {G_Alg: PAlgebra Name (sig P) G}
    (WF_falg : @WF_Ind H F Name Fun_H Fun_F _ (Sub_Functor_inl' _ _ _ sub_F_G_H)
      F_Alg)
    (WF_falg : @WF_Ind H G Name Fun_H Fun_G _ (Sub_Functor_inr' _ _ _ sub_F_G_H)
      G_Alg)
    :
    @WF_Ind H (F :+: G) _ _ _ P _ (PAlgebra_Plus Name _ F G) | 0.
      econstructor; intros.
      destruct e; simpl.
      rewrite (proj_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)); simpl;
        reflexivity.
      rewrite (proj_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)); simpl;
        reflexivity.
    Defined.

    (* The key reasoning lemma. *)
    Lemma Ind {F : Set -> Set}
      {Fun_F : Functor F}
      {P : Fix F -> Prop}
      {N : Set}
      {Ind_Alg : PAlgebra N (sig P) F}
      {WF_Ind_Alg : WF_Ind Ind_Alg}
      :
      forall (f : Fix F)
        (fUP' : Universal_Property'_fold f),
        P f.
      intros.
      cut (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f) = id f).
      unfold id.
      intro f_eq; rewrite <- f_eq.
      eapply (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)).
      erewrite (@Fusion _ Fun_F f fUP' _ _ (@proj1_sig (Fix F) P)
        (@p_algebra _ _ _ Ind_Alg) in_t).
      eapply Fix_id_fold; unfold id; assumption.
      intros; rewrite (proj_eq (WF_Ind := WF_Ind_Alg)).
      simpl; unfold id; reflexivity.
    Defined.

  Class WF_Ind2 {E E' F: Set -> Set} {Name : Set}
    {Fun_E : Functor E} {Fun_E : Functor E'} {Fun_F : Functor F}
    {P : (Fix E) * (Fix E') -> Prop} {sub_F_E : F :<: E} {sub_F_E' : F :<: E'}
    (F_Alg : PAlgebra Name (sig P) F) :=
    {proj1_eq : forall e, fst (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) =
      in_t (inj (Sub_Functor := sub_F_E) (fmap (fun e => fst (proj1_sig e)) e));
      proj2_eq : forall e, snd (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) =
        in_t (inj (Sub_Functor := sub_F_E') (fmap (fun e => snd (proj1_sig e)) e))
    }.

  Global Instance WF_Ind2_Plus_split {F G H H'}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {Fun_H' : Functor H'}
    {sub_F_G_H : (F :+: G) :<: H}
    {sub_F_G_H' : (F :+: G) :<: H'}
    {Name : Set}
    {P : (Fix H) * (Fix H') -> Prop}
    {F_Alg: PAlgebra Name (sig P) F}
    {G_Alg: PAlgebra Name (sig P) G}
    (WF_falg : @WF_Ind2 H H' F Name Fun_H Fun_H' Fun_F _
      (Sub_Functor_inl' _ _ _ sub_F_G_H) (Sub_Functor_inl' _ _ _ sub_F_G_H')
      F_Alg)
    (WF_falg : @WF_Ind2 H H' G Name Fun_H Fun_H' Fun_G _
      (Sub_Functor_inr' _ _ _ sub_F_G_H) (Sub_Functor_inr' _ _ _ sub_F_G_H')
      G_Alg)
    :
    @WF_Ind2 H H' (F :+: G) _ _ _ _ P _ _ (PAlgebra_Plus Name _ F G) | 0.
      econstructor; intros; destruct e; simpl.
      rewrite (proj1_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)
        (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl;
        reflexivity.
      rewrite (proj1_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)
        (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl;
        reflexivity.
      rewrite (proj2_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)
        (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl;
        reflexivity.
      rewrite (proj2_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)
        (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl;
        reflexivity.
    Defined.

    Lemma Ind2 {F : Set -> Set}
      {Fun_F : Functor F}
      {P : (Fix F) * (Fix F) -> Prop}
      {N : Set}
      {Ind_Alg : PAlgebra N (sig P) F}
      {WF_Ind_Alg : WF_Ind2 Ind_Alg}
      :
      forall (f : Fix F)
        (fUP' : Universal_Property'_fold f),
        P (f, f).
      intros.
      cut (fst (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f).
      cut (snd (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f).
      intros f2_eq f1_eq; rewrite <- f1_eq at 1; rewrite <- f2_eq at -1.
      generalize (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)).
      destruct (proj1_sig (fold_ (sig P) p_algebra f)); simpl; auto.
      erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => snd (proj1_sig e))
        (@p_algebra _ _ _ Ind_Alg) in_t).
      eapply Fix_id_fold; unfold id; assumption.
      intros; rewrite (proj2_eq (WF_Ind2 := WF_Ind_Alg)).
      simpl; unfold id; reflexivity.
      erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => fst (proj1_sig e))
        (@p_algebra _ _ _ Ind_Alg) in_t).
      eapply Fix_id_fold; unfold id; assumption.
      intros; rewrite (proj1_eq (WF_Ind2 := WF_Ind_Alg)).
      simpl; unfold id; reflexivity.
    Defined.

    Class iPAlgebra (Name : Set) {I : Set} (A : I -> Prop) (F: (I -> Prop) -> I -> Prop) : Prop :=
    { ip_algebra : iAlgebra F A}.

    (* Definition iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop)
      (F G : (I -> Prop) -> I -> Prop)
      {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} :
      iPAlgebra Name A (F ::+:: G) :=
        Build_iPAlgebra Name _ A _
        (fun f fga =>
          (match fga with
             | or_introl fa => ip_algebra f fa
             | or_intror ga => ip_algebra f ga
           end)). *)

    Global Instance iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop)
      (F G : (I -> Prop) -> I -> Prop)
      {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} :
      iPAlgebra Name A (F ::+:: G) | 6 :=
        {| ip_algebra := fun f fga =>
          (match fga with
             | or_introl fa => ip_algebra f fa
             | or_intror ga => ip_algebra f ga
           end) |}.

  Class iWF_Ind {I : Set} {E F: (I -> Prop) -> I -> Prop} {Name : Set}
    {Fun_E : iFunctor E} {Fun_F : iFunctor F}
    {P : forall i, iFix E i -> Prop} {sub_F_E : Sub_iFunctor F E}
    (F_Alg : iPAlgebra Name (fun i => sig (P i)) F) :=
    {iproj_eq : forall i e, proj1_sig (ip_algebra (iPAlgebra := F_Alg) i e) =
      in_ti i (inj_i (Sub_iFunctor := sub_F_E) i (ifmap i (fun i => proj1_sig (P := P i)) e))}.

  Definition Sub_iFunctor_inl' {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop)
    (isub_F_G : Sub_iFunctor (F ::+:: G) H) :
    Sub_iFunctor F H :=
    {| inj_i := fun (A : I' -> Prop) (i : I') (fai : F A i) =>
      @inj_i _ _ _ isub_F_G _ _ (or_introl (G A i) fai);
      prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) =>
        let o := prj_i i hai in
          match o with
            | or_introl (or_introl H2) => or_introl True H2
            | or_introl (or_intror _) => or_intror (F A i) I
            | or_intror H1 => or_intror (F A i) H1
          end |}.

  Definition Sub_iFunctor_inr' {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop)
    (isub_F_G : Sub_iFunctor (F ::+:: G) H) :
    Sub_iFunctor G H :=
    {| inj_i := fun (A : I' -> Prop) (i : I') (gai : G A i) =>
      @inj_i _ _ _ isub_F_G _ _ (or_intror _ gai);
      prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) =>
        let o := prj_i i hai in
          match o with
            | or_introl (or_intror H2) => or_introl True H2
            | or_introl (or_introl _) => or_intror _ I
            | or_intror H1 => or_intror _ H1
          end |}.

  Global Instance iWF_Ind_Plus_split {I : Set}
    {F G H : (I -> Prop) -> I -> Prop}
    {Fun_F : iFunctor F}
    {Fun_G : iFunctor G}
    {Fun_H : iFunctor H}
    {sub_F_G_H : Sub_iFunctor (F ::+:: G) H}
    {Name : Set}
    {P : forall i, iFix H i -> Prop}
    {F_Alg: iPAlgebra Name (fun i => sig (P i)) F}
    {G_Alg: iPAlgebra Name (fun i => sig (P i)) G}
    {WF_falg : @iWF_Ind _ H F Name Fun_H Fun_F _ (Sub_iFunctor_inl' _ _ _ sub_F_G_H)
      F_Alg}
    {WF_falg : @iWF_Ind _ H G Name Fun_H Fun_G _ (Sub_iFunctor_inr' _ _ _ sub_F_G_H)
      G_Alg}
    :
    @iWF_Ind _ H (F ::+:: G) _ _ _ P _ (iPAlgebra_Plus Name _ F G) | 0.
      econstructor; intros.
      destruct e; simpl.
      rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inl' _ _ _ _ sub_F_G_H)); simpl;
        reflexivity.
      rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inr' _ _ _ _ sub_F_G_H)); simpl;
        reflexivity.
    Defined.

End WF_Ind_FAlgebras.

(* ============================================== *)
(* ADDTIONAL MENDLER ALGEBRA INFRASTRUCTURE       *)
(* ============================================== *)

Section WF_MAlgebras.

  Class WF_MAlgebra {Name : Set} {F : Set -> Set} {A : Set}
    {Fun_F : Functor F}(MAlg : forall R, FAlgebra Name R A F) :=
    {wf_malgebra : forall (T T' : Set) (f : T' -> T) (rec : T -> A) (ft : F T'),
      f_algebra (FAlgebra := MAlg T) rec (fmap f ft) =
      f_algebra (FAlgebra := MAlg T') (fun ft' => rec (f ft')) ft}.

  Global Instance WF_MAlgebra_Plus {Name : Set} {F G : Set -> Set} {A : Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    (MAlg_F : forall R, FAlgebra Name R A F)
    (MAlg_G : forall R, FAlgebra Name R A G)
    {WF_MAlg_F : WF_MAlgebra MAlg_F}
    {WF_MAlg_G : WF_MAlgebra MAlg_G}
    :
    @WF_MAlgebra Name (F :+: G) A _ (fun R => FAlgebra_Plus Name R A F G).
  Proof.
    constructor; intros.
    destruct ft; simpl; apply wf_malgebra.
  Qed.

End WF_MAlgebras.

Definition Smarked (S: Set) : Set := S.

Ltac Smark H :=
  let t := type of H in
  let n:= fresh in
    (assert (n:Smarked t); [exact H | clear H; rename n into H]).

Ltac unSmark H := unfold Smarked in H.

Ltac unSmark_all := unfold Smarked in *|-.

Ltac WF_Falg_rewrite' :=
  match goal with
    | H : WF_FAlgebra _ _ _ _ _ _ _ |- _ =>
      try rewrite (wf_algebra (WF_FAlgebra := H)); Smark H; WF_Falg_rewrite'
    | _ => simpl
  end;
  unSmark_all.

Ltac WF_Falg_rewrite := unfold inject, in_t; WF_Falg_rewrite'.

Ltac fold_ind := eapply Ind.

Hint Extern 0 (FAlgebra _ _ _ (_ :+: _)) =>
  apply FAlgebra_Plus; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (forall _, FAlgebra _ _ _ _) =>
  intros; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (forall _, PAlgebra _ _ _) =>
  intros; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (PAlgebra _ _ (_ :+: _)) =>
  apply PAlgebra_Plus; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (iPAlgebra _ _ (_ :+: _)) =>
  apply iPAlgebra_Plus; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (WF_Ind _) =>
  let e := fresh in
    constructor; intro e; destruct e; reflexivity : typeclass_instances.

Hint Extern 0 (WF_Ind2 _) =>
  let e := fresh in
    constructor; intro e; destruct e; reflexivity : typeclass_instances.

Hint Extern 0 (WF_MAlgebra _) =>
  let T := fresh in
    let T' := fresh in
      let f' := fresh in
        let rec' := fresh in
          let ft := fresh in
            constructor; intros T T' f' rec' ft; destruct ft;
              simpl; auto; fail : typeclass_instances.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Export XR_R1.
Require Export XR_Rmult.

Local Open Scope R_scope.

Fixpoint pow (r:R) (n:nat) : R := match n with
| O => R1
| S n => Rmult r (pow r n)
end.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import PartSum.
Open Local Scope R_scope.

Set Implicit Arguments.

Section Sigma.

  Variable f : nat -> R.

  Definition sigma (low high:nat) : R :=
    sum_f_R0 (fun k:nat => f (low + k)) (high - low).

  Theorem sigma_split :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high.
  Proof.
    intros; induction  k as [| k Hreck].
    cut (low = 0%nat).
    intro; rewrite H1; unfold sigma in |- *; rewrite <- minus_n_n;
      rewrite <- minus_n_O; simpl in |- *; replace (high - 1)%nat with (pred high).
    apply (decomp_sum (fun k:nat => f k)).
    assumption.
    apply pred_of_minus.
    inversion H; reflexivity.
    cut ((low <= k)%nat \/ low = S k).
    intro; elim H1; intro.
    replace (sigma low (S k)) with (sigma low k + f (S k)).
    rewrite Rplus_assoc;
      replace (f (S k) + sigma (S (S k)) high) with (sigma (S k) high).
    apply Hreck.
    assumption.
    apply lt_trans with (S k); [ apply lt_n_Sn | assumption ].
    unfold sigma in |- *; replace (high - S (S k))%nat with (pred (high - S k)).
    pattern (S k) at 3 in |- *; replace (S k) with (S k + 0)%nat;
      [ idtac | ring ].
    replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with
    (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))).
    apply (decomp_sum (fun i:nat => f (S k + i))).
    apply lt_minus_O_lt; assumption.
    apply sum_eq; intros; replace (S k + S i)%nat with (S (S k) + i)%nat.
    reflexivity.
    ring.
    replace (high - S (S k))%nat with (high - S k - 1)%nat.
    apply pred_of_minus.
    omega.
    unfold sigma in |- *; replace (S k - low)%nat with (S (k - low)).
    pattern (S k) at 1 in |- *; replace (S k) with (low + S (k - low))%nat.
    symmetry  in |- *; apply (tech5 (fun i:nat => f (low + i))).
    omega.
    omega.
    rewrite <- H2; unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
      replace (high - S low)%nat with (pred (high - low)).
    replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with
    (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))).
    apply (decomp_sum (fun k0:nat => f (low + k0))).
    apply lt_minus_O_lt.
    apply le_lt_trans with (S k); [ rewrite H2; apply le_n | assumption ].
    apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat.
    reflexivity.
    ring.
    omega.
    inversion H; [ right; reflexivity | left; assumption ].
  Qed.

  Theorem sigma_diff :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
  Proof.
    intros low high k H1 H2; symmetry  in |- *; rewrite (sigma_split H1 H2); ring.
  Qed.

  Theorem sigma_diff_neg :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high.
  Proof.
    intros low high k H1 H2; rewrite (sigma_split H1 H2); ring.
  Qed.

  Theorem sigma_first :
    forall low high:nat,
      (low < high)%nat -> sigma low high = f low + sigma (S low) high.
  Proof.
    intros low high H1; generalize (lt_le_S low high H1); intro H2;
      generalize (lt_le_weak low high H1); intro H3;
        replace (f low) with (sigma low low).
    apply sigma_split.
    apply le_n.
    assumption.
    unfold sigma in |- *; rewrite <- minus_n_n.
    simpl in |- *.
    replace (low + 0)%nat with low; [ reflexivity | ring ].
  Qed.

  Theorem sigma_last :
    forall low high:nat,
      (low < high)%nat -> sigma low high = f high + sigma low (pred high).
  Proof.
    intros low high H1; generalize (lt_le_S low high H1); intro H2;
      generalize (lt_le_weak low high H1); intro H3;
        replace (f high) with (sigma high high).
    rewrite Rplus_comm; cut (high = S (pred high)).
    intro; pattern high at 3 in |- *; rewrite H.
    apply sigma_split.
    apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
    apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
    apply S_pred with 0%nat; apply le_lt_trans with low;
      [ apply le_O_n | assumption ].
    unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
      replace (high + 0)%nat with high; [ reflexivity | ring ].
  Qed.

  Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
  Proof.
    intro; unfold sigma in |- *; rewrite <- minus_n_n.
    simpl in |- *; replace (low + 0)%nat with low; [ reflexivity | ring ].
  Qed.

End Sigma.


(* week-04_programming-and-proving.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 05 Sep 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).

Definition beq_nat_nat A B :=
  match A, B with
    (a1, b1), (a2, b2) =>
    (a1 =n= a2) && (b1 =n= b2)
  end.

Notation "A =nn= B" :=
  (beq_nat_nat A B) (at level 70, right associativity).

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

Definition test_add (candidate: nat -> nat -> nat) :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4)
  .

Fixpoint add_v1 (i j : nat) : nat :=
  match i with
  | O => j
  | S i' => S (add_v1 i' j)
  end.

Compute (test_add add_v1).

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_add_v1_0 :
  forall j : nat,
    add_v1 0 j = j.
Proof.
  unfold_tactic add_v1.
Qed.

Lemma unfold_add_v1_S :
  forall i' j : nat,
    add_v1 (S i') j = S (add_v1 i' j).
Proof.
  unfold_tactic add_v1.
Qed.

Proposition add_v1_0_n :
  forall n : nat,
    add_v1 0 n = n.
Proof.
  intro n.
  Check (unfold_add_v1_0).
  apply unfold_add_v1_0.

  Restart.
  apply unfold_add_v1_0.
Qed.

Lemma add_v1_n_0 :
  forall n : nat,
    add_v1 n 0 = n.
Proof.
  intro i.
  induction i as [  | i' IH_i'].

  Check (unfold_add_v1_0 0).
  (* apply (unfold_add_v1_0 0). *)
  rewrite (unfold_add_v1_0 0).
  reflexivity.

  Check (unfold_add_v1_S i' 0).
  rewrite -> (unfold_add_v1_S i' 0).
  Check (IH_i').
  rewrite -> IH_i'.
  reflexivity.
Qed.
Lemma add_v1_assoc :
  forall x y z : nat,
    add_v1 x (add_v1 y z) =
    add_v1 (add_v1 x y) z.
Proof.
  intro x.
  induction x as [ | x' IHx'].

  intros y z.
  rewrite -> (unfold_add_v1_0 (add_v1 y z)).
  rewrite -> (unfold_add_v1_0 y).
  reflexivity.

  intros y z.
  rewrite -> (unfold_add_v1_S x' (add_v1 y z)).
  rewrite -> (unfold_add_v1_S x' y).
  rewrite -> (unfold_add_v1_S (add_v1 x' y)).
  rewrite -> (IHx' y z).
  reflexivity.
Qed.

(* ***** *)

Fixpoint add_v2 (i j : nat) : nat :=
  match i with
  | O => j
  | S i' => add_v2 i' (S j)
  end.

Compute (test_add add_v2).

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_add_v2_0 :
  forall j : nat,
    add_v2 0 j = j.
Proof.
  unfold_tactic add_v2.
Qed.

Lemma unfold_add_v2_S :
  forall i' j : nat,
    add_v2 (S i') j = add_v2 i' (S j).
Proof.
  unfold_tactic add_v2.
Qed.

(* ***** *)

Proposition equivalence_of_add_v1_and_add_v2 :
  forall i j : nat,
    add_v1 i j = add_v2 i j.
Proof.
Admitted.

Proposition add_v2_0_n :
  forall n : nat,
    add_v2 0 n = n.
Proof.
  intro n.
  Check (equivalence_of_add_v1_and_add_v2).
  rewrite <- (equivalence_of_add_v1_and_add_v2 0 n).
  apply unfold_add_v1_0.
Qed.
Proposition add_v2_n_0 :
  forall n : nat,
    add_v2 n 0 = n.
Proof.
  intro n.
  Check (equivalence_of_add_v1_and_add_v2).
  rewrite <- (equivalence_of_add_v1_and_add_v2 n 0).
  Check (add_v1_n_0).
  rewrite -> add_v1_n_0.
  reflexivity.
Qed.

Lemma add_v2_assoc :
  forall x y z : nat,
    add_v2 x (add_v2 y z) =
    add_v2 (add_v2 x y) z.
Proof.
Abort.

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

Definition test_min (candidate : nat -> nat -> nat) : bool :=
  (candidate 0 3 =n= 0)
  &&
  (candidate 3 0 =n= 0)
  &&
  (candidate 2 3 =n= 2)
  &&
  (candidate 3 2 =n= 2)
  &&
  (candidate 3 3 =n= 3)
  .

(* ***** *)

(* Lambda-dropped version of min_v1: *)

Fixpoint visit_min_v1 (m_init n_init m n : nat) : nat :=
  match m with
  | 0 => m_init
  | S m' => match n with
            | 0 => n_init
            | S n' => visit_min_v1 m_init n_init m' n'
            end
  end.

Definition min_v1 (m_init n_init : nat) : nat :=
  visit_min_v1 m_init n_init m_init n_init.

Compute (test_min min_v1).

Fixpoint min_v2 (m n : nat) : nat :=
  match m with
  | 0 => 0
  | S m' => match n with
            | 0 => 0
            | S n' => S (min_v2 m' n')
            end
  end.

Compute (test_min min_v2).

(* ***** *)

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_visit_min_v1_0 :
  forall m_init n_init n : nat,
    visit_min_v1 m_init n_init 0 n = m_init.
Proof.
  unfold_tactic visit_min_v1.
Qed.

Lemma unfold_visit_min_v1_S :
  forall m_init n_init m' n : nat,
    visit_min_v1 m_init n_init (S m') n =
    match n with
    | 0 => n_init
    | S n' => visit_min_v1 m_init n_init m' n'
    end.
Proof.
  unfold_tactic visit_min_v1.
Qed.

Lemma unfold_min_v2_0 :
  forall n : nat,
    min_v2 0 n = 0.
Proof.
  unfold_tactic min_v2.
Qed.

Lemma unfold_min_v2_S :
  forall m' n : nat,
    min_v2 (S m') n =
    match n with
    | 0 => 0
    | S n' => S (min_v2 m' n')
    end.
Proof.
  unfold_tactic min_v2.
Qed.

(* ***** *)

Lemma succ_visit_min_v1 :
  forall m n m' n' : nat,
    visit_min_v1 (S m) (S n) m' n' =
    S (visit_min_v1 m n m' n').
Proof.
  intros m n m'.
  induction m' as [ | m'' IHm''].

  intro n'.
  Check (unfold_visit_min_v1_0 (S m) (S n) n').
  rewrite -> (unfold_visit_min_v1_0 (S m) (S n) n').
  Check (unfold_visit_min_v1_0 m n n').
  rewrite -> (unfold_visit_min_v1_0 m n n').
  reflexivity.

  intros [ | n'].
  Check (unfold_visit_min_v1_S (S m) (S n) m'' 0).
  rewrite -> (unfold_visit_min_v1_S (S m) (S n) m'' 0).
  rewrite -> (unfold_visit_min_v1_S m n m'' 0).
  reflexivity.

  Check (unfold_visit_min_v1_S (S m) (S n) m'' (S n')).
  rewrite -> (unfold_visit_min_v1_S (S m) (S n) m'' (S n')).
  Check (IHm'' n').
  rewrite -> (IHm'' n').
  Check (unfold_visit_min_v1_S m n m'' (S n')).
  rewrite -> (unfold_visit_min_v1_S m n m'' (S n')).
  reflexivity.
 Qed.

  Proposition equivalence_of_min_v1_and_min_v2 :
  forall m n : nat,
    min_v1 m n = min_v2 m n.
Proof.
  unfold min_v1.
  intro m.
  induction m as [ |m' IHm'].

  intro n.
  Check (unfold_visit_min_v1_0 0 n).
  rewrite -> (unfold_visit_min_v1_0 0 n).
  Check (unfold_min_v2_0).
  rewrite -> (unfold_min_v2_0 n).
  reflexivity.

  intros [ | n'].
  Check (unfold_visit_min_v1_S (S m') 0 m' 0).
  rewrite -> (unfold_visit_min_v1_S (S m') 0 m' 0).
  Check (unfold_min_v2_S m' 0).
  rewrite -> (unfold_min_v2_S m' 0).
  reflexivity.

  Check (unfold_visit_min_v1_S (S m') (S n') m' (S n')).
  rewrite -> (unfold_visit_min_v1_S (S m') (S n') m' (S n')).
  Check (unfold_min_v2_S m' (S n')).
  rewrite -> (unfold_min_v2_S m' (S n')).
  Check (IHm' n').
  rewrite <- (IHm' n').

  Check (succ_visit_min_v1 m' n' m' n').
  apply (succ_visit_min_v1 m' n' m' n').
Qed.

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

Definition test_evenp (candidate : nat -> bool) : bool :=
  (eqb (candidate 0) true)
  &&
  (eqb (candidate 1) false)
  &&
  (eqb (candidate 7) false)
  &&
  (eqb (candidate 8) true)
  &&
  (eqb (candidate 17) false)
  .

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

Compute (test_evenp evenp_v1).

(* With an inherited attribute, lambda-lifted: *)

Fixpoint visit_evenp_v2 (n : nat) (a : bool) : bool :=
  match n with
  | 0 => a
  | S n' => visit_evenp_v2 n' (negb a)
  end.

Definition evenp_v2 (n : nat) : bool :=
  visit_evenp_v2 n true.

Compute (test_evenp evenp_v2).

Fixpoint evenp_v3 (n : nat) : bool :=
  match n with
  | 0 => true
  | S n' => negb (evenp_v3 n')
  end.

Compute (test_evenp evenp_v3).

(********************************************************************************)
Lemma unfold_evenp_v1_0 :
    evenp_v1 0 = true.
Proof.
  unfold_tactic evenp_v1.
Qed.

Lemma unfold_evenp_v1_S :
  forall n' : nat,
    evenp_v1 (S n') =
    match n' with
            | 0 => false
            | S n'' => evenp_v1 n''
    end.
Proof.
  unfold_tactic evenp_v1.
Qed.

Lemma unfold_visit_evenp_v2_0 :
  forall (a : bool),
   visit_evenp_v2 0 a = a.
Proof.
  unfold_tactic visit_evenp_v2.
Qed.

Lemma unfold_visit_evenp_v2_S :
  forall (n' : nat) (a : bool),
    visit_evenp_v2 (S n') a = visit_evenp_v2 n' (negb a).
Proof.
  unfold_tactic visit_evenp_v2.
Qed.

Lemma unfold_evenp_v3_0 :
    evenp_v3 0 = true.
Proof.
  unfold_tactic evenp_v3.
Qed.

Lemma unfold_evenp_v3_S :
  forall n' : nat,
    evenp_v3 (S n') = negb (evenp_v3 n').
Proof.
  unfold_tactic evenp_v3.
Qed.

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

Lemma about_visit_evenp_v2:
  forall (n : nat) (b: bool),
    visit_evenp_v2 n (negb b) = negb (visit_evenp_v2 n b).
  intro n.
  induction n as [ | n' IHn'].
  intro b.
  Check (unfold_visit_evenp_v2_0 (negb b)).
  rewrite -> (unfold_visit_evenp_v2_0 (negb b)).
  Check (unfold_visit_evenp_v2_0 b).
  rewrite -> (unfold_visit_evenp_v2_0 b).
  reflexivity.

  intro b.
  Check (unfold_visit_evenp_v2_S n' (negb b)).
  rewrite -> (unfold_visit_evenp_v2_S n' (negb b)).

  Check (unfold_visit_evenp_v2_S n' b).
  rewrite -> (unfold_visit_evenp_v2_S n' b).

  rewrite <- (IHn').
  reflexivity.
Qed.

Lemma about_evenp_v1:
  forall n : nat,
    negb (evenp_v1 (S n)) = (evenp_v1 n).

  intro n''.
  induction n'' as [ | n'' IHn''].

  Check (unfold_evenp_v1_S 0).
  rewrite -> (unfold_evenp_v1_S 0).
  Check (unfold_evenp_v1_0).
  rewrite -> unfold_evenp_v1_0.
  unfold negb.
  reflexivity.

  Check (unfold_evenp_v1_S (S n'')).
  rewrite -> (unfold_evenp_v1_S (S n'')).
  Check IHn''.
  rewrite <- IHn''.
  Search (negb (negb _) = _).
  apply negb_involutive.
Qed.

Proposition equivalence_of_evenp_v1_and_evenp_v2 :
  forall n : nat,
    evenp_v1 n = evenp_v2 n.
Proof.
   unfold evenp_v2.
   intros [ | n'].
   Check (unfold_evenp_v1_0).
   rewrite -> (unfold_evenp_v1_0).
   Check (unfold_visit_evenp_v2_0 true).
   rewrite -> (unfold_visit_evenp_v2_0 true).
   reflexivity.

   induction n' as [ | n'' IHn''].
   Check (unfold_evenp_v1_S 0).
   rewrite -> (unfold_evenp_v1_S 0).
   Check (unfold_visit_evenp_v2_S 0 true).
   rewrite -> (unfold_visit_evenp_v2_S 0 true).

   Check (unfold_visit_evenp_v2_0 (negb true)).
   rewrite -> (unfold_visit_evenp_v2_0 ).
   unfold negb.
   reflexivity.

   Check (unfold_evenp_v1_S (S n'')).
   rewrite -> (unfold_evenp_v1_S (S n'')).
   Check (about_evenp_v1 n'').
   rewrite <- (about_evenp_v1 n'').

   rewrite IHn''.

   Check (unfold_visit_evenp_v2_S (S n'') true).
   rewrite -> (unfold_visit_evenp_v2_S (S n'') true).

   Check (about_visit_evenp_v2 (S n'') true).
   rewrite -> (about_visit_evenp_v2 (S n'') true).
   reflexivity.
Qed.

Proposition equivalence_of_evenp_v2_and_evenp_v3 :
  forall n : nat,
    evenp_v2 n = evenp_v3 n.
Proof.
  unfold evenp_v2.
  intro n.
  induction n as [ | n'].

  rewrite -> (unfold_visit_evenp_v2_0 true).
  rewrite -> (unfold_evenp_v3_0).
  reflexivity.

  Check (unfold_evenp_v3_S n').
  rewrite -> (unfold_evenp_v3_S n').
  rewrite <- IHn'.

  Check (unfold_visit_evenp_v2_S n' true).
  rewrite -> (unfold_visit_evenp_v2_S n' true).
  Check (about_visit_evenp_v2 n' true).
  rewrite -> (about_visit_evenp_v2 n' true).
  reflexivity.
Qed.

Proposition equivalence_of_evenp_v1_and_evenp_v3 :
  forall n : nat,
    evenp_v1 n = evenp_v3 n.
Proof.
  intros [ | n'].

  rewrite -> unfold_evenp_v1_0.
  rewrite -> unfold_evenp_v3_0.
  reflexivity.

  induction n' as [ | n' IHn'].
  Check unfold_evenp_v1_S 0.
  rewrite -> (unfold_evenp_v1_S 0).
  Check unfold_evenp_v3_S 0.
  rewrite -> (unfold_evenp_v3_S 0).
  rewrite -> (unfold_evenp_v3_0).
  unfold negb.
  reflexivity.

  Check (unfold_evenp_v3_S (S n')).
  rewrite -> (unfold_evenp_v3_S (S n')).
  Check (IHn').
  rewrite <- IHn'.
  Check (about_evenp_v1 n').
  rewrite -> (about_evenp_v1 n').

  Check (unfold_evenp_v1_S (S n')).
  rewrite -> (unfold_evenp_v1_S (S n')).
  reflexivity.
Qed.

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

Definition test_fac (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 1)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 2)
  &&
  (candidate 3 =n= 6) &&
  (candidate 4 =n= 24)
  &&
  (candidate 5 =n= 120)
  .

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

Compute (test_fac fac_v1).

Fixpoint visit_fac_v2 (n a : nat) : nat :=
  match n with
  | 0 => a
  | S n' => (visit_fac_v2 n' (n * a))
  end.

Definition fac_v2 (n : nat) : nat :=
  visit_fac_v2 n 1.

Compute (test_fac fac_v2).

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

Lemma unfold_fac_v1_0 :
    fac_v1 0 = 1.
Proof.
  unfold_tactic fac_v1.
Qed.

Lemma unfold_fac_v1_S :
  forall (n' : nat),
  fac_v1 (S n') = (S n') * (fac_v1 n').
Proof.
  unfold_tactic fac_v1.
Qed.

Lemma unfold_visit_fac_v2_0 :
  forall (a : nat),
   visit_fac_v2 0 a = a.
Proof.
  unfold_tactic visit_fac_v2.
Qed.

Lemma unfold_visit_fac_v2_S :
  forall (n' a : nat),
    visit_fac_v2 (S n') a = visit_fac_v2 n' ((S n') * a).
Proof.
  unfold_tactic visit_fac_v2.
Qed.

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

Lemma about_visit_fac_v2:
    forall (n a1 a2 : nat),
      visit_fac_v2 n (a1 * a2) = a1 * visit_fac_v2 n a2.
Proof.
  intro n.
  induction n as [ | n' IHn'].

  intros a1 a2.
  rewrite -> (unfold_visit_fac_v2_0 (a1 * a2)).
  rewrite -> (unfold_visit_fac_v2_0 a2).
  reflexivity.

  intros a1 a2.
  rewrite -> (unfold_visit_fac_v2_S n' (a1 * a2)).
  rewrite -> (unfold_visit_fac_v2_S n' a2).
  Check (IHn' a1 (S n' * a2)).
  rewrite <- (IHn' a1 (S n' * a2)).

 (* Nat.mul_shuffle3: forall n m p : nat, n * (m * p) = m * (n * p)*)
  rewrite -> (Nat.mul_shuffle3 (S n') a1 a2).
  reflexivity.
Qed.

Proposition equivalence_of_fac_v1_and_fac_v2 :
  forall n : nat,
    fac_v1 n = fac_v2 n.
Proof.
  unfold fac_v2.
  induction n as [ | n' IHn'].

  Check unfold_fac_v1_0.
  rewrite -> unfold_fac_v1_0.
  Check (unfold_visit_fac_v2_0 1).
  rewrite -> (unfold_visit_fac_v2_0 1).
  reflexivity.

  Check (IHn').
  rewrite -> (unfold_fac_v1_S n').
  rewrite -> (IHn').
  rewrite -> (unfold_visit_fac_v2_S n').

  rewrite <- (about_visit_fac_v2 n' (S n') 1).
  reflexivity.
Qed.

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

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

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

Compute (test_fib fib_v1).

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

Definition fib_v2 (n : nat) : nat :=
  visit_fib_v2 n 0 1.

Compute (test_fib fib_v2).

Fixpoint visit_fib_v3 (n : nat) : nat * nat :=
  match n with
  | 0 => (0, 1)
  | S n' => match visit_fib_v3 n' with
              | (a1, a2) => (a2, a1 + a2)
            end
  end.

Definition fib_v3 (n : nat) : nat :=
  match visit_fib_v3 n with
    | (a1, a2) => a1
  end.

Compute (test_fib fib_v3).

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

Definition test_visit_fib_v2 (f : nat -> nat -> nat -> nat) :=
  (f 0 0 1 =n= 0)&&
  (f 1 0 1 =n= 1)&&
  (f 2 0 1 =n= 1)&&
  (f 3 0 1 =n= 2)&&
  (f 4 0 1 =n= 3)&&
  (f 5 0 1 =n= 5)&&
  (f 6 0 1 =n= 8)&&
  (f 7 0 1 =n= 13).

Compute test_visit_fib_v2 visit_fib_v2.

Definition test_visit_fib_v3 (f : nat -> nat * nat) :=
  (f 0 =nn= (0, 1))&&
  (f 1 =nn= (1, 1))&&
  (f 2 =nn= (1, 2))&&
  (f 2 =nn= (2, 3))&&
  (f 4 =nn= (3, 5))&&
  (f 5 =nn= (5, 8))&&
  (f 6 =nn= (8, 13))&&
  (f 7 =nn= (13, 21)).

Compute test_visit_fib_v2 visit_fib_v2.

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

Lemma unfold_fib_v1_0 :
    fib_v1 0 = 0.
Proof.
  unfold_tactic fib_v1.
Qed.

Lemma unfold_fib_v1_1 :
    fib_v1 1 = 1.
Proof.
  unfold_tactic fib_v1.
Qed.

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

(*
Lemma unfold_fib_v1_S' :
  forall (n'' : nat),
   fib_v1 (S n'') = fib_v1 (S (S n'')) - (fib_v1 n'').
Proof.
  unfold_tactic fib_v1.
Qed.
*)

Lemma unfold_visit_fib_v2_0 :
  forall (a1 a2: nat),
   visit_fib_v2 0 a1 a2 = a1.
Proof.
  unfold_tactic visit_fib_v2.
Qed.

Lemma unfold_visit_fib_v2_S :
  forall (n' a1 a2: nat),
   visit_fib_v2 (S n') a1 a2 = visit_fib_v2 n' a2 (a1 + a2).
Proof.
  unfold_tactic visit_fib_v2.
Qed.

Lemma unfold_visit_fib_v3_0 :
   visit_fib_v3 0 = (0, 1).
Proof.
  unfold_tactic visit_fib_v3.
Qed.

Lemma unfold_visit_fib_v3_S :
  forall (n': nat),
   visit_fib_v3 (S n') = match visit_fib_v3 n' with
                         | (a1, a2) => (a2, a1 + a2)
                         end.
Proof.
  unfold_tactic visit_fib_v3.
Qed.

(****************************************)
Lemma about_visit_fib_v2:
  forall (n : nat),
    visit_fib_v2 (S (S n)) 0 1 = (visit_fib_v2 (S n) 0 1) + (visit_fib_v2 n 0 1).
Admitted.

Lemma about_visit_fib_v2':
  forall (n : nat),
    visit_fib_v2 (S (S n)) 0 1 = visit_fib_v2 (S n) 0 1 + visit_fib_v2 n 0 1.
Admitted.

Proposition equivalence_of_fib_v1_and_fib_v2 :
  forall n : nat,
    fib_v1 n = fib_v2 n.
Proof.
  unfold fib_v2.
  induction n as [ | n'].

  rewrite -> (unfold_fib_v1_0).
  rewrite -> (unfold_visit_fib_v2_0 0 1).
  reflexivity.

  induction n' as [ | n'' IHn''].
  unfold fib_v1.
  unfold visit_fib_v2.
  reflexivity.

  rewrite -> (unfold_fib_v1_S).
  rewrite -> (about_visit_fib_v2 n'').

  Check (IHn'' (S n'')).
  Check (unfold_visit_fib_v2_S n'' 0 1).
  assert (IHn_new := IHn').
  apply IHn_new in IHn''.

  destruct IHn'.
  apply IHn' in IHn''.

Abort.

Proposition equivalence_of_fib_v1_and_fib_v3 :
  forall n : nat,
    fib_v1 n = fib_v3 n.
Proof.
  unfold fib_v3.
  intro n.
  induction n as [ | n' IHn'].

  rewrite -> (unfold_fib_v1_0).
  rewrite -> (unfold_visit_fib_v3_0).
  reflexivity.

  Check (unfold_fib_v1_S).
  assert (H_unfold_fib_v1_S := unfold_fib_v1_S).

  Search (_ = _ + _ -> _ = _ - _).
  (*plus_minus: forall n m p : nat, n = m + p -> p = n - m*)
  Check (unfold_visit_fib_v3_S n').
  rewrite -> (unfold_visit_fib_v3_S n').

Abort.

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

Inductive list_nat : Type :=
  nil_nat : list_nat
| cons_nat : nat -> list_nat -> list_nat.

Fixpoint beq_list_nat (xs ys : list_nat) : bool :=
  match xs with
    nil_nat =>
    match ys with
      nil_nat =>
      true
    | cons_nat y ys' =>
      false
    end
  | cons_nat x xs' =>
    match ys with
      nil_nat =>
      false
    | cons_nat y ys' =>
      (x =n= y) && beq_list_nat xs' ys'
    end
  end.

Notation "A =ns= B" :=
  (beq_list_nat A B) (at level 70, right associativity).

(* ***** *)

Definition test_append_list_nat (candidate: list_nat -> list_nat -> list_nat) :=
  (candidate nil_nat nil_nat =ns= nil_nat)
  &&
  (candidate nil_nat (cons_nat 10 nil_nat) =ns= (cons_nat 10 nil_nat))
  &&
  (candidate (cons_nat 1 nil_nat) (cons_nat 10 nil_nat) =ns= (cons_nat 1 (cons_nat 10 nil_nat)))
  (* etc. *)
  .

Fixpoint append_list_nat (xs ys : list_nat) : list_nat :=
  match xs with
  | nil_nat =>
    ys
  | cons_nat x xs' =>
    cons_nat x (append_list_nat xs' ys)
  end.

Compute (test_append_list_nat append_list_nat).

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_append_list_nat_nil_nat :
  forall ys : list_nat,
    append_list_nat nil_nat ys = ys.
Proof.
  unfold_tactic append_list_nat.
Qed.

Lemma unfold_append_list_nat_cons_nat :
  forall (x : nat) (xs' ys : list_nat),
    append_list_nat (cons_nat x xs') ys =
    cons_nat x (append_list_nat xs' ys).
Proof.
  unfold_tactic append_list_nat.
Qed.

Lemma append_nil_nat_ys :
  forall ys : list_nat,
    append_list_nat nil_nat ys = ys.
Proof.
Abort.

Lemma append_ys_nil_nat :
  forall xs : list_nat,
    append_list_nat xs nil_nat = xs.
Proof.
Abort.

Lemma append_list_nat_assoc :
  forall xs ys zs : list_nat,
    append_list_nat xs (append_list_nat ys zs) =
    append_list_nat (append_list_nat xs ys) zs.
Proof.
Abort.

(* ***** *)

Definition test_length_list_nat (candidate: list_nat -> nat) :=
  (candidate nil_nat =n= 0)
  &&
  (candidate (cons_nat 1 nil_nat) =n= 1)
  &&
  (candidate (cons_nat 2 (cons_nat 1 nil_nat)) =n= 2)
  (* etc. *)
  .

Fixpoint length_list_nat_v1 (xs : list_nat) : nat :=
  match xs with
  | nil_nat =>
    0
  | cons_nat x xs' =>
    S (length_list_nat_v1 xs')
  end.

Compute (test_length_list_nat length_list_nat_v1).

Fixpoint visit_length_list_nat_v2 (xs : list_nat) (a : nat) : nat :=
  match xs with
  | nil_nat =>
    a
  | cons_nat x xs' =>
    visit_length_list_nat_v2 xs' (S a)
  end.

Definition length_list_nat_v2 (xs : list_nat) : nat :=
  visit_length_list_nat_v2 xs 0.

Compute (test_length_list_nat length_list_nat_v2).

Proposition equivalence_of_length_list_nat_v1_and_length_list_nat_v2 :
  forall xs : list_nat,
    length_list_nat_v1 xs = length_list_nat_v2 xs.
Proof.
Abort.

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

Proposition append_and_length_commute_with_each_other :
  forall xs ys : list_nat,
    length_list_nat_v1 (append_list_nat xs ys) =
    (length_list_nat_v1 xs) + (length_list_nat_v1 ys).
Proof.
Abort.

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

Inductive binary_tree : Type :=
  Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Definition test_number_of_leaves (candidate: binary_tree -> nat) :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 2)) (Leaf 3)) =n= 3)
  (* etc. *)
  .

Fixpoint number_of_leaves_v1 (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    1
  | Node t1 t2 =>
    (number_of_leaves_v1 t1) + (number_of_leaves_v1 t2)
  end.

Compute (test_number_of_leaves number_of_leaves_v1).

Fixpoint visit_number_of_leaves_v2 (t : binary_tree) (a : nat) : nat :=
  match t with
    Leaf n =>
    S a
  | Node t1 t2 =>
    visit_number_of_leaves_v2 t1 (visit_number_of_leaves_v2 t2 a)
  end.

Definition number_of_leaves_v2 (t : binary_tree) : nat :=
  visit_number_of_leaves_v2 t 0.

Compute (test_number_of_leaves number_of_leaves_v1).

Proposition equivalence_of_number_of_leaves_v1_and_number_of_leaves_v2 :
  forall t : binary_tree,
    number_of_leaves_v1 t = number_of_leaves_v2 t.
Proof.
Abort.

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

(* end of week-04_programming-and-proving.v *)


Require Import Coq.Program.Equality.
Require Import Language.
Require Import Value.

(** * Definition *)

Inductive ptype : term -> type -> Prop :=
| Pt_Int : forall n,
    ptype (Lit n) Int
| Pt_Arr : forall e A B,
    lc (Lam A e B) ->
    ptype (Lam A e B) (Arr A B)
| Pt_Ann : forall e A,
    lc e ->
    ptype (Ann e A) A
| Pt_Mrg : forall e1 e2 A B,
    ptype e1 A ->
    ptype e2 B ->
    ptype (Mrg e1 e2) (And A B).

Hint Constructors ptype : core.

(** * Properties *)

(** ** Determinism *)

Lemma ptype_determinism :
  forall e A B,
    ptype e A -> ptype e B ->
    A = B.
Proof.
  intros * Pt1 Pt2. generalize dependent B.
  induction Pt1; eauto; intros;
    try solve [dependent destruction Pt2; eauto].
  - dependent destruction Pt2; eauto.
    pose proof (IHPt1_1 _ Pt2_1).
    pose proof (IHPt1_2 _ Pt2_2).
    congruence.
Qed.

(** unify ptype varialbes *)

Ltac subst_ptype :=
  match goal with
  | [H1: ptype ?v ?A1, H2: ptype ?v ?A2 |- _] =>
      (pose proof (ptype_determinism _ _ _ H1 H2) as Eqs; subst; clear H2)
  end.


Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Algebra.

Section Monoid.
  Context {T eq op id} {monoid:@monoid T eq op id}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "*" := op.
  Local Infix "=" := eq : eq_scope.
  Local Open Scope eq_scope.

  Lemma cancel_right z iz (Hinv:op z iz = id) :
    forall x y, x * z = y * z <-> x = y.
  Proof.
    split; intros.
    { assert (op (op x z) iz = op (op y z) iz) as Hcut by (rewrite_hyp ->!*; reflexivity).
      rewrite <-associative in Hcut.
      rewrite <-!associative, !Hinv, !right_identity in Hcut; exact Hcut. }
    { rewrite_hyp ->!*. reflexivity. }
  Qed.

  Lemma cancel_left z iz (Hinv:op iz z = id) :
    forall x y, z * x = z * y <-> x = y.
  Proof.
    split; intros.
    { assert (op iz (op z x) = op iz (op z y)) as Hcut by (rewrite_hyp ->!*; reflexivity).
      rewrite !associative, !Hinv, !left_identity in Hcut; exact Hcut. }
    { rewrite_hyp ->!*; reflexivity. }
  Qed.

  Lemma inv_inv x ix iix : ix*x = id -> iix*ix = id -> iix = x.
  Proof.
    intros Hi Hii.
    assert (H:op iix id = op iix (op ix x)) by (rewrite Hi; reflexivity).
    rewrite associative, Hii, left_identity, right_identity in H; exact H.
  Qed.

  Lemma inv_op x y ix iy : ix*x = id -> iy*y = id -> (iy*ix)*(x*y) =id.
  Proof.
    intros Hx Hy.
    cut (iy * (ix*x) * y = id); try intro H.
    { rewrite <-!associative; rewrite <-!associative in H; exact H. }
    rewrite Hx, right_identity, Hy. reflexivity.
  Qed.

End Monoid.

Section Homomorphism.
  Context {T  EQ OP ID} {monoidT:  @monoid T  EQ OP ID }.
  Context {T' eq op id} {monoidT': @monoid T' eq op id }.
  Context {phi:T->T'}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.
  Class is_homomorphism :=
    {
      homomorphism : forall a b,  phi (OP a b) = op (phi a) (phi b);

      is_homomorphism_phi_proper : Proper (respectful EQ eq) phi
    }.
  Global Existing Instance is_homomorphism_phi_proper.
End Homomorphism.