Require Import vcfloat.VCFloat.
Require Import List.
Import ListNotations.

Require Import common op_defs dotprod_model sum_model.
Require Import dot_acc float_acc_lems list_lemmas.

Section MVGenDefs.

Definition matrix {A : Type} := list (list A).

Definition vector {A : Type} := list A.

Fixpoint zero_vector {A: Type} (m : nat) (zero : A) : vector :=
  match m with
  | S n => zero :: zero_vector n zero
  | _ => []
  end.

Fixpoint zero_matrix {A: Type} (m n: nat) (zero : A) : matrix :=
  match m with
  | S m' => zero_vector n zero :: zero_matrix m' n zero
  | _ => []
  end.

Definition is_finite_vec {t : type} (v: vector) : Prop :=
  forall x, In x v -> Binary.is_finite (fprec t) (femax t) x = true.

Definition is_zero_vector {A: Type} v (zero : A) : Prop := forall x, In x v -> x = zero.

Definition map_mat {A B: Type} (f : A -> B) (M : matrix) : matrix :=
  map (map f) M.

Definition map2 {A B C: Type} (f: A -> B -> C) al bl :=
  map (uncurry f) (List.combine al bl).

Fixpoint zero_map_vec {A B : Type} (zero : B) (v : @vector A) : @vector B :=
  match v with
  | [] => []
  | h :: t => zero :: zero_map_vec zero t
end.

Fixpoint zero_map_mat {A B : Type} (zero : B) (M : @matrix A) : @matrix B :=
  match M with
  | [] => []
  | hM :: tM => zero_map_vec zero hM :: zero_map_mat zero tM
end.

Definition in_matrix {T : Type} (A : list (list T)) (a : T) :=
  let A' := flat_map (fun x => x) A in In a A'.

Definition matrix_index {A} (m: matrix) (i j: nat) (zero: A) : A :=
 nth j (nth i m nil) zero.

Definition eq_size {T1 T2}
  (A : list (list T1)) (B : list (list T2)) := length A = length B /\
  forall x y, In x A -> In y B -> length x = length y.

End MVGenDefs.

Section MVOpDefs.

(* generic vector sum *)
Definition vec_sum {A: Type} (u v : vector) (sum : A -> A -> A)  : @vector A :=
  map2 sum u v.

(* sum vectors of reals *)
Definition vec_sumR u v :=  vec_sum u v Rplus.

(* generic matrix sum *)
Definition mat_sum {T: Type} (A B : matrix) (sum : T -> T -> T) : @matrix T :=
  map2 (map2 sum) A B.

(* sum matrices of reals *)
Definition mat_sumR A B :=  mat_sum A B Rplus.

(* floating-point matrix vector multiplication *)
Definition mvF {NAN : Nans}  {t: type} (m: matrix ) (v: vector ) : vector  :=
      map (fun row => @dotprod NAN t row v) m.

(* real valued matrix vector multiplication *)
Definition mvR  (m: matrix) (v: vector) : vector :=
      map (fun row => dotprodR row v) m.

End MVOpDefs.

Notation "A *f v" := (mvF A v) (at level 40).
Notation "A *r v"  := (mvR A v) (at level 40).
Notation "A *fr v" := (map FT2R (mvF A v)) (at level 40).

Notation "u -v v" := (vec_sum u v Rminus) (at level 40).
Notation "u +v v" := (vec_sumR u v) (at level 40).

Notation "A -m B" := (mat_sumR A (map_mat Ropp B)) (at level 40).
Notation "A +m B" := (mat_sumR A B) (at level 40).

Notation "E _( i , j )"  :=
  (matrix_index E i j 0%R) (at level 15).

Section MVLems.

Lemma map2_length {A B C: Type} (f: A -> B -> C) al bl :
  length al = length bl ->
  length (map2 f al bl) = length al.
Proof. intros; unfold map2; rewrite map_length, combine_length, H, Nat.min_id; auto. Qed.

Lemma map_mat_length {A B: Type} :
  forall (f : A -> B) (M : @matrix A) ,
  length (map_mat f M) = length M.
Proof. intros; induction M; [simpl; auto | simpl; rewrite IHM; auto]. Qed.

Lemma zero_matrix_length {A: Type} (m n: nat) (zero : A) :
  length (zero_matrix m n zero) = m .
Proof. induction m; unfold zero_matrix; simpl; auto. Qed.

Lemma mvF_len {NAN : Nans} t m v:
  length (@mvF NAN t m v)  = length m.
Proof. induction m; simpl; auto. Qed.

Lemma dotprodF_nil {NAN : Nans} {t: type} row :
dotprod row [] = (Zconst t 0).
Proof. destruct row; simpl; auto. Qed.

Lemma mvF_nil {NAN : Nans} {t: type} : forall m, @mvF NAN t m [] = zero_vector (length m) (Zconst t 0).
Proof.
intros; unfold mvF.
set (f:= (fun row : list (ftype t) => dotprod row [])).
replace (map f m) with  (map (fun _ => Zconst t 0) m).
induction m; simpl; auto.
{ rewrite IHm; auto. }
apply map_ext_in; intros.
subst f; simpl. rewrite dotprodF_nil; auto.
Qed.

Lemma mvR_nil : forall m, mvR m [] = zero_vector (length m) 0%R.
Proof.
intros; unfold mvR.
set (f:= (fun row : list R => dotprodR row [])).
replace (map f m) with  (map (fun _ => 0%R) m).
induction m; simpl; auto.
{ rewrite IHm; auto. }
apply map_ext_in; intros.
subst f; simpl. rewrite dotprodR_nil_r; auto.
Qed.

Lemma mat_sum_length {T: Type} (sum: T -> T -> T) :
  forall (A B: matrix),
  forall (Hlen : length A = length B),
  length (mat_sum A B sum) = length A.
Proof. intros. unfold mat_sum; rewrite map2_length; auto. Qed.

Lemma zero_vector_length {A : Type} (m : nat) (zero : A) :
  length (zero_vector m zero) =  m.
Proof. induction m; simpl; auto. Qed.

Lemma vec_sumR_cons :
forall (u v : vector) u0 v0,
vec_sum (u0 :: u) (v0 :: v) Rplus = (u0 + v0) :: vec_sum u v Rplus.
Proof. induction u; destruct v; (intros; unfold vec_sum, map2; simpl; auto). Qed.

Lemma vec_sum_zeroR:
  forall (v : vector),
  vec_sum v (zero_vector (length v) 0%R) Rplus = v.
Proof.
intros; induction v; simpl; auto.
rewrite vec_sumR_cons, IHv, Rplus_0_r; auto.
Qed.

Lemma map_nil {A B: Type} (f : A -> B) : map f [] = [].
Proof. simpl; auto. Qed.

Lemma mat_sumR_cons:
  forall (A B: matrix) av bv,
  forall (Hlen : length A = length B),
  mat_sumR (av :: A) (bv :: B) = vec_sumR av bv :: mat_sumR A B.
Proof. induction A; destruct B; (intros; unfold mat_sum, vec_sum, map2; simpl; auto). Qed.

Lemma mat_sumR_zero:
  forall (B : matrix) (n : nat)
  (Hin : forall row, In row B -> length row  = n),
  mat_sum B (zero_matrix (length B) n 0%R) Rplus = B.
Proof.
intros ? ? ?. induction B; auto.
fold (mat_sumR (a :: B) (zero_matrix (length (a :: B)) n 0)).
fold (mat_sumR B (zero_matrix (length B) n 0)) in IHB.
simpl; rewrite mat_sumR_cons.
rewrite <- IHB; [ f_equal | intros; apply Hin; simpl; auto].
rewrite <- vec_sum_zeroR; unfold vec_sumR; repeat f_equal.
symmetry; apply Hin; simpl; auto.
repeat f_equal; apply IHB; intros; apply Hin; simpl; auto.
rewrite zero_matrix_length; auto.
Qed.

Lemma mat_sum_nil {A : Type} M (f: A -> A -> A) :
  mat_sum M [] f = [].
Proof. destruct M; auto. Qed.

Lemma zero_map_mat_length {A B: Type} :
  forall (M : @matrix A) (z : B), length (zero_map_mat z M) = length M.
Proof.
intros; induction M; [simpl; auto | simpl; rewrite IHM; auto ].
Qed.

Lemma vec_sumR_bounds a b a' b':
a' + b' :: vec_sumR a b =  vec_sumR (a' :: a) (b' :: b).
Proof. unfold vec_sumR; simpl; auto. Qed.

Lemma vec_sumR_opp :
forall u v,
length u = length v ->
vec_sum u v Rminus = vec_sum u (map Ropp v) Rplus.
Proof.
intros ?.
induction u.
{ intros; simpl; auto. }
intros; destruct v; simpl; auto.
rewrite vec_sumR_cons.
rewrite <- IHu; auto.
Qed.

Lemma vec_sumR_comm :
forall u v ,
length u = length v ->
vec_sumR u v = vec_sumR v u.
Proof.
intros ?.
induction u.
{ intros. simpl in H; symmetry in H; apply length_zero_iff_nil in H; subst;
simpl; auto. }
intros; destruct v; auto.
unfold vec_sumR; rewrite !vec_sumR_cons.
fold (vec_sumR v u);
fold (vec_sumR u v).
rewrite <- IHu. rewrite Rplus_comm; auto.
simpl in H; auto.
Qed.

Lemma vec_sumR_assoc :
forall u v w,
length u = length v ->
length w = length v ->
vec_sumR (vec_sumR u v) w = vec_sumR u (vec_sumR v w).
Proof.
intros ?.
induction u.
{ intros. simpl in H; symmetry in H; apply length_zero_iff_nil in H; subst;
simpl; auto. }
intros; destruct v; simpl; auto.
destruct w; unfold vec_sumR; simpl; auto.
unfold vec_sumR; rewrite !vec_sumR_cons.
fold (vec_sumR v w).
fold (vec_sumR u v).
simpl in H, H0.
fold (vec_sumR (vec_sumR u v) w);
rewrite IHu; [rewrite Rplus_assoc; auto  | lia | lia ].
Qed.

Lemma vec_sumR_minus :
forall u ,
vec_sumR (map Ropp u) u = (zero_vector (length u) 0%R).
Proof.
intros; induction u.
{ simpl; auto. }
unfold vec_sumR; simpl; rewrite !vec_sumR_cons.
fold (vec_sumR (map Ropp u) u).
rewrite IHu; f_equal; nra.
Qed.

Lemma vec_sum_length {A : Type} :
forall u v (f : A -> A -> A) ,
length u = length v ->
length u = length (vec_sum u v f).
Proof.
intros ?; induction u.
{ simpl; auto. }
intros; destruct v; simpl; auto.
specialize (IHu v f); rewrite IHu.
unfold vec_sum; auto.
simpl in H; auto.
Qed.

Lemma vec_sum_length2  {A B: Type} (f : B -> B-> B) :
forall (u : list A) v w,
length u = length v ->
length v = length w ->
length u = length (vec_sum v w f).
Proof.
intros ?;
induction u.
{ intros. simpl in H; symmetry in H; apply length_zero_iff_nil in H; subst;
simpl; auto. }
intros; destruct v; simpl; auto.
destruct w. { simpl in H0;  discriminate. }
simpl; auto.
specialize (IHu v w); rewrite IHu.
unfold vec_sum; auto.
simpl in H; auto.
simpl in H; auto.
Qed.

Lemma nth_app_0 {T : Type} :
forall (l0 l : list T),
l0 <> [] ->
nth 0 (l0 ++ l) = nth 0 l0.
Proof.
intros.
induction l0; auto.
simpl. assert False by auto; contradiction.
Qed.

Lemma matrix_index_nil {A} (i j: nat) (zero: A) :
   matrix_index [] i j zero = zero.
Proof. unfold matrix_index. destruct i; destruct j; simpl; auto. Qed.

Lemma vec_sumR_nth :
forall j u a
(Hlen: length a = length u),
nth j u 0%R - nth j a 0%R = nth j (vec_sum u a Rminus) 0%R.
Proof.
induction j; destruct u; intros.
{ simpl; apply length_zero_iff_nil in Hlen; subst; simpl; nra. }
{ destruct a; try discriminate; auto. }
{ destruct a; simpl; [nra | try discriminate; auto]. }
destruct a; try discriminate; auto.
assert (length a = length u) by (simpl in Hlen; lia);
specialize (IHj u a H);
simpl; auto.
Qed.

Lemma nth_cons_vec_sumR a l r u2 : forall i,
  nth i ((l) +v (u2)) 0 = nth i (l) 0 + nth i ( u2) 0 ->
  nth (S i) ((a :: l) +v (r :: u2)) 0 = nth (S i) (a :: l) 0 + nth (S i) (r :: u2) 0.
Proof. intros; simpl; auto. Qed.

Lemma nth_cons_mvR b B u : forall i,
  nth (S i) ( (b::B) *r u) = nth i (B *r u).
Proof. intros; simpl; auto. Qed.

Lemma length_mvR_mvF {NANS : Nans} {t : type} : forall (m : @matrix (ftype t)) v,
length ((map_mat FT2R m) *r (map FT2R v)) = length (m *fr v).
Proof.
  intros.
  unfold mvR, mvF, map_mat.
rewrite !map_length; auto.
Qed.

Lemma nth_vec_sum op : forall u1 u2
  (Hlen: length u2 = length u1) i
  (Hop : op 0 0 = 0),
  nth i (vec_sum u1 u2 op) 0 = op (nth i u1 0) (nth i u2 0).
Proof.
induction u1. intros.
rewrite length_zero_iff_nil in Hlen.
subst. simpl. destruct i; auto.
destruct u2; try discriminate. intros.
simpl; destruct i; auto.
rewrite <- IHu1; auto.
Qed.

Lemma vec_sum_nth_plus : forall u1 u2
(Hlen: length u2 = length u1) i,
nth i (u1 +v u2) 0 = nth i u1 0 + nth i u2 0.
Proof.
induction u1. intros.
rewrite length_zero_iff_nil in Hlen.
subst. destruct i; simpl; ring.
destruct u2; intros.
destruct i; try discriminate.
destruct i; simpl; try ring.
apply IHu1. simpl in Hlen; lia.
Qed.

End MVLems.


Set Warnings "-local-declaration".

Require Import
  Coq.Unicode.Utf8
  Coq.Classes.Morphisms
  Coq.Setoids.Setoid.

(***********************************************************************
 * This is a minimal Boolean Logic comprised of ∨, ¬ and three axioms. *)

Module Type MinimalBooleanLogic.

Parameter t : Type.             (* The type of boolean propositions *)

(** These three terms are syntactic and can be defined in terms of the
    fundamentals above. They are given as parameters so that module authors
    may chose economical definitions; we also provides implies as a relation
    in Prop to facilitate use of Coq's rewriting system. *)
Parameter implies : t -> t -> Prop.
Parameter true    : t.
Parameter false   : t.

#[global]
Declare Instance implies_Reflexive : Reflexive implies.
#[global]
Declare Instance implies_Transitive : Transitive implies.

(** The following are fundamental to a classical definition of this logic. *)
Parameter not : t -> t.
Parameter or  : t -> t -> t.

#[global]
Declare Instance not_respects_implies : Proper (implies --> implies) not.
#[global]
Declare Instance or_respects_implies : Proper (implies ==> implies ==> implies) or.

#[global]
Declare Scope boolean_scope.
Bind Scope boolean_scope with t.
Delimit Scope boolean_scope with boolean.
Open Scope boolean_scope.

Notation "¬ p"   := (not p)   (at level 75, right associativity) : boolean_scope.
Infix    "∨"     := or        (at level 85, right associativity) : boolean_scope.
Notation "p ⇒ q" := (¬ p ∨ q) (at level 86, right associativity) : boolean_scope.
Notation "⊤"     := true      (at level 0, no associativity) : boolean_scope.
Notation "⊥"     := false     (at level 0, no associativity) : boolean_scope.

Definition equivalent p q := implies p q /\ implies q p.

Infix "⟹" := implies    (at level 99, right associativity) : boolean_scope.
Infix "≈"  := equivalent (at level 90, no associativity) : boolean_scope.

(** This is one set of fundamental axioms of boolean algebra.
 *
 * NOTE: It is possible to formulate the following using a single axiom:
 *
 *   ∀ p q r s,
 *     ¬(¬(¬(p ∨ q) ∨ r) ∨ ¬(p ∨ ¬(¬r ∨ ¬(r ∨ s)))) ≈ r
 *
 * However, the proofs of the three axioms below in terms of this single one
 * are laborious and left as an exercise to the motivated reader. Further
 * notes may be found in the paper "Short Single Axioms for Boolean Algebra"
 * by McCune, et al. *)
Axiom or_comm    : ∀ p q,   p ∨ q ≈ q ∨ p.
Axiom or_assoc   : ∀ p q r, (p ∨ q) ∨ r ≈ p ∨ (q ∨ r).
Axiom huntington : ∀ p q,   ¬(¬p ∨ ¬q) ∨ ¬(¬p ∨ q) ≈ p.

(** These axioms establish the meaning of the syntactic terms. *)
Axiom or_inj      : ∀ p q,  p ⟹ p ∨ q.
Axiom true_def    : ∀ p,    p ∨ ¬p ≈ ⊤.
Axiom false_def   : ∀ p,    ¬(p ∨ ¬p) ≈ ⊥.

End MinimalBooleanLogic.

Module MinimalBooleanLogicFacts (Import B : MinimalBooleanLogic).

#[global]
Program Instance equivalent_Equivalence : Equivalence equivalent.
Next Obligation. now intro x; split. Qed.
Next Obligation. repeat intro; split; destruct H; now intuition. Qed.
Next Obligation. repeat intro; split; destruct H, H0; now transitivity y. Qed.

#[global]
Program Instance implies_respects_implies :
  Proper (implies --> implies ==> Basics.impl) implies.
Next Obligation.
  repeat intro.
  unfold Basics.flip in H.
  now rewrite <- H0, <- H1.
Qed.

#[global]
Program Instance implies_respects_equivalent :
  Proper (equivalent ==> equivalent ==> iff) implies.
Next Obligation.
  repeat intro.
  destruct H, H0.
  split; intros.
  - now rewrite H1, H3, H0.
  - now rewrite <- H2, <- H3, <- H.
Qed.

#[global]
Program Instance equivalent_respects_equivalent :
  Proper (equivalent ==> equivalent ==> iff) equivalent.
Next Obligation.
  repeat intro.
  split; intros.
  - now rewrite <- H, H1, H0.
  - now rewrite H, H1, <- H0.
Qed.

#[global]
Program Instance not_respects_equivalent :
  Proper (equivalent ==> equivalent) not | 9.
Next Obligation.
  repeat intro.
  destruct H.
  split; intros.
  - now rewrite H0.
  - now rewrite H.
Qed.

#[global]
Program Instance or_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) or.
Next Obligation.
  repeat intro.
  destruct H, H0.
  split.
  - now rewrite H, H0.
  - now rewrite H1, H2.
Qed.

Ltac one_arg :=
  repeat intro;
  match goal with
    [ H : _ ≈ _ |- _ ≈ _ ] =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    destruct H as [H1 H2]; split;
    first [ now rewrite H1
          | now rewrite H2 ]
  end.

Ltac two_arg :=
  repeat intro;
  match goal with
    [ HA : _ ≈ _, HB : _ ≈ _ |- _ ≈ _ ] =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    let H3 := fresh "H" in
    let H4 := fresh "H" in
    destruct HA as [H1 H2], HB as [H3 H4]; split;
    first [ now rewrite H1, H3
          | now rewrite H2, H4 ]
  end.

#[local] Obligation Tactic := solve [ one_arg | two_arg ].

Theorem or_inj_r p q : p ⟹ q ∨ p.
Proof.
  rewrite or_comm.
  now apply or_inj.
Qed.

Theorem true_impl p : (⊤ ⟹ p) <-> p ≈ ⊤.
Proof.
  split; intro.
  - split; auto.
    rewrite <- (true_def p).
    now apply or_inj.
  - now rewrite H.
Qed.

Theorem impl_true p : p ⟹ ⊤.
Proof.
  rewrite <- (true_def p).
  now apply or_inj.
Qed.

(** Many of the following proofs are based on work from:
    "A Complete Proof of the Robbins Conjecture", by Allen L. Mann
    May 25, 2003 *)
Theorem or_not p : p ∨ ¬p ≈ ¬p ∨ ¬¬p.
Proof.
  pose proof (huntington p (¬¬ p)) as H1.
  pose proof (huntington (¬ p) (¬¬ p)) as H2.
  pose proof (huntington (¬ p) (¬ p)) as H3.
  pose proof (huntington (¬¬ p) (¬ p)) as H4.
  rewrite <- H4.
  rewrite <- H3 at 2.
  rewrite <- H2 at 1.
  rewrite <- H1 at 1.
  rewrite <- !or_assoc.
  rewrite (or_comm _ (¬ (¬ ¬ ¬ p ∨ ¬ p))).
  rewrite !or_assoc.
  apply or_respects_equivalent.
    now rewrite or_comm.
  rewrite <- !or_assoc.
  rewrite (or_comm _ (¬ (¬ ¬ p ∨ ¬ ¬ p))).
  rewrite !or_assoc.
  apply or_respects_equivalent.
    reflexivity.
  apply or_respects_equivalent.
    now rewrite or_comm.
  now rewrite or_comm.
Qed.

Theorem not_not p : ¬¬p ≈ p.
Proof.
  pose proof (huntington (¬¬ p) (¬ p)) as H1.
  pose proof (huntington p (¬¬ p)) as H2.
  rewrite <- H1.
  rewrite (or_comm _ (¬¬p)), <- or_not.
  rewrite or_comm.
  rewrite (or_comm _ (¬p)).
  now apply huntington.
Qed.

Theorem contrapositive p q : (p ⟹ q) <-> (¬q ⟹ ¬p).
Proof.
  split; intro.
  - rewrite H.
    reflexivity.
  - apply not_respects_implies in H.
    now rewrite !not_not in H.
Qed.

Theorem not_swap p q : ¬p ≈ q <-> p ≈ ¬q.
Proof.
  split; intro.
  - rewrite <- not_not.
    now rewrite H.
  - rewrite H.
    now apply not_not.
Qed.

Theorem not_inj p q : ¬p ≈ ¬q -> p ≈ q.
Proof.
  intro.
  rewrite <- (not_not p).
  rewrite <- (not_not q).
  now rewrite H.
Qed.

Theorem not_true : ¬⊤ ≈ ⊥.
Proof. now rewrite <- (true_def ⊥), false_def. Qed.

Theorem not_false : ¬⊥ ≈ ⊤.
Proof.
  rewrite <- (false_def ⊤), true_def.
  now apply not_not.
Qed.

Theorem or_false p : p ∨ ⊥ ≈ p.
Proof.
  pose proof (huntington ⊥ ⊥) as H1.
  rewrite (or_comm _ ⊥) in H1.
  rewrite false_def in H1.
  rewrite !not_false in H1.
  assert (H2 : ⊤ ∨ ¬(⊤ ∨ ⊤) ≈ ⊤).
    rewrite <- (true_def ⊤) at 1.
    rewrite or_assoc.
    rewrite (or_comm (¬⊤)).
    rewrite not_true at 1.
    rewrite H1.
    rewrite <- not_true.
    now apply true_def.
  assert (H3 : ⊤ ∨ ⊤ ≈ ⊤).
    rewrite <- H2 at 2.
    rewrite <- or_assoc.
    now apply true_def.
  assert (H4 : ⊥ ∨ ⊥ ≈ ⊥).
    rewrite <- not_true at 1.
    rewrite <- not_true at 1.
    rewrite <- H3 at 1.
    rewrite not_true.
    exact H1.
  rewrite <- (huntington p p) at 2.
  rewrite (or_comm _ p).
  rewrite false_def.
  rewrite <- H4 at 2.
  rewrite <- (false_def p) at 2.
  rewrite <- or_assoc.
  rewrite (or_comm p (¬p)).
  now rewrite huntington.
Qed.

Theorem false_or p : ⊥ ∨ p ≈ p.
Proof. now rewrite or_comm; apply or_false. Qed.

Theorem or_idem p : p ∨ p ≈ p.
Proof.
  assert (H1 : ∀ q, ¬ (¬ q ∨ ¬ q) ≈ q).
    intro q.
    rewrite <- (huntington q q) at 3.
    rewrite (or_comm (¬q) q).
    rewrite false_def.
    now rewrite or_false.
  specialize (H1 (¬p)).
  rewrite not_not in H1.
  apply not_inj.
  exact H1.
Qed.

Theorem or_true p : p ∨ ⊤ ≈ ⊤.
Proof.
  rewrite <- (true_def p) at 1.
  rewrite <- or_assoc.
  rewrite or_idem.
  now apply true_def.
Qed.

Theorem true_or p : ⊤ ∨ p ≈ ⊤.
Proof. now rewrite or_comm; apply or_true. Qed.

(** Either this or or_inj must be taken as an axiom *)
Theorem impl_implies : ∀ p q, (p ⟹ q) <-> (⊤ ⟹ p ⇒ q).
Proof.
  split; intros.
  - rewrite <- H.
    (* rewrite impl_def. *)
    rewrite or_comm.
    rewrite true_def.
    reflexivity.
  - rewrite <- (huntington p q).
    (* rewrite impl_def in H. *)
    rewrite <- H.
    rewrite not_true.
    rewrite or_false.
    apply contrapositive.
    rewrite not_not.
    rewrite or_comm.
    now apply or_inj.
Qed.

Theorem false_impl p : ⊥ ⟹ p.
Proof.
  rewrite <- (false_def p).
  apply contrapositive.
  rewrite not_not.
  rewrite or_comm.
  now apply or_inj.
Qed.

End MinimalBooleanLogicFacts.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor.

(**
Opposite of a functor F : C -> D is a functor F^op : C^op -> D^op with the same object and arrow maps.
 *)
Section Opposite_Functor.
  Context {C D : Category} (F : (C –≻ D)%functor).

  Local Open Scope morphism_scope.
  Local Open Scope object_scope.

  Program Definition Opposite_Functor : (C^op –≻ D^op)%functor :=
    {|
      FO := F _o;
      FA := fun _ _ h => F @_a _ _ h;
      F_id := fun a => F_id F a;
      F_compose := fun _ _ _ f g => F_compose F g f
    |}.

End Opposite_Functor.

Notation "F '^op'" := (Opposite_Functor F) : functor_scope.

(* We can compose functors. The object and arrow maps are simply function compositions of object and arrow maps. *)
Section Functor_Compose.
  Context {C C' C'' : Category} (F : (C –≻ C')%functor) (F' : (C' –≻ C'')%functor).

  Local Open Scope morphism_scope.
  Local Open Scope object_scope.

  Program Definition Functor_compose : (C –≻ C'')%functor :=
    {|
      FO := fun c => F' _o (F _o c);
      FA := fun c d f => F' _a (F _a f)
    |}.

End Functor_Compose.

Notation "F ∘ G" := (Functor_compose G F) : functor_scope.

(** Associativity of functor composition *)
Section Functor_Assoc.
  Context {C1 C2 C3 C4 : Category}
          (F : (C1 –≻ C2)%functor)
          (G : (C2 –≻ C3)%functor)
          (H : (C3 –≻ C4)%functor).

  Local Open Scope functor_scope.

  Theorem Functor_assoc : (H ∘ G) ∘ F = H ∘ (G ∘ F).
  Proof.
    Func_eq_simpl; trivial.
  Defined.

End Functor_Assoc.

(** The identitiy functor *)

Program Definition Functor_id (C : Category) : (C –≻ C)%functor :=
  {|
    FO := fun x => x;
    FA := fun c d f => f
  |}.

Section Functor_Identity_Unit.
  Context  (C C' : Category) (F : (C –≻ C')%functor).

  (** Fucntor_id is the left ididntity of functor composition. *)
  Theorem Functor_id_unit_left : ((Functor_id C') ∘ F)%functor = F.
  Proof.
    Func_eq_simpl; trivial.
  Defined.

  (** Functor_id is the right identity of functor composition. *)
  Theorem Functor_id_unit_right : (Functor_compose (Functor_id _) F) = F.
  Proof.
    Func_eq_simpl; trivial.
  Defined.

End Functor_Identity_Unit.


(* Enumerated types *)
Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.

(* Booleans *)
Inductive bool : Type :=
  | true
  | false.

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

Definition andb (b1 b2 : bool) : bool :=
  match b1 with
  | true  => b2
  | false => false
  end.

Definition orb (b1 b2 : bool) :=
  match b1 with
  | true  => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1 b2 : bool) : bool :=
  negb (b1 && b2).

Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

Definition andb3 (b1 b2 b3 : bool) : bool :=
  b1 && b2 && b3.

Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.

Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.

Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.

Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.

Check true.

Check true
    : bool.

Check (negb true)
    : bool.

Check negb
    : bool -> bool.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black     => true
  | white     => true
  | primary _ => false
  end.

Definition is_red (c : color) : bool :=
  match c with
  | primary red => true
  | _           => false
  end.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Check Playground.b.

Module TuplePlayground.

Inductive bit : Type :=
  | B0
  | B1.

Inductive nybble : Type :=
  | bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B1 B0)
    : nybble.

Definition all_zero (nb : nybble) : bool :=
  match nb with
  | bits B0 B0 B0 B0 => true
  | bits _ _ _ _     => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).

Compute (all_zero (bits B0 B0 B0 B0)).

End TuplePlayground.

Module NatPlayground.

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

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

End NatPlayground.

Check (S (S (S (S O)))).

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

Compute (minustwo 4).

Check S.

Check pred : nat -> nat.

Check minustwo : nat -> nat.

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

Definition oddb (n : nat) : bool :=
  negb (evenb n).

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

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

Compute (plus 3 2).

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

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

End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O   => S O
  | S p => mult base (exp base p)
  end.

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

Definition factorial (n : nat) : nat :=
  fact_tr n 1.

Example test_factorial1: (factorial 3) = 6.
Proof. reflexivity. Qed.

Example test_factorial2: (factorial 5) = 120.
Proof. reflexivity. Qed.

Notation "x + y" := (plus x y)
                        (at level 50, left associativity)
                        : nat_scope.

Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.

Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

Check ((0 + 1) + 1) : nat.

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

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

Example test_leb1: leb 2 2 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 2 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 2 = false.
Proof. simpl. reflexivity. Qed.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Example test_leb3': (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
  leb (S n) m.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. reflexivity. Qed.

Example test_ltb2: (ltb 2 4) = true.
Proof. reflexivity. Qed.

Example test_ltb3: (ltb 4 2) = false.
Proof. reflexivity. Qed.

(* Proof by simplification *)
Theorem plus_O_n : forall n : nat,
  0 + n = n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem plus_1_l : forall n : nat,
  1 + n = S n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem mult_0_l : forall n : nat,
0 * n = 0.
Proof.
  intros n.
  reflexivity.
Qed.

(* Proof by rewrite *)
Theorem plus_id_example : forall n m : nat,
  n = m ->
  n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m ->
  m = o ->
  n + m = m + o.
Proof.
  intros n m o.
  intros H0.
  rewrite -> H0.
  intros H1.
  rewrite <- H1.
  reflexivity.
Qed.

Check mult_n_O.
(* 0 = n * 0 *)

Check mult_n_Sm.
(* n * m + n = n * S m *)

Theorem mult_n_0_m_0 : forall n m : nat,
  (n * 0) + (m * 0) = 0.
Proof.
  intros n m.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity.
Qed.

Theorem mult_n_1 : forall n : nat,
  n * 1 = n.
Proof.
  intros n.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity.
Qed.

(* Proof by case analysis *)
Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  destruct n.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative : forall b1 b2 : bool,
  andb b1 b2 = andb b2 b1.
Proof.
  intros b1 b2.
  destruct b1.
  - destruct b2.
    + reflexivity.
    + reflexivity.
  - destruct b2.
    + reflexivity.
    + reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem andb_true_elim2 : forall n m : bool,
  andb n m = true -> m = true.
Proof.
  intros.
  destruct n.
  - simpl in H. apply H.
  - simpl in H. destruct m.
    + reflexivity.
    + apply H.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros n.
  destruct n.
  - reflexivity.
  - reflexivity.
Qed.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall x : bool, f x = x) ->
  forall b : bool, f (f b) = b.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall x : bool, f x = negb x) ->
  forall b : bool, f (f b) = b.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H.
  apply negb_involutive.
Qed.

Theorem andb_eq_orb : forall b c : bool,
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros .
  destruct b.
  - simpl in H. rewrite -> H. reflexivity.
  - simpl in H. apply H.
Qed.

Inductive bin : Type :=
  | Z  : bin
  | B0 : bin -> bin
  | B1 : bin -> bin.

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z     => B1 Z
  | B0 m' => B1 m'
  | B1 m' => B0 (incr m')
  end.

Example test_bin_inrc1: (incr (B1 Z)) = B0 (B1 Z).
Proof. reflexivity. Qed.

Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. reflexivity. Qed.

Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. reflexivity. Qed.

Fixpoint bin_to_nat (m : bin) : nat :=
  match m with
  | Z     => 0
  | B0 m' => 2 * bin_to_nat m'
  | B1 m' => 1 + 2 * bin_to_nat m'
  end.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint double (double_arg0 : Nat) : Nat
           := match double_arg0 with
              | zero => zero
              | succ n => succ (succ (double n))
              end.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : Nat
           := match len_arg0 with
              | nil => zero
              | cons x y => succ (len y)
              end.

Lemma lem : forall l1 l2 n, succ (len (append l1 l2)) = len (append l1 (cons n l2)).
Proof.
   induction l1.
   - intros. simpl. f_equal. apply IHl1.
   - intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst), eq (len (append x x)) (double (len x)).
Proof.
induction x.
   - simpl. rewrite <- IHx. f_equal. rewrite (lem x x n). reflexivity.
   - reflexivity.
Qed.


Require Export P01.

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intros n. induction n.
  - reflexivity.
  - simpl. rewrite <- IHn. reflexivity.
Qed.

Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intros n. induction n.
  - intros m. simpl. destruct m.
    + reflexivity.
    + intros H. inversion H.
  - intros m. simpl. induction m.
    + intros H. inversion H.
    + intros H. apply IHn in H. rewrite H. reflexivity.
Qed.

Theorem beq_nat_true_iff : forall n1 n2 : nat,
  beq_nat n1 n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply beq_nat_true.
  - intros H. rewrite H. rewrite <- beq_nat_refl. reflexivity.
Qed.

Theorem beq_nat_false_iff : forall x y : nat,
  beq_nat x y = false <-> x <> y.
Proof.
  intros x y. unfold not. split.
  - (* -> *) intros H0 H1. apply beq_nat_true_iff in H1. rewrite H1 in H0. inversion H0.
  - (* <- *) intros H. induction x as [| x'].
    + induction y as [| y'].
      { exfalso. apply H. reflexivity. }
      { generalize dependent y'. auto. }
    + induction y as [| y'].
      { generalize dependent x'. auto. }
      { simpl. destruct (beq_nat x' y') eqn:Heq.
        - exfalso. apply H. apply f_equal. apply beq_nat_true_iff. apply Heq.
        - reflexivity. }
Qed.

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  destruct contra.  Qed.

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - (* b = true *)
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  - (* b = false *)
    reflexivity.
Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros b. split.
  - (* -> *) apply not_true_is_false.
  - (* <- *) intros H. rewrite H. intros H'. inversion H'.
Qed.

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros. unfold t_update. apply functional_extensionality.
  intros x. destruct (beq_id x1 x) eqn: H1.
  - apply beq_id_true_iff in H1. rewrite <- H1. rewrite <- beq_id_false_iff in H.
    rewrite H. reflexivity.
  - reflexivity.
Qed.


Require Import Coq.Classes.Morphisms Coq.Program.Program Coq.Unicode.Utf8.

(* First, two ways to do quoting in the naive scenario without
 holes/variables in the expression: *)

Module simple.
  (* An example term language and evaluation: *)
  Inductive Expr := Plus (a b: Expr) | Mult (a b: Expr) | Zero | One.

  Fixpoint eval (e: Expr): nat :=
    match e with
    | Plus a b => eval a + eval b
    | Mult a b => eval a * eval b
    | Zero => 0
    | One => 1
    end.

  (* First up is the simplest approach I can think of. *)
  Module approach_A.
    Class Quote (n: nat) := quote: Expr.

    Arguments quote _ {Quote}.

    Section instances.

      Context n m `{Quote n} `{Quote m}.

      Global Instance: Quote 0 := Zero.
      Global Instance: Quote 1 := One.
      Global Instance: Quote (n + m) := Plus (quote n) (quote m).
      Global Instance: Quote (n * m) := Mult (quote n) (quote m).

    End instances.

    Ltac do_quote :=
      match goal with
      |- (?a = ?b) => change (eval (quote a) = eval (quote b))
      end.

    Lemma example: (1 + 0 + 1) * (1 + 1) = (1 + 1) + (1 + 1).
     do_quote.
    Admitted.
  End approach_A.

  (* This works, but there's something unsatisfying about this quotation, because
  the actual Quote instances are not validated until we get to the [change] tactic,
  which validates the quotation by requiring convertibility.

  Next, we show an alternative implementation where the Quote instances
  are all proved locally correct at their definition: *)

  Module approach_B.
    Class Quote (n: nat) := { quote: Expr; eval_quote: n = eval quote  }.

    Arguments quote _ {Quote}.
    Arguments eval_quote _ {Quote}.

    Section instances.

      Context n m `{Quote n} `{Quote m}.

      Global Program Instance: Quote 0 := { quote := Zero }.
      Global Program Instance: Quote 1 := { quote := One }.

      Global Instance: Quote (n + m).
      Proof.
      refine {| quote := Plus (quote n) (quote m) |}.
      simpl. do 2 rewrite <- eval_quote. reflexivity.
      Qed.

      Global Instance: Quote (n * m).
      Proof.
      refine {| quote := Mult (quote n) (quote m) |}.
      simpl. do 2 rewrite <- eval_quote. reflexivity.
      Qed.

    End instances.

    Lemma do_quote {n m} `{Quote n} `{Quote m}: eval (quote n) = eval (quote m) → n = m.
    Proof. intros. rewrite (eval_quote n), (eval_quote m). assumption. Qed.

    Lemma example: (1 + 0 + 1) * (1 + 1) = (1 + 1) + (1 + 1).
     apply do_quote.
    Admitted.
  End approach_B.
End simple.

(* So far so good, but the variable-less scenario isn't really interesting. We now rework approach B
 to include quotation of holes/variables, including recognition of syntactically identical ones. *)

Module with_vars.
(* Some random utilities: *)

Lemma sum_assoc {A B C}: (A+B)+C → A+(B+C). intuition. Defined.
Lemma bla {A B C}: (A+B) → A+(B+C). intuition. Defined.
Lemma monkey {A B}: False + A → A + B. intuition. Defined.

Section obvious.
  Class Obvious (T: Type) := obvious: T.

  Context (A B C: Type).

  Global Instance: Obvious (A → A) := id.
  Global Instance: Obvious (False → A) := False_rect _.
  Global Instance: Obvious (A → A + B) := inl.
  Global Instance: Obvious (A → B + A) := inr.
  Global Instance obvious_sum_src  `{Obvious (A → C)} `{Obvious (B → C)}: Obvious (A+B → C). repeat intro. intuition. Defined.
  Global Instance obvious_sum_dst_l `{Obvious (A → B)}: Obvious (A → B+C). repeat intro. intuition. Defined.
  Global Instance obvious_sum_dst_r `{Obvious (A → B)}: Obvious (A → C+B). repeat intro. intuition. Defined.
End obvious.

(* Again our example term language, this time without plus/one (they're boring), but with Var
 added: *)

Inductive Expr (V: Type) := Mult (a b: Expr V) | Zero | Var (v: V).

Arguments Var {V}.
Arguments Zero {V}.
Arguments Mult {V}.

(*
Require Import monads canonical_names.

Instance: MonadReturn Expr := fun _ => Var.

Instance expr_bind: MonadBind Expr := fun A B =>
  fix F (m: Expr A) (f: A → Expr B): Expr B :=
    match m with
    | Zero => Zero
    | Mult x y => Mult (F x f) (F y f)
    | Var v => f v
    end.

Section eqs.

  Context `{e: Equiv A} `{Equivalence _ e}.

  Global Instance expr_eq: Equiv (Expr A) :=
    fix F (x y: Expr A) :=
      match x, y with
      | Var v, Var w => v = w
      | Mult v w, Mult p q => F v p ∧ F w q
      | Zero, Zero => True
      | _, _ => False
      end.

  Instance: Reflexive expr_eq.
  Proof. intro. induction x; simpl; intuition. Qed.

  Instance: Symmetric expr_eq.
  Proof. intro. induction x; destruct y; simpl in *; intuition. Qed.

  Instance: Transitive expr_eq.
  Admitted.

  Global Instance expr_equivalence: Equivalence expr_eq.

End eqs.

Instance: ∀ `{Equiv A}, Proper ((=) ==> (=)) (ret Expr).
 repeat intro.
 assumption.
Qed.

Instance bind_proper: ∀ `{Equiv A} `{Equiv B},
 Proper ((=) ==> pointwise_relation A (=) ==> (=)) (@expr_bind A B).
Proof.
 intros A H B H0 x y E.
(*
 induction x.
  destruct y; intuition.
  intros f g E'.
  simpl.
  red.
  simpl.
  split.
   red in E.
   simpl in E.

   apply IHx2.

  simpl in *.

 unfold expr_bind.

 simpl.
*)
Admitted.

Instance: Monad Expr.
  *)

(* The expression type is parameterized over the set of variable indices. Hence, we diverge
 from Claudio, who uses nat indices for variables, thereby introducing bounds problems and
 dummy variables and other nastiness. *)

(* An expression is only meaningful in the context of a variable assignment: *)

Definition Value := nat.
Definition Vars V := V → Value.

Fixpoint eval {V} (vs: Vars V) (e: Expr V): Value :=
  match e with
  | Zero => 0
  | Mult a b => eval vs a * eval vs b
  | Var v => vs v
  end.

#[global]
Instance eval_proper V: Proper (pointwise_relation _ eq ==> eq ==> eq) (@eval V).
Proof.
 repeat intro. subst.
 induction y0; simpl.
   congruence.
  reflexivity.
 apply H.
Qed.

(* Some simple combinators for variable packs: *)

Definition novars: Vars False := False_rect _.
Definition singlevar (x: Value): Vars unit := fun _ => x.
Definition merge {A B} (a: Vars A) (b: Vars B): Vars (A+B) :=
  fun i => match i with inl j => a j | inr j => b j end.

(* These last two combinators are the "constructors" of an implicitly defined subset of
 Gallina terms (representing Claudio's "heaps") for which we implement syntactic
 lookup with type classes: *)

Section Lookup.
  (* Given a heap and value, Lookup instances give the value's index in the heap: *)

  Class Lookup {A} (x: Value) (f: Vars A) := { lookup: A; lookup_correct: f lookup = x }.

  Global Arguments lookup {A} _ _ {Lookup}.

  Context (x: Value) {A B} (va: Vars A) (vb: Vars B).

  (* If the heap is a merge of two heaps and we can find the value's index in the left heap,
   we can access it by indexing the merged heap: *)

  Global Instance lookup_left `{!Lookup x va}: Lookup x (merge va vb).
  Proof.
  refine {| lookup := inl (lookup x va) |}.
  apply lookup_correct.
  Defined.

  (* And vice-versa: *)

  Global Instance lookup_right `{!Lookup x vb} : Lookup x (merge va vb).
  Proof.
  refine {| lookup := inr (lookup x vb) |}.
  apply lookup_correct.
  Defined.

  (* If the heap is just a singlevar, we can easily index it. *)

  Global Program Instance: Lookup x (singlevar x) := { lookup := tt }.

  (* Note that we don't have any fallback/default instances at this point. We /will/ introduce
  such an instance for our Quote class later on, which will add a new variable to the heap
  if another Quote instance that relies on Lookup into the "current" heap fails. *)
End Lookup.

(* One useful operation we need before we get to Quote relates to variables and expression
 evaluation. As its name suggests, map_var maps an expression's variable indices. *)

Definition map_var {V W: Type} (f: V → W): Expr V → Expr W :=
  fix F (e: Expr V): Expr W :=
    match e with
    | Mult a b => Mult (F a) (F b)
    | Zero => Zero
    | Var v => Var (f v)
    end.

(* An obvious identity is: *)

Lemma eval_map_var {V W} (f: V → W) v e:
  eval v (map_var f e) = eval (v ∘ f) e.
Proof.
 induction e; simpl; try reflexivity.
 rewrite IHe1, IHe2.
 reflexivity.
Qed.

(* Finally, Quote itself: *)

Section Quote.
  (* In Quote, the idea is that V, l, and n are all "input" variables, while V' and r are "output"
  variables (in the sense that we will rely on unification to generate them. V and l represent
  the "current heap", n represents the value we want to quote, and V' and r' represent the
  heap of newly encountered variables during the quotation.
    This explains the type of quote: it is an expression that refers either to variables from
  the old heap, or to newly encountered variables.
    eval_quote is the usual correctness property, which now merges the two heaps. *)

  Class Quote {V} (l: Vars V) (n: Value) {V'} (r: Vars V') :=
    { quote: Expr (V + V')
    ; eval_quote: @eval (V+V') (merge l r) quote = n }.

  Arguments quote {V l} _ {V' r Quote}.

  (* Our first instance for Zero is easy. The "novars" in the result type reflects the fact that no new
   variables are encountered. The correctness proof is easy enough for Program. *)

  Global Program Instance quote_zero V (v: Vars V): Quote v 0 novars := { quote := Zero }.

  (* The instance for multiplication is a bit more complex. The first line is just boring
   variable declarations. The second line is important. "Quote x y z" must be read as
   "quoting y with existing heap x generates new heap z", so the second line
   basically just shuffles heaps around.
     The third line has some ugly map_var's in it because the heap shuffling must be reflected
   in the variable indices, but apart from that it's just constructing a Mult
   term with quoted subterms. *)

  Global Program Instance quote_mult V (v: Vars V) n V' (v': Vars V') m V'' (v'': Vars V'')
    `{!Quote v n v'} `{!Quote (merge v v') m v''}: Quote v (n * m) (merge v' v'') :=
      { quote := Mult (map_var bla (quote n)) (map_var sum_assoc (quote m)) }.

  Next Obligation. Proof with auto.
   destruct Quote0, Quote1.
   subst. simpl.
   do 2 rewrite eval_map_var.
   f_equal; apply eval_proper; auto; intro; intuition.
  Qed.

  (* Now follows the instance where we recognize values that are already in the heap. This
   is expressed by the Lookup requirement, which will only be fulfilled if the Lookup instances
   defined above can find the value in the heap. The novars in the [Quote v x novars] result
   reflects that this quotation does not generate new variables. *)

  Global Program Instance quote_old_var V (v: Vars V) x {i: Lookup x v}:
    Quote v x novars | 8 := { quote := Var (inl (lookup x v)) }.
  Next Obligation. Proof. apply lookup_correct. Qed.

  (* Finally, the instance for new variables. We give this lower priority so that it is only
   used if Lookup fails. *)

  Global Program Instance quote_new_var V (v: Vars V) x: Quote v x (singlevar x) | 9
    := { quote := Var (inr tt) }.
End Quote.

(* Note: Explicitly using dynamically configured variable index sets instead of plain lists
 not only removes the need for an awkward dummy value to cope with out-of-bounds
 accesses, but also means that we can prove the correctness class fields in
 Lookup/Quote without having to take the potential for out-of-bounds indexing into
 account (which would be a nightmare). *)

(* When quoting something from scratch we will want to start with an empty heap.
 To avoid having to mention this, we define quote' and eval_quote': *)

Definition quote': ∀ x {V'} {v: Vars V'} {d: Quote novars x v}, Expr _ := @quote _ _.

Definition eval_quote': ∀ x {V'} {v: Vars V'} {d: Quote novars x v},
  eval (merge novars v) quote = x
    := @eval_quote _ _ .

Arguments quote' _ {V' v d}.
Arguments eval_quote' _ {V' v d}.

(* Time for some tests! *)

Goal ∀ x y (P: Value → Prop), P ((x * y) * (x * 0)).
  intros.
  rewrite <- (eval_quote' _).
    (* turns the goal into
         P (eval some_variable_pack_composed_from_combinators quote)
    *)
  simpl quote.
Admitted.

(* We can also inspect quotations more directly: *)

Section inspect.
  Variables x y: Value.
  (* Eval compute in quote' ((x * y) * (x * 0)). *)
    (* = Mult (Mult (Var (inr (inl (inl ())))) (Var (inr (inl (inr ())))))
           (Mult (Var (inr (inl (inl ())))) Zero)
       : Expr (False + (() + () + (False + False))) *)

  (* The second occurrence of (Var (inr (inl (inl ())))) means
   the quoting has successfully noticed that it's the same
   expression. *)

  (* The two units in the generated variable index type reflect the
   fact that the expression contains two variables. *)

  (* I think adding some additional Quote instances might let us
   get rid of the False's, but at the moment I see little reason to. *)
End inspect.

(* If we want to quote an equation between two expressions we should make
 sure that the both sides refer to the same variable pack, and for that we write a
 little utility function. It does the same kind of shuffling that the mult
 Quote instance did. *)

Lemma quote_equality {V} {v: Vars V} {V'} {v': Vars V'} (l r: Value) `{!Quote novars l v} `{!Quote v r v'}:
  let heap := (merge v v') in
  eval heap (map_var monkey quote) = eval heap quote → l = r.
Proof with intuition.
 destruct Quote0 as [lq []].
 destruct Quote1 as [rq []].
 intros heap H.
 subst heap. simpl in H.
 rewrite <- H, eval_map_var.
 apply eval_proper... intro...
Qed.

Goal ∀ x y, x * y = y * x.
 intros.
 apply (quote_equality _ _).
 simpl quote.
 unfold map_var, monkey, sum_rect.
Admitted.

End with_vars.


Set Implicit Arguments.

Print nat. (* Inductive nat : Set :=  O : nat | S : nat -> nat *)
Check nat_ind.
(*
forall P : nat -> Prop,
       P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n
*)

Print nat_ind.
(*
nat_ind =
fun P : nat -> Prop => nat_rect P
     : forall P : nat -> Prop,
              P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n
*)

Print nat_rec.
(*
nat_rec =
fun P : nat -> Set => nat_rect P
     : forall P : nat -> Set,
              P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n
*)

Print nat_rect.
(*
fun (P : nat -> Type) (f : P 0) (f0 : forall n : nat, P n -> P (S n)) =>
fix F (n : nat) : P n :=
  match n as n0 return (P n0) with
    | 0 => f
    | S n0 => f0 n0 (F n0)
  end
  : forall P : nat -> Type,
    P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n
*)

Check plus_O_n. (* forall n : nat, 0 + n = n *)
Check plus_Sn_m. (* forall n m : nat, S n + m = S (n + m) *)

Theorem plus_assoc: forall x y z:nat,
  (x+y)+z = x+(y+z).
Proof.
  intros x y z. elim x. rewrite plus_O_n. rewrite plus_O_n. reflexivity.
  intros x' IH. rewrite plus_Sn_m. rewrite plus_Sn_m. rewrite plus_Sn_m.
  rewrite IH. reflexivity.
Qed.

(* defining (_ * 2) by recursion *)
Fixpoint mult2 (n:nat) : nat :=
  match n with
  | 0   => 0
  | S p => S (S (mult2 p))
  end.

Print plus.

Fixpoint mult3 (n:nat) :nat :=
  match n with
  | 0   => 0
  | S p => S (S (S (mult3 p)))
  end.
(*
plus =
fix plus (n m : nat) {struct n} : nat :=
  match n with
    | 0 => m
    | S p => S (plus p m)
  end
: nat -> nat -> nat
*)

Definition less_than_three (n:nat) : bool :=
  match n with
  | 0         => true
  | S 0       => true
  | S (S 0)   => true
  | other     => false
  end.

Eval compute in (less_than_three 0).
Eval compute in (less_than_three 1).
Eval compute in (less_than_three 2).
Eval compute in (less_than_three 3).
Eval compute in (less_than_three 4).

Fixpoint plus2 (n m : nat) : nat :=
  match m with
    | 0   => n
    | S p => S (plus2 n p)
  end.
Check plus_n_O.
Check plus_n_Sm. (* forall n m : nat, S (n + m) = n + S m *)

Theorem same_plus: forall n m : nat, plus2 n m = n + m.
Proof.
  intros n m. elim m. simpl. apply plus_n_O. clear m. intros m H. simpl.
  rewrite <- plus_n_Sm. rewrite H. reflexivity.
Qed.

Fixpoint sum_f_acc (n:nat)(f: nat->nat)(acc: nat) :nat :=
  match n with
    | 0     => acc
    | S p   => sum_f_acc p f (acc + (f p))
  end.

Definition sum_f (n:nat)(f:nat->nat) : nat := sum_f_acc n f 0.

Eval compute in (sum_f 5 (fun n => (S n)*(S n))).

Fixpoint iterate (A:Set)(f:A->A)(n:nat)(x:A){struct n} : A :=
  match n with
    | 0   => x
    | S p => f (iterate f p x)
  end.

Fixpoint two_power (n:nat) : nat :=
  match n with
    | 0   => 1
    | S p => 2 * two_power p
  end.

Eval compute in two_power 10.

Check plus_n_Sm.

Lemma mult2_n_plus_n : forall (n:nat), mult2 n = n + n.
Proof.
  intro n. elim n. simpl. reflexivity. clear n. intros n IH.
  simpl. rewrite IH. simpl. cut (S (n+n) = n + S n). intro H.
  rewrite H. reflexivity. simpl. apply plus_n_Sm.
Qed.

Fixpoint sum_n (n:nat) : nat :=
  match n with
    | 0       => 0
    | S p     => S p + sum_n p
  end.

Lemma plus_comm: forall (n m:nat), n + m = m + n.
Proof.
  intros n m. elim n. simpl. auto. clear n. intros n IH.
  simpl. rewrite IH. simpl. apply plus_n_Sm.
Qed.

Lemma sum_n_form : forall (n:nat), 2*(sum_n n) = n*(n + 1).
Proof.
  intro n. elim n. simpl. reflexivity. clear n. intros n IH.
  simpl. cut (n + sum_n n + S (n + sum_n n + 0) =  n + 1 + n * S (n + 1)).
  intro H. rewrite H. reflexivity.
  cut(n + sum_n n + S (n + sum_n n + 0) = n + (sum_n n + S (n + sum_n n + 0))).
  cut(n + 1 + n * S (n + 1) = n + (1 + n * S (n + 1))). intros H0 H1.
  rewrite H0, H1. cut (sum_n n + S (n + sum_n n + 0) = 1 + n * S (n + 1)).
  intro H2. rewrite H2. reflexivity. cut (S (n + sum_n n + 0) = sum_n n + n + 1).
  intro H3. rewrite H3. cut( sum_n n + (sum_n n + n + 1) = sum_n n + sum_n n + S n).
  intro H2. rewrite H2. cut (sum_n n + sum_n n = 2*sum_n n). intro H4. rewrite H4.
  rewrite IH. simpl. cut ( n * (n + 1) + S n = S  (n*(n+1) + n)). intro H5. rewrite H5.
  cut(n * (n + 1) + n = n * S (n + 1)). intro H6. rewrite H6. reflexivity.
  simpl. cut(forall (a b:nat), a*b + a = a*(S b)). intro H6. apply H6.
  intros a b. generalize a. elim b. auto. intro c. intro H7. auto.
  cut (S (n * (n + 1) + n) = n * (n + 1) + S n). intro H8. rewrite H8.
  reflexivity. apply plus_n_Sm. simpl. auto. cut (n + 1 = S n).
  intro H9. cut(sum_n n + n + 1 = sum_n n + (n + 1)). intro H10. rewrite H10.
  rewrite H9. rewrite plus_assoc. reflexivity. apply plus_assoc. simpl.
  cut(S n = n + 1). intro H11. rewrite H11. reflexivity. simpl.
  elim n. simpl. reflexivity. intro m. intro H12. simpl. rewrite H12.
  reflexivity. cut(forall n:nat, S n = n + 1). intro H13. rewrite H13.
  cut (n + sum_n n = sum_n n + n). intro H14. rewrite H14.
  cut( sum_n n + n + 0 = sum_n n + n). intro H15. rewrite H15. reflexivity.
  rewrite <- plus_n_O. reflexivity. apply plus_comm. intro m. elim m. simpl.
  reflexivity. clear m. intros m IH'. simpl. rewrite IH'. reflexivity.
  apply plus_assoc. apply plus_assoc.
  (* this was a complete nightmare. Obviously need automattion and use ring tactic or other *)
Qed.

Require Import Arith.

Lemma sum_n_n : forall (n:nat), n <= sum_n n.
Proof.
  intro n. elim n. simpl. apply le_n. clear n. intros n IH.
  simpl. apply le_n_S. apply le_plus_l.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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