(*|
################################
Coq: automate repeated rewriting
################################

:Link: https://stackoverflow.com/q/48139738
|*)

(*|
Question
********
|*)

Example test : forall f (n : nat), f n = n -> f (f n) = n.
Proof.
  intros f n H. repeat rewrite H. reflexivity.
Qed.

(*|
What would be a good way to further automate this? In particular, I
would like to not have to mention the name of the hypothesis anywhere.

----

**A:** ``repeat rewrite H.`` can be replaced with ``rewrite ?H.``
(rewrite zero or more times) or ``rewrite !H.`` (rewrite one or more
times)

**A:** There is also ``autorewrite`` tactics.

**Q:** Is there a way to make ``autorewrite`` consider local
hypotheses?

**A:** You can use this new `strat_rewrite tactic
<https://github.com/coq/coq/blob/2d6e395dead61a49ede6208bc40e16b4b8e68ce4/CHANGES#L1028>`__:
``Require Import Setoid. Hint Rewrite my_hint : my_db. <...>
rewrite_strat topdown <local_term>; topdown (hints my_db).``
|*)

(*|
Answer
******

If the goal can be solved with some sequence of rewrites, then the
`congruence <https://coq.inria.fr/refman/tactics.html#congruence>`__
tactic can handle it.

    The tactic ``congruence``, by Pierre Corbineau, implements the
    standard Nelson and Oppen congruence closure algorithm, which is a
    decision procedure for ground equalities with uninterpreted
    symbols. It also include the constructor theory (see 8.5.7 and
    8.5.6). If the goal is a non-quantified equality, ``congruence``
    tries to prove it with non-quantified equalities in the context.
    Otherwise it tries to infer a discriminable equality from those in
    the context. Alternatively, ``congruence`` tries to prove that a
    hypothesis is equal to the goal or to the negation of another
    hypothesis.

    ``congruence`` is also able to take advantage of hypotheses
    stating quantified equalities, you have to provide a bound for the
    number of extra equalities generated that way. Please note that
    one of the members of the equality must contain all the quantified
    variables in order for ``congruence`` to match against it.

The above basically means that ``congruence`` can solve your goal if
it can be solved using ``rewrite`` and ``discriminate`` tactics. But
sometimes ``congruence`` can't help you because it does not unfold
definitions for you -- in that case you'll have to help it.
|*)

Reset Initial. (* .none *)
Example test : forall f (n : nat), f n = n -> f (f n) = n.
Proof. congruence. Qed.


Inductive eList (a:Set) : Set :=
| Nil   : eList a
| ECons : a -> oList a -> eList a
with oList (a:Set) : Set :=
| OCons : a -> eList a -> oList a
.

Arguments Nil {a}.
Arguments ECons {a} _ _.
Arguments OCons {a} _ _.

Fixpoint eLength (a:Set) (xs:eList a) : nat :=
    match xs with
    | Nil           => O
    | ECons _ xs    => S (oLength a xs)
    end
with oLength (a:Set) (xs:oList a) : nat :=
    match xs with
    | OCons _ xs    => S (eLength a xs)
    end
.

Arguments eLength {a} _.
Arguments oLength {a} _.

Fixpoint eeAppend (a:Set) (xs ys:eList a) : eList a :=
    match xs with
    | Nil           => ys
    | ECons x xs    => ECons x (oeAppend a xs ys)
    end
with oeAppend (a:Set) (xs : oList a) (ys:eList a) : oList a :=
    match xs with
    | OCons x xs => OCons x (eeAppend a xs ys)
    end
.

Fixpoint ooAppend (a:Set) (xs ys:oList a) : eList a :=
    match xs with
    | OCons x xs    => ECons x (eoAppend a xs ys)
    end
with eoAppend (a:Set) (xs:eList a) (ys:oList a) : oList a :=
    match xs with
    | Nil           => ys
    | ECons x xs    => OCons x (ooAppend a xs ys)
    end
.

Arguments eeAppend {a} _ _.
Arguments eoAppend {a} _ _.
Arguments oeAppend {a} _ _.
Arguments ooAppend {a} _ _.

(* generate mutual induction scheme *)
Scheme eList_mut := Induction for eList Sort Prop
with oList_mut := Induction for oList Sort Prop.

(*
Check eList_mut.

eList_mut :
    forall (a : Set) (P : eList a -> Prop) (Q : oList a -> Prop),
    P Nil ->
    (forall (x : a) (xs : oList a), Q xs -> P (ECons x xs)) ->
    (forall (x : a) (xs : eList a), P xs -> Q (OCons x xs)) ->
    forall (xs : eList a), P xs
*)

(*
Check oList_mut.

oList_mut :
    forall (a : Set) (P : eList a -> Prop) (Q : oList a -> Prop),
    P Nil ->
    (forall (x : a) (xs : oList a), Q xs -> P (ECons x xs)) ->
    (forall (x : a) (xs : eList a), P xs -> Q (OCons x xs)) ->
    forall (xs : oList a), Q xs
*)

Lemma plus_n_O': forall (n:nat), plus n 0 = n.
Proof.
    apply nat_ind; simpl.
    - reflexivity.
    - intros n IH. rewrite IH. reflexivity.
Qed.

Lemma plus_n_O'': forall (n:nat), plus n 0 = n.
Proof.
    apply (nat_ind (fun n => plus n 0 = n)); simpl.
    - reflexivity.
    - intros n IH. rewrite IH. reflexivity.
Qed.

Lemma length_eeAppend : forall (a:Set) (xs ys:eList a),
    eLength (eeAppend xs ys) = plus (eLength xs) (eLength ys).
Proof.
    intros a.
    apply (eList_mut a
        (fun (xs:eList a) => forall (ys:eList a),
            eLength (eeAppend xs ys) = plus (eLength xs) (eLength ys))
        (fun (xs:oList a) => forall (ys:eList a),
            oLength (oeAppend xs ys) = plus (oLength xs) (eLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Lemma length_eoAppend : forall (a:Set) (xs:eList a) (ys:oList a),
    oLength (eoAppend xs ys) = plus (eLength xs) (oLength ys).
Proof.
    intros a.
    apply (eList_mut a
        (fun (xs:eList a) => forall (ys:oList a),
            oLength (eoAppend xs ys) = plus (eLength xs) (oLength ys))
        (fun (xs:oList a) => forall (ys:oList a),
            eLength (ooAppend xs ys) = plus (oLength xs) (oLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Lemma length_oeAppend : forall (a:Set) (xs:oList a) (ys:eList a),
    oLength(oeAppend xs ys) = plus (oLength xs) (eLength ys).
Proof.
    intros a.
    apply (oList_mut a
        (fun (xs:eList a) => forall (ys:eList a),
            eLength (eeAppend xs ys) = plus (eLength xs) (eLength ys))
        (fun (xs:oList a) => forall (ys:eList a),
            oLength (oeAppend xs ys) = plus (oLength xs) (eLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Lemma length_ooAppend : forall (a:Set) (xs:oList a) (ys:oList a),
    eLength(ooAppend xs ys) = plus (oLength xs) (oLength ys).
Proof.
    intros a.
    apply (oList_mut a
        (fun (xs:eList a) => forall (ys:oList a),
            oLength (eoAppend xs ys) = plus (eLength xs) (oLength ys))
        (fun (xs:oList a) => forall (ys:oList a),
            eLength (ooAppend xs ys) = plus (oLength xs) (oLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Fixpoint test0 (n:nat) : nat :=
    match n with
    | 0     => 0
    | S n   => test1 n
    end
with test1 (n:nat) : nat :=
    match n with
    | 0     => 0
    | S n   => test2 n
    end
with test2 (n:nat) : nat :=
    match n with
    | 0     => 0
    | S n   => test3 n
    end
with test3 (n:nat) : nat :=
    match n with
    | 0     => 0
    | S n   => test0 n
    end.

Lemma test_all : test0 7 = 0.
Proof. reflexivity. Qed.

(*
Check eList_mut.

eList_mut :
    forall (a : Set) (P : eList a -> Prop) (Q : oList a -> Prop),
    P Nil ->
    (forall (x : a) (xs : oList a), Q xs -> P (ECons x xs)) ->
    (forall (x : a) (xs : eList a), P xs -> Q (OCons x xs)) ->
    forall (xs : eList a), P xs
*)

(*
Check oList_mut.

oList_mut :
    forall (a : Set) (P : eList a -> Prop) (Q : oList a -> Prop),
    P Nil ->
    (forall (x : a) (xs : oList a), Q xs -> P (ECons x xs)) ->
    (forall (x : a) (xs : eList a), P xs -> Q (OCons x xs)) ->
    forall (xs : oList a), Q xs
*)

(* We can build these induction principle manually *)
(* First we define the general recursion principle *)
Fixpoint eList_mut_rect (a:Set)(P:eList a -> Type)(Q:oList a -> Type)
    (pnil : P Nil)
    (p:forall (x:a)(xs:oList a), Q xs -> P (ECons x xs))
    (q:forall (x:a)(xs:eList a), P xs -> Q (OCons x xs))
    (xs:eList a)
    : P xs :=
        match xs with
        | Nil           => pnil
        | ECons x xs    => p x xs (oList_mut_rect a P Q pnil p q xs)
        end
with oList_mut_rect (a:Set)(P:eList a -> Type)(Q:oList a -> Type)
    (pnil : P Nil)
    (p:forall (x:a)(xs:oList a), Q xs -> P (ECons x xs))
    (q:forall (x:a)(xs:eList a), P xs -> Q (OCons x xs))
    (xs:oList a)
    : Q xs :=
        match xs with
        | OCons x xs    => q x xs (eList_mut_rect a P Q pnil p q xs)
        end
.

(* We can specialize this recursion principle to Prop *)

Definition eList_mut_ind (a:Set)(P:eList a -> Prop)(Q:oList a -> Prop)
    (pnil: P Nil)
    (p:forall (x:a)(xs:oList a), Q xs -> P (ECons x xs))
    (q:forall (x:a)(xs:eList a), P xs -> Q (OCons x xs))
    (xs:eList a)
    : P xs := eList_mut_rect a P Q pnil p q xs.

Definition oList_mut_ind (a:Set)(P:eList a -> Prop)(Q:oList a -> Prop)
    (pnil: P Nil)
    (p:forall (x:a)(xs:oList a), Q xs -> P (ECons x xs))
    (q:forall (x:a)(xs:eList a), P xs -> Q (OCons x xs))
    (xs:oList a)
    : Q xs := oList_mut_rect a P Q pnil p q xs.

(* we can now prove all four concatenation lemmas using those *)

Lemma length_eeAppend' : forall (a:Set) (xs ys:eList a),
    eLength (eeAppend xs ys) = plus (eLength xs) (eLength ys).
Proof.
    intros a.
    apply (eList_mut_ind a
        (fun (xs:eList a) => forall (ys:eList a),
            eLength (eeAppend xs ys) = plus (eLength xs) (eLength ys))
        (fun (xs:oList a) => forall (ys:eList a),
            oLength (oeAppend xs ys) = plus (oLength xs) (eLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Lemma length_eoAppend' : forall (a:Set) (xs:eList a) (ys:oList a),
    oLength (eoAppend xs ys) = plus (eLength xs) (oLength ys).
Proof.
    intros a.
    apply (eList_mut_ind a
        (fun (xs:eList a) => forall (ys:oList a),
            oLength (eoAppend xs ys) = plus (eLength xs) (oLength ys))
        (fun (xs:oList a) => forall (ys:oList a),
            eLength (ooAppend xs ys) = plus (oLength xs) (oLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Lemma length_oeAppend' : forall (a:Set) (xs:oList a) (ys:eList a),
    oLength(oeAppend xs ys) = plus (oLength xs) (eLength ys).
Proof.
    intros a.
    apply (oList_mut_ind a
        (fun (xs:eList a) => forall (ys:eList a),
            eLength (eeAppend xs ys) = plus (eLength xs) (eLength ys))
        (fun (xs:oList a) => forall (ys:eList a),
            oLength (oeAppend xs ys) = plus (oLength xs) (eLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Lemma length_ooAppend' : forall (a:Set) (xs:oList a) (ys:oList a),
    eLength(ooAppend xs ys) = plus (oLength xs) (oLength ys).
Proof.
    intros a.
    apply (oList_mut_ind a
        (fun (xs:eList a) => forall (ys:oList a),
            oLength (eoAppend xs ys) = plus (eLength xs) (oLength ys))
        (fun (xs:oList a) => forall (ys:oList a),
            eLength (ooAppend xs ys) = plus (oLength xs) (oLength ys))).
    - reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
    - intros x xs IH ys. simpl. rewrite IH. reflexivity.
Qed.

Fixpoint factorial (n:nat) : nat :=
    match n with
    | 0     => 1
    | S n   => mult (S n) (factorial n)
    end.

Lemma factorial_test : factorial 5 = 120.
Proof. reflexivity. Qed.

Definition factorial' : nat -> nat :=
    fix f (n:nat) : nat :=
        match n with
        | 0     => 1
        | S n   => mult (S n) (f n)
        end.

Lemma factorial_test' : factorial' 5 = 120.
Proof. reflexivity. Qed.

Lemma factorial_same : forall (n:nat), factorial n = factorial' n.
Proof.
    induction n as [|n IH]; simpl.
    - reflexivity.
    - rewrite IH. reflexivity.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Check string_dec.
(*string_dec 的类型并不是bool，而是一个形如{x=y}+{x\neq y}的类型，叫做sumbool
一个sumbool类型的元素要么是x和y相等的证明，要么是x和y不等证明，目前可当做bool来考虑*)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.
(*两个字符创在eqb_string意义上相等，当且仅当在=意义上相等,建立了互映的关系*)

(** The following useful property follows from an analogous
    lemma about strings: *)
Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y =true <-> x=y.
Proof.
  intros x y.
  unfold eqb_string.
  destruct (string_dec x y) as [|Hs].
  - subst. split. reflexivity. reflexivity.
  - split.
    + intros H. inversion H.
    + intros. rewrite H in Hs. destruct Hs. reflexivity.
Qed.
(** Similarly: *)
Theorem eqb_string_false_iff : forall x y :string,
    eqb_string x y= false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This handy variant follows just by rewriting: *)

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

Definition total_map (A : Type) := string -> A.

(*t_empty 在应用到任何字符串时都会返回默认元素*)
Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

(*由t_update可构造高阶函数，逐个修改键值，下面就构造出string到bool的映射，其中"foo"和"bar"映射到true
其他映射到false*)
Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
     _ !-> false
  ).

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, standard, optional (t_apply_empty) *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  intros. reflexivity. Qed.
(** [] *)
(** **** Exercise: 2 stars, standard, optional (t_update_eq) *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros.
  unfold t_update.
  assert(H: eqb_string x x =true). {rewrite eqb_string_true_iff. reflexivity. }
  rewrite H.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_neq) *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  intros.
  unfold t_update.
  assert(H1: eqb_string x1 x2 =false). { apply false_eqb_string. apply H. }
  rewrite H1.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_shadow)  *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (eqb_string x x0).
  -reflexivity.
  -reflexivity.
Qed.

(** **** Exercise: 2 stars, standard, optional (eqb_stringP)*)

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros.
  apply iff_reflect.
  rewrite eqb_string_true_iff.
  reflexivity.
Qed.

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

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (eqb_string x x0) eqn: H1.
  -apply eqb_string_true_iff in H1. rewrite H1. reflexivity.
  -reflexivity.
Qed.
(** **** Exercise: 3 stars, standard, recommended (t_update_permute) *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (eqb_string x1 x) eqn: H1.
  - destruct (eqb_string x2 x) eqn: H2.
    + apply eqb_string_true_iff in H1. apply eqb_string_true_iff in H2.
      rewrite<-H1 in H2. rewrite H2 in H. destruct H. reflexivity.
    + reflexivity.
  - destruct (eqb_string x2 x) eqn: H2.
    + reflexivity.
    + reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.


Require Export D.

(** **** Exercise: 3 stars (types_unique)  *)
(** Another pleasant property of the STLC is that types are
    unique: a given term (in a given context) has at most one
    type. *)

Lemma type_is_unique: forall t G T T'
    (TYPED: G |- t \in T)
    (TYPED': G |- t \in T'),
  T = T'.
Proof.
  exact FILL_IN_HERE.
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 (z : natural) (y : natural) (lf2 : natural) : natural :=
  plus (mult z (Succ y)) lf2.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import ZArith Arith Bool Lia.

Inductive poly : Type :=
| Cst : Z -> poly
| Poly : poly -> nat -> poly -> poly .

Inductive valid_pol : poly -> Prop :=
|cst : forall (z:Z), valid_pol (Cst z)
|compose_cst :
	forall (i :nat),
	forall (x y :Z), y <> 0%Z ->
	valid_pol (Poly (Cst x) i (Cst y))
|compose_l :
	forall (i j :nat), i < j ->
	forall (x :Z),  x <> 0%Z ->
	forall (p q : poly), valid_pol (Poly p j q) ->
	valid_pol (Poly (Poly p j q) i (Cst x))
|compose_r :
	forall (i j :nat), i <= j ->
	forall (x :Z),
	forall (p q : poly), valid_pol (Poly p j q) ->
	valid_pol (Poly (Cst x) i (Poly p j q))
|compose_lr :
	forall (i j j':nat), i < j /\ i <= j' ->
	forall (p q p' q': poly), valid_pol (Poly p j q) /\ valid_pol (Poly p' j' q') ->
	valid_pol (Poly (Poly p j q) i (Poly p' j' q'))
.

Fixpoint valid_b (pol:poly) : bool :=
match pol with
|Cst _ => true
|Poly p i q =>
  match p,q with
  | _, Cst 0 => false
  |Cst _, Cst _ => true
  |Poly _ j1 _, Cst _ => (i <? j1) && valid_b p
  |Cst _,  (Poly p2 j2 q2) => (i <=? j2) && valid_b q
  |(Poly p1 j1 q1),  (Poly p2 j2 q2) =>
  (i <? j1) && (i <=? j2)
  && valid_b p && valid_b q
  end
end.

Record valid_poly : Type :=
{ VP_value : poly ;
VP_prop : valid_b VP_value = true }.

Require Import FMapList.
Require Import Coq.FSets.FMapList.
Require Import Coq.Structures.OrderedTypeEx.
Module Import NatMap := FMapList.Make(Nat_as_OT).
Require Import Coq.FSets.FMapFacts.
Module P := WProperties_fun Nat_as_OT NatMap.
Module F := P.F.

Definition monoid : Type := NatMap.t nat.

(* We could make a single definition [get_coefficient] with a dependent match to keep the polynomials proofs of validity at each recursive call, but it would makes the proofs harder. Instead we use the following definitions, with the lemma [valid_b_more] to propagate the polynomials validity proofs at each recursive call *)
Fixpoint get_coefficient_ (pol: poly) (m:monoid) :=
  match pol with
  | Cst z => if (P.for_all (fun (k:nat) (v:nat) => v =? 0%nat ) m) then z else 0%Z
  | Poly p i q =>
    match NatMap.find i m with
      |None | Some 0 => get_coefficient_ p m
      |Some n => Z.add (get_coefficient_ p m) (get_coefficient_ q (add i (n-1) m))
      end
end.

Definition get_coefficient (pol: valid_poly) (m:monoid) := get_coefficient_ (VP_value pol) m.

Lemma option_dec {A}:
  forall (el: option A),
    el = None \/ exists w: A, el = Some w.
Proof.
  intros.
  destruct el.
  right; exists a; trivial.
  left; trivial.
Qed.

Fixpoint poly_val_ (pol:poly) (f : nat -> Z) :=
  match pol with
  | Cst z => z
  | Poly p i q =>
    Z.add (poly_val_ p f) (Z.mul (f i) (poly_val_ q f))
end.

Definition poly_val (pol:valid_poly) (f : nat -> Z) :=
 poly_val_ (VP_value pol) f
.


Require Import EQ ANY.
Require Import Alist.

Require Import Relations.
Require Import Operators_Properties.

Declare Module Name : EQ.

Definition name := Name.t.
Definition name_eq_dec := Name.t_eq_dec.

Inductive type : Type :=
| TBool : type
| TArrow : type -> type -> type.

Inductive term : Type :=
| TConst : bool -> term
| TVar : name -> term
| TIf : term -> term -> term -> term
| TAbs : name -> type -> term -> term
| TApp : term -> term -> term.

Module TypeAny.
  Definition t := type.
End TypeAny.

Module TypingContext := alist Name TypeAny.

Definition typing_context := TypingContext.t.

Inductive has_type : typing_context -> term -> type -> Prop :=
| HTConst : forall Gamma b, has_type Gamma (TConst b) TBool
| HTVar : forall Gamma x tau,
    TypingContext.get x Gamma = Some tau ->
    has_type Gamma (TVar x) tau
| HTIf : forall Gamma e1 e2 e3 tau,
    has_type Gamma e1 TBool ->
    has_type Gamma e2 tau ->
    has_type Gamma e3 tau ->
    has_type Gamma (TIf e1 e2 e3) tau
| HTAbs : forall Gamma x tyx e tau,
    has_type (TypingContext.shadow x tyx Gamma) e tau ->
    has_type Gamma (TAbs x tyx e) (TArrow tyx tau)
| HTApp : forall Gamma e1 e2 ty2 tau,
    has_type Gamma e1 (TArrow ty2 tau) ->
    has_type Gamma e2 ty2 ->
    has_type Gamma (TApp e1 e2) tau.

Fixpoint subs (from : name) (to : term) (e : term) : term :=
  match e with
  | TConst _ => e
  | TVar y => if name_eq_dec from y then to else e
  | TIf e1 e2 e3 => TIf (subs from to e1)
                       (subs from to e2)
                       (subs from to e3)
  | TAbs y tau e' => if name_eq_dec from y then e else TAbs y tau (subs from to e')
  | TApp e1 e2 => TApp (subs from to e1) (subs from to e2)
  end.

Definition is_value (e : term) : Prop :=
  match e with
  | TConst _ => True
  | TAbs _ _ _ => True
  | _ => False
  end.

Inductive step : term -> term -> Prop :=
| step_if_true :
    forall e2 e3,
      step (TIf (TConst true) e2 e3) e2
| step_if_false :
    forall e2 e3,
      step (TIf (TConst false) e2 e3) e3
| step_if_step :
    forall e1 e1' e2 e3,
      step e1 e1' ->
      step (TIf e1 e2 e3) (TIf e1' e2 e3)
| step_beta :
    forall x tau e1 e2,
      is_value e2 ->
      step (TApp (TAbs x tau e1) e2) (subs x e2 e1)
| step_app1 :
    forall e1 e1' e2,
      step e1 e1' ->
      step (TApp e1 e2) (TApp e1' e2)
| step_app2 :
    forall e1 e2 e2',
      is_value e1 ->
      step e2 e2' ->
      step (TApp e1 e2) (TApp e1 e2').

Definition step_star := clos_refl_trans_n1 term step.
Definition irreducible (e : term) : Prop := forall e', step e e' -> False.
Definition terminates (e : term) : Prop := exists v, irreducible v /\ step_star e v.


Require Import List.
Notation "[]" := nil.
Notation "[ a ]" := (cons a nil).
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Infix "::" := cons.

Require Import Arith.
Infix "===" := eq_nat_dec (at level 50).

Inductive term : Set :=
| var : nat -> term
| Pi : term -> term -> term
| abs : term -> term -> term
| app : term -> term -> term
| star : term
| box : term.
Coercion var : nat >-> term.

Fixpoint open_rec (k:nat) (t:term) (u:term) : term :=
  match t with
    | var n => match (k === n) with
                 | left Hr => u
                 | right Hr => t
               end
    | Pi A B => Pi (open_rec k A u) (open_rec (S k) B u)
    | abs A B => abs (open_rec k A u) (open_rec (S k) B u)
    | app A B => app (open_rec k A u) (open_rec k B u)
    | star => star
    | box => box
  end.
Definition open := open_rec 0.

Inductive beta_eq : term -> term -> Prop :=
| beta_eq_base : forall A B C, beta_eq (app (abs A B) C) (open B C)
| beta_eq_refl : forall A, beta_eq A A
| beta_eq_sym : forall A B, beta_eq A B -> beta_eq B A
| beta_eq_trans : forall A B C, beta_eq A B -> beta_eq B C -> beta_eq A C.
Infix "=b=" := beta_eq (at level 50).

Inductive cube : term -> term -> Prop :=
| cube_s_s : cube star star
| cube_b_b : cube box box
| cube_s_b : cube box star.
Infix "~>" := cube (at level 50).

Fixpoint reduce (t:term) : term :=
  match t with
    | var n => var n
    | Pi A B => Pi A B
    | abs A B => abs A B
    | app (abs A B) C => (open B C)
    | app A B => app (reduce A) B
    | star => star
    | box => box
  end.

Definition context := list (nat * term).

Reserved Notation "G |- x ;; T" (at level 55).
Inductive turnstile : context -> term -> term -> Set :=
| star_intro : [] |- star ;; box
| var_intro : forall x T G,
  In (x,T) G ->
  G |- x ;; T
| app_intro : forall f a A A' B G,
  G |- f ;; (Pi A B) ->
    G |- a ;; A' ->
      A =b= A' ->
      G |- (app f a) ;; (open B a)
| lam_intro : forall x b A B G t,
  ([(x,A)] ++ G) |- b ;; B ->
    G |- (Pi A B) ;; t ->
      G |- (abs A b) ;; (Pi A B)
| pi_intro : forall x A B t s,
  G |- A ;; s ->
    ([(x,A)] ++ G) |- B ;; t ->
      s ~> t ->
      G |- (Pi A B) ;; t
  where "G |- x ;; T" := (turnstile G x T).

Definition varin (n:nat) (c:context) : {t | In (n,t) c} + {forall t, ~ In (n,t) c}.
Proof.
  intros. induction c.
  (*nil*)
  right ; intros ; simpl ; auto.
  (*cons*)
  destruct a. simpl.
  case_eq (n0 === n).
    (* n0 = n *)
    intros e He. rewrite e in *.
    left. exists t. auto.
    (* n0 <> n *)
    intros ne Hne.
    case_eq IHc.
      (* In next *)
      intros e He.  left. inversion e. exists x. auto.
      (* not In next *)
      intros Hni Hnew. right.
      intros. unfold not. intros. inversion H.
        (* left *)
        inversion H0. congruence.
        (* right *)
        unfold not in * ; eapply Hni. eauto.
Defined.
Infix "@" := varin (at level 55).


Check true.

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 => saturday
  | saturday => sunday
  | sunday => monday
  end.

Compute next_weekday monday.

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

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) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb_true_false :
  (orb true false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb_true_true :
  (orb true true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb_false_false :
  (orb false false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb_false_true :
  (orb false true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_negb_false :
  (negb false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_negb_true :
  (negb true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example andb_true_true :
  (andb true true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example andb_true_false :
  (andb true false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example andb_false_true :
  (andb false true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example andb_false_false :
  (andb false false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

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

Compute (true || false).
Compute (true && false).

Definition negb' (b : bool) : bool :=
  if b then false
  else true.

Definition orb' (b1 b2 : bool) : bool :=
  if b1 then true
  else b2.

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

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

Example nanb_true_true :
  (nandb true true) = false.
Proof.
  (* compute. *)
  reflexivity.
Qed.

Example andb_true_true' :
  (nandb' true true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Check 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 p => false
  end.

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

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

  Definition b : bool := true.

Check b : bool.
Check Playground.b : rgb.

Module NatNumber.
  Inductive nat : Type :=
    | O
    | S (n : nat).

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

Check (S (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).

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

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

Compute even 4.
Compute odd 3.

Example test_even_4 :
  (even 4) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_odd_3 :
  (odd 3) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Module NatNumber2.
  Fixpoint plus (n1 n2 : nat) : nat :=
    match n1 with
    | O => n2
    | S n1' => S (plus n1' n2)
    end.

  Compute (plus 3 4).

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

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

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

  Example test_minus_4_2 :
    (minus 4 2) = 2.
  Proof.
    simpl.
    reflexivity.
  Qed.

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

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

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

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

  Fixpoint leb (n1 n2 : nat) : bool :=
    match n1, n2 with
    | O, O => true
    | O, _ => true
    | _, O => false
    | S n1', S n2' => leb n1' n2'
    end.

  Fixpoint geb (n1 n2 : nat) : bool :=
    match n1, n2 with
    | O, O => true
    | _, O => true
    | O, _ => false
    | S n1', S n2' => geb n1' n2'
    end.

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

  Example test_leb_3_4 :
    (3 <=? 4) = true.
  Proof.
    simpl.
    reflexivity.
  Qed.

End NatNumber2.

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

Fixpoint leb (n1 n2 : nat) : bool :=
  match n1, n2 with
  | O, O => true
  | O, _ => true
  | _, O => false
  | S n1', S n2' => leb n1' n2'
  end.

Fixpoint geb (n1 n2 : nat) : bool :=
  match n1, n2 with
  | O, O => true
  | _, O => true
  | O, _ => false
  | S n1', S n2' => geb n1' n2'
  end.

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

Theorem plus_O_n :
  forall (n : nat), plus O n = n.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Theorem plus_n_O :
  forall (n: nat), plus n O = n.
Proof.
  induction n.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHn.
    reflexivity.
Qed.

Theorem mult_O_n :
  forall (n : nat), mult O n = O.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Theorem mult_n_O :
  forall (n : nat), mult n O = O.
Proof.
  induction n.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHn.
    reflexivity.
Qed.

Theorem plus_id :
  forall (n m : nat), n = m -> plus n n = plus m m.
Proof.
  intros.
  rewrite <- H.
    (* rewrite -> H. *)
  reflexivity.
Qed.

Check mult_n_O.

Theorem mult_n_o_m_o :
  forall (p q : nat), (p * O) + (q * O) = O.
Proof.
  intros.
  rewrite -> mult_n_O.
  rewrite -> mult_n_O.
  simpl.
  reflexivity.
  (* induction p.
  - simpl.
    apply mult_n_O.
  - intros.
    simpl.
    rewrite IHp.
    reflexivity. *)
Qed.

Theorem plus_n_S_eqb_O :
  forall (n : nat), ((plus n (S O)) =? O) = false.
Proof.
  intros.
  destruct n as [| n'] eqn : E.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

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

Theorem andb_commutative :
  forall (a b : bool), andb a b = andb b a.
Proof.
  intros a b;
  destruct a, b;
  simpl;
  reflexivity.
Qed.

Theorem plus_1_neq_O :
  forall (n : nat), (plus n (S O)) =? O = false.
Proof.
  (* intros n. destruct n. *)
  intros [|n].
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Theorem andb_commutative' :
  forall (a b : bool), andb a b = andb b a.
Proof.
  intros [] [];
  simpl;
  reflexivity.
Qed.


From Coq Require Import Nat Reals List Arith Lia Lra.
From Coquelicot Require Import Coquelicot.

Import ListNotations.

Section StandardLibraryLemmas.

Lemma nat_pred_le_lt:
    forall n m, (n <= Nat.pred m)%nat -> (m >= 1)%nat -> (n < m)%nat.
Proof.
    intros n m Hn Hn_ge_1.
    compute.
    induction m.
    - simpl in Hn.
      apply le_n_S in Hn.
      apply (Nat.le_trans (S n) 1).
      apply Hn. apply Hn_ge_1.
    - rewrite Nat.pred_succ in Hn.
      apply le_n_S.
      apply Hn.
Qed.

Lemma f_equal2_plus_R:
    forall x1 y1 x2 y2 : R,
    x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2.
Proof.
    intros x1 y1 x2 y2.
    lra.
Qed.

Lemma list_prod_empty:
    forall A B l,
        list_prod (A:=A) (B:=B) l [] = [].
Proof.
    intros A B l.
    induction l.
    * compute. reflexivity.
    * unfold list_prod.
      simpl. apply IHl.
Qed.

End StandardLibraryLemmas.

Section CoquelicotGeneralLemmas.

Lemma coeff_Tn_default:
    forall n T (it: Tn n T) d i,
        (i >= n)%nat ->
        coeff_Tn d it i = d.
Proof.
    intros n T it d.
    induction n. reflexivity.
    intros i Hi.
    unfold coeff_Tn.
    assert (Hi2: i = S (pred i)). {
        apply S_pred_pos. lia.
    }
    rewrite Hi2.
    induction it.
    fold (coeff_Tn (T:=T) (n:=n)). simpl.
    specialize (IHn b (pred i)).
    apply IHn.
    lia.
Qed.

Lemma zero_is_0:
    zero = 0.
Proof.
    reflexivity.
Qed.

Lemma sum_n_m_shift:
    forall (f: nat -> R) n m shift,
    sum_n_m f n m = sum_n_m (fun l => f (l - shift)%nat) (n + shift) (m + shift).
Proof.
    intros f n m shift.
    induction shift.
    * repeat rewrite Nat.add_0_r.
      apply sum_n_m_ext.
      intros n0.
      rewrite Nat.sub_0_r.
      reflexivity.
    * repeat rewrite Nat.add_succ_r.
      rewrite <- sum_n_m_S.
      apply IHshift.
Qed.

Lemma floor1_tech:
    forall r n,
       IZR n < r -> r <= IZR n + 1 -> floor1 r = n.
Proof.
    intros r n H1 H2.
    unfold floor1.
    destruct floor1_ex as [x Hx]. simpl.
    apply Z.le_antisymm.
    - apply Zlt_succ_le. simpl.
      apply lt_IZR.
      apply (Rlt_le_trans _ r).
      * destruct Hx as [H H0].
        apply H.
      * destruct Hx as [H H0].
        rewrite succ_IZR.
        apply H2.
    - apply Zlt_succ_le.
      apply lt_IZR.
      rewrite succ_IZR.
      apply (Rlt_le_trans _ r).
      * apply H1.
      * destruct Hx as [H H0].
        apply H0.
Qed.

Lemma floor1_plus_IZR:
    forall r n,
        floor1 (r + IZR n) = (floor1 r + n)%Z.
Proof.
    intros r n.
    apply floor1_tech.
    * rewrite plus_IZR.
      apply Rplus_lt_compat_r.
      unfold floor1.
      destruct floor1_ex.
      simpl.
      apply a.
    * rewrite plus_IZR.
      rewrite Rplus_assoc.
      rewrite (Rplus_comm (IZR n) 1).
      rewrite <- Rplus_assoc.
      apply Rplus_le_compat_r.
      unfold floor1. destruct floor1_ex. simpl.
      destruct a. apply H0.
Qed.

End CoquelicotGeneralLemmas.

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

Section CoquelicotMatrix.

Lemma coeff_mat_default:
    forall A d m n (M: matrix (T:=A) m n) i j,
        ((i >= m)%nat \/ (j >= n)%nat) ->
        coeff_mat d M i j = d.
Proof.
    intros A d m n M i j Hij.
    destruct Hij as [Hi|Hj].
    - unfold coeff_mat.
      rewrite (coeff_Tn_default _ _ _ _ i); try lia.
      destruct (lt_dec j n).
      * apply coeff_Tn_bij; try lia.
      * rewrite coeff_Tn_default; try lia. reflexivity.
    - unfold coeff_mat. rewrite coeff_Tn_default; try lia. reflexivity.
Qed.

Definition transpose {m n: nat} (M: matrix m n) :=
    mk_matrix n m (fun i j => coeff_mat 0 M j i).

Theorem transpose_transpose:
    forall m n (M: matrix m n),
    transpose (transpose M) = M.
Proof.
    intros m n M.
    unfold transpose.
    unfold transpose.
    rewrite <- (mk_matrix_bij 0).
    apply mk_matrix_ext.
    intros i j Hi Hj.
    repeat (rewrite coeff_mat_bij; try lia).
    reflexivity.
Qed.

Theorem Mmult_Mzero:
    forall n m (M: matrix (T:=R) m n), Mmult (n:=m) Mzero M = (Mzero (n:=n)).
Proof.
    intros n m M.
    unfold Mmult.
    unfold Mzero.
    apply mk_matrix_ext.
    intros i j Hi Hj.
    unfold sum_n.
    rewrite <- (sum_n_m_const_zero 0 (Init.Nat.pred m)) at 1.
    apply sum_n_m_ext_loc.
    intros k Hk.
    rewrite coeff_mat_bij; try lia.
    rewrite Rmult_0_l.
    reflexivity.
Qed.

Definition scalar_mult {m n: nat} (c:R) (v: matrix m n) :=
    mk_matrix m n (fun i j => c * coeff_mat 0 v i j).

End CoquelicotMatrix.

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

(** * Theory of column vectors

Basic theory of column vectors, wrapper for Coquelicot matricies

Operations:
- Contruction via mk_colvec
- Coefficients retrieval via coeff_colvec
- Special cases: dimesion zero vectors, null vectors
- Conversions to n*1 and 1*n matricies
- Dot product
*)

Section ColumnVectors.

(* Column vector is a 1d matrix *)
Definition colvec m := matrix (T:=R) m 1.

(* There is only a single colvec of dimension zero *)
Lemma unique_colvec_0:
    forall (v1: colvec 0) (v2: colvec 0),
        v1 = v2.
Proof.
    intros v1 v2.
    rewrite <- (mk_matrix_bij 0 v1).
    rewrite <- (mk_matrix_bij 0 v2).
    apply mk_matrix_ext.
    intros i j Hi Hj.
    rewrite coeff_mat_default; try lia.
Qed.

(* Coeficient of a colvec V[i] with x0 as default value*)
Definition coeff_colvec {m: nat} (x0: R) (V:colvec m) (i:nat) :=
  coeff_mat x0 V i 0.

(* Construction of a colvec *)
Definition mk_colvec m (f: nat -> R) : colvec m :=
    mk_matrix m 1 (fun i j => (f i)).

(* Dot product *)
Definition dot {n:nat} (c1: colvec n) (c2: colvec n) : R :=
    coeff_mat 0 (Mmult (transpose c1) c2) 0 0.

(* Null vector *)
Definition null_vector m := mk_colvec m (fun i => 0).

(* Associativity of multiplication with constant and dot product *)
Theorem dot_scalar_mult:
    forall dim c (v1: colvec dim) (v2: colvec dim),
    dot (scalar_mult c v1) v2 = Rmult c (dot v1 v2).
Proof.
    intros dim c v1 v2.
    unfold dot.
    unfold Mmult.
    repeat rewrite (coeff_mat_bij _ _ 0 0 Nat.lt_0_1 Nat.lt_0_1).
    rewrite <- (sum_n_mult_l c).
    apply sum_n_ext_loc.
    intros n Hloc.
    induction dim.
    * compute. lra.
    * assert (Hdim: (S dim >= 1)%nat). lia.
      pose proof (nat_pred_le_lt n (S dim) Hloc Hdim) as Hndim.
      unfold scalar_mult.
      unfold transpose.
      rewrite (coeff_mat_bij _ _ 0 n Nat.lt_0_1 Hndim).
      unfold mk_colvec.
      rewrite (coeff_mat_bij _ _ 0 n Nat.lt_0_1 Hndim).
      unfold coeff_colvec.
      rewrite (coeff_mat_bij _ _ n 0 Hndim Nat.lt_0_1).
      rewrite Rmult_assoc.
      reflexivity.
Qed.

(* 0 dot v1 = 0 *)
Theorem dot_null_vector:
    forall dim x, dot (null_vector dim) x = 0.
Proof.
    intros dim x.
    unfold dot.
    unfold Mmult.
    rewrite (coeff_mat_bij _ _ 0 0 Nat.lt_0_1 Nat.lt_0_1).
    unfold sum_n.
    unfold coeff_colvec.
    unfold null_vector.
    unfold mk_colvec.
    rewrite <- zero_is_0.
    rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) 0 (Nat.pred dim)) at 1.
    apply sum_n_m_ext_loc.
    intros n Hn.
    destruct Hn.
    induction dim.
    * compute. lra.
    * assert (Hdim: (S dim >= 1)%nat). lia.
      pose proof (nat_pred_le_lt n (S dim) H0 Hdim) as Hndim.
      unfold transpose.
      rewrite (coeff_mat_bij _ _ 0 n Nat.lt_0_1 Hndim).
      rewrite (coeff_mat_bij _ _ n 0 Hndim Nat.lt_0_1).
      rewrite Rmult_0_l.
      reflexivity.
Qed.

(* v1 + 0 = v1 *)
Theorem Mplus_null_vector:
    forall dim v, Mplus v (null_vector dim) = v.
Proof.
    intros dim v.
    unfold Mplus. unfold colvec in v. unfold null_vector. unfold mk_colvec.
    rewrite <- (mk_matrix_bij 0 v) at 1.
    apply mk_matrix_ext.
    intros i j Hi Hj.
    unfold coeff_colvec.
    rewrite (coeff_mat_bij 0 (fun _ _ => 0) i j).
    rewrite Rplus_0_r.
    induction j. reflexivity. lia.
    apply Hi. lia.
Qed.

(* For a matrix M and a vector v, M*v can be split into multiple
   dot products over matrix rows *)
Theorem Mmult_dot_split:
    forall n m M v, Mmult M v = mk_colvec n (
        fun i =>
            dot (mk_colvec m (fun j => coeff_mat 0 M i j)) v
    ).
Proof.
    intros n m M V.
    unfold Mmult.
    unfold mk_colvec. unfold dot. unfold Mmult.
    apply mk_matrix_ext.
    intros i j Hi Hj.
    rewrite coeff_mat_bij.
    apply sum_n_ext_loc.
    intros n0 Hn0.
    induction m.
    * compute. lra.
    * unfold transpose.
      rewrite coeff_mat_bij.
      unfold coeff_colvec.
      rewrite coeff_mat_bij.
      induction j. reflexivity. lia.
      apply nat_pred_le_lt. apply Hn0. lia. lia. lia.
      apply nat_pred_le_lt. apply Hn0. lia. lia. lia.
Qed.

(* v1 * (v2 + v3) = v1 * v2 + v1 * v3 *)
Theorem dot_Mplus_distr:
    forall dim (v1: colvec dim) v2 v3,
        dot v1 (Mplus v2 v3) = (dot v1 v2) + (dot v1 v3).
Proof.
    intros dim v1 v2 c3.
    unfold dot.
    unfold Mplus.
    unfold Mmult.
    repeat (rewrite coeff_mat_bij; try lia).
    assert (Hplus: forall a b, a + b = plus a b). { reflexivity. }
    rewrite Hplus.
    rewrite <- sum_n_plus.
    apply sum_n_ext_loc.
    intros n Hn.
    unfold mk_colvec. unfold coeff_colvec.
    induction dim.
    * compute. lra.
    * repeat (rewrite coeff_mat_bij; try lia).
      rewrite Rmult_plus_distr_l. reflexivity.
Qed.

(* Associativity of dot and matrix multiplication via transposition.
   For matrix M and vectors v1 v2: v1 * (M * v2) = (v1^T * M)^T * v2 *)
Theorem dot_Mmult:
    forall m n v1 (M: matrix m n) v2,
        dot v1 (Mmult M v2) = dot (transpose (Mmult (transpose v1) M)) v2.
Proof.
    intros m n v1 M v2.
    unfold dot.
    repeat rewrite colvec2matrix_spec.
    rewrite Mmult_assoc.
    rewrite transpose_transpose.
    reflexivity.
Qed.

End ColumnVectors.

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

Section ReshapeOperations.

Definition block_diag_matrix
    {in_dim1 in_dim2 out_dim1 out_dim2: nat}
    (M1: matrix (T:=R) out_dim1 in_dim1)
    (M2: matrix (T:=R) out_dim2 in_dim2):
    matrix (out_dim1 + out_dim2) (in_dim1 + in_dim2) :=
    mk_matrix (out_dim1 + out_dim2) (in_dim1 + in_dim2)
        (fun i j =>
            if (ltb i out_dim1) then
                (if (ltb j in_dim1) then
                    coeff_mat 0 M1 i j
                else
                    0)
            else
                (if (ltb j in_dim1) then
                    0
                else
                    coeff_mat 0 M2 (i - out_dim1) (j - in_dim1))
        ).

Definition extend_colvec_at_bottom {n: nat} (v: colvec n) (new_dim: nat) :=
    mk_colvec new_dim (
        fun i =>
        match i <? n with
        | true => coeff_colvec 0 v i
        | false => 0
        end
    ).

Lemma extend_colvec_at_bottom_same_dim:
    forall d (v: colvec d),
        extend_colvec_at_bottom v d = v.
Proof.
    intros d v.
    unfold colvec in v.
    unfold extend_colvec_at_bottom.
    rewrite <- (mk_matrix_bij 0 v) at 1.
    unfold mk_colvec.
    destruct d.
    * apply unique_colvec_0.
    * apply mk_matrix_ext.
      intros i j Hi Hj.
      rewrite <- Nat.ltb_lt in Hi.
      rewrite Hi.
      unfold coeff_colvec.
      induction j.
      - reflexivity.
      - lia.
Qed.

Lemma extend_colvec_at_bottom_preserves_equality:
    forall d1 d2 (v1: colvec d1) v2,
      v1 = v2 <->
      extend_colvec_at_bottom v1 (d1 + d2) = extend_colvec_at_bottom v2 (d1 + d2).
Proof.
    intros d1 d2 v1 v2.
    rewrite <- (mk_matrix_bij 0 v1).
    rewrite <- (mk_matrix_bij 0 v2).
    split.
    {
      intros Hequal.
      unfold colvec in v1. unfold colvec in v2.
      unfold extend_colvec_at_bottom.
      unfold mk_colvec.
      apply mk_matrix_ext.
      intros i j Hi Hj.
      remember (i <? d1) as r.
      destruct r; try reflexivity.
      symmetry in Heqr. rewrite Nat.ltb_lt in Heqr.
      pose proof (mk_matrix_ext (T:=R)) as Hext.
      specialize (Hext d1 1%nat (coeff_mat 0 v1) (coeff_mat 0 v2)).
      unfold coeff_colvec.
      repeat (rewrite coeff_mat_bij; try lia).
      apply Hext; try lia.
      apply Hequal.
    }
    {
      intros Hequal.
      apply mk_matrix_ext.
      intros i j Hi Hj.
      unfold extend_colvec_at_bottom in Hequal.
      unfold mk_colvec in Hequal.
      pose proof (mk_matrix_ext (T:=R)) as Hext.
      specialize (Hext (d1 + d2)%nat 1%nat).
      specialize (Hext (fun i _ : nat =>
                          if i <? d1 then
                            coeff_colvec 0 (mk_matrix d1 1 (coeff_mat 0 v1)) i
                          else
                            0)).
      specialize (Hext (fun i _ : nat =>
                          if i <? d1 then
                            coeff_colvec 0 (mk_matrix d1 1 (coeff_mat 0 v2)) i
                          else
                            0)).
      destruct Hext as [Hext1 Hext2].
      specialize (Hext2 Hequal).
      specialize (Hext2 i j).
      pose proof Hi as Hi_cp.
      rewrite <- Nat.ltb_lt in Hi.
      rewrite Hi in Hext2.
      unfold coeff_colvec in Hext2.
      repeat (rewrite coeff_mat_bij in Hext2; try lia).
      induction j.
      * apply Hext2; try lia.
      * lia.
    }
Qed.

Definition extend_colvec_on_top {n: nat} (v: colvec n) (new_dim: nat) :=
    mk_colvec new_dim (
        fun i =>
        match i <? (new_dim - n) with
        | true => 0
        | false => coeff_colvec 0 v (i - (new_dim - n))
        end
    ).

Lemma extend_colvec_on_top_same_dim:
    forall d (v: colvec d),
      extend_colvec_on_top v d = v.
Proof.
    intros d v.
    unfold colvec in v.
    unfold extend_colvec_on_top.
    rewrite <- (mk_matrix_bij 0 v) at 1.
    unfold mk_colvec.
    destruct d.
    * apply unique_colvec_0.
    * apply mk_matrix_ext.
      intros i j Hi Hj.
      rewrite Nat.sub_diag.
      simpl.
      unfold coeff_colvec.
      rewrite Nat.sub_0_r.
      induction j.
      - reflexivity.
      - lia.
Qed.

Lemma extend_colvec_on_top_preserves_equality:
    forall d1 d2 (v1: colvec d2) v2,
      v1 = v2 <->
      extend_colvec_on_top v1 (d1 + d2) = extend_colvec_on_top v2 (d1 + d2).
Proof.
    intros d1 d2 v1 v2.
    rewrite <- (mk_matrix_bij 0 v1).
    rewrite <- (mk_matrix_bij 0 v2).
    split.
    {
      intros Hequal.
      unfold colvec in v1. unfold colvec in v2.
      unfold extend_colvec_on_top.
      unfold mk_colvec.
      apply mk_matrix_ext.
      intros i j Hi Hj.
      rewrite Nat.add_sub.
      remember (i <? d1) as r.
      destruct r; try reflexivity.
      symmetry in Heqr. rewrite Nat.ltb_ge in Heqr.
      pose proof (mk_matrix_ext (T:=R)) as Hext.
      specialize (Hext d2 1%nat (coeff_mat 0 v1) (coeff_mat 0 v2)).
      unfold coeff_colvec.
      repeat (rewrite coeff_mat_bij; try lia).
      apply Hext; try lia.
      apply Hequal.
    }
    {
      intros Hequal.
      apply mk_matrix_ext.
      intros i j Hi Hj.
      unfold extend_colvec_on_top in Hequal.
      unfold mk_colvec in Hequal.
      rewrite Nat.add_sub in Hequal.
      pose proof (mk_matrix_ext (T:=R)) as Hext.
      specialize (Hext (d1 + d2)%nat 1%nat).
      specialize (Hext (fun i _ : nat =>
                          if i <? d1 then
                            0
                          else
                            coeff_colvec 0 (mk_matrix d2 1 (coeff_mat 0 v1)) (i - d1))).
      specialize (Hext (fun i _ : nat =>
                          if i <? d1 then
                            0
                          else
                            coeff_colvec 0 (mk_matrix d2 1 (coeff_mat 0 v2)) (i - d1))).
      destruct Hext as [Hext1 Hext2].
      specialize (Hext2 Hequal).
      specialize (Hext2 (i + d1)%nat j).
      assert (Hi2: (d1 <= i + d1)%nat). lia.
      rewrite <- Nat.ltb_ge in Hi2.
      rewrite Hi2 in Hext2.
      rewrite Nat.add_sub in Hext2.
      unfold coeff_colvec in Hext2.
      repeat (rewrite coeff_mat_bij in Hext2; try lia).
      induction j.
      * apply Hext2; try lia.
      * lia.
    }
Qed.

Definition colvec_concat {n m: nat} (v1: colvec n) (v2: colvec m) :=
    Mplus (extend_colvec_at_bottom v1 (n + m)) (extend_colvec_on_top v2 (n + m)).

Lemma dot_extend_at_bottom:
    forall d1 d2 (v: colvec d1) x1 x2,
        dot (extend_colvec_at_bottom v (d1 + d2)) (colvec_concat x1 x2) =
        dot v x1.
Proof.
    intros d1 d2 v x1 x2.
    destruct d1.
    * destruct d2.
      - rewrite (unique_colvec_0 (extend_colvec_at_bottom v (0 + 0)) v).
        rewrite (unique_colvec_0 (colvec_concat x1 x2) x1).
        reflexivity.
      - unfold dot.
        unfold Mmult.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite sum_O.
        rewrite coeff_mat_default; try lia.
        rewrite Rmult_0_l. rewrite Nat.add_0_l at 1.
        rewrite <- zero_is_0.
        rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) 0 (d2)).
        apply sum_n_ext_loc.
        intros n Hn.
        unfold transpose.
        unfold extend_colvec_at_bottom.
        unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        simpl.
        apply Rmult_0_l.
    * destruct d2.
      - unfold dot.
        unfold Mmult.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_0_r at 1.
        apply sum_n_ext_loc.
        intros n Hn.
        unfold transpose.
        unfold extend_colvec_at_bottom. unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        simpl in Hn.
        unfold colvec_concat.
        unfold Mplus.
        unfold extend_colvec_at_bottom.
        unfold extend_colvec_on_top.
        unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_sub.
        apply le_lt_n_Sm in Hn.
        rewrite <- Nat.ltb_lt in Hn.
        rewrite Hn.
        unfold coeff_colvec.
        rewrite Rplus_0_r.
        reflexivity.
      - unfold extend_colvec_at_bottom.
        unfold colvec_concat.
        unfold dot. unfold Mmult.
        repeat (rewrite coeff_mat_bij; try lia).
        unfold sum_n. simpl.
        rewrite <- (Rplus_0_r (sum_n_m _ 0 (d1))).
        rewrite (sum_n_m_Chasles _ _ d1 (d1 + S d2)); try lia.
        apply f_equal2_plus_R.
        * apply sum_n_ext_loc.
          intros n Hn.
          unfold transpose.
          unfold Mplus.
          unfold extend_colvec_at_bottom.
          unfold extend_colvec_on_top.
          unfold mk_colvec.
          repeat (rewrite coeff_mat_bij; try lia).
          rewrite <- Nat.add_succ_l.
          rewrite Nat.add_sub.
          apply le_lt_n_Sm in Hn.
          rewrite <- Nat.ltb_lt in Hn.
          rewrite Hn.
          unfold coeff_colvec.
          rewrite Rplus_0_r.
          reflexivity.
        * simpl.
          rewrite <- zero_is_0.
          rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) (S d1) (d1 + S d2)) at 1.
          apply sum_n_m_ext_loc.
          intros k Hk.
          unfold transpose.
          unfold Mplus.
          unfold extend_colvec_at_bottom.
          unfold extend_colvec_on_top.
          unfold mk_colvec.
          repeat (rewrite coeff_mat_bij; try lia).
          destruct Hk.
          rewrite <- Nat.ltb_ge in H.
          rewrite H.
          rewrite Rmult_0_l.
          reflexivity.
Qed.

Lemma dot_extend_on_top:
    forall d1 d2 (v: colvec d2) x1 x2,
        dot (extend_colvec_on_top v (d1 + d2)) (colvec_concat x1 x2) =
        dot v x2.
Proof.
    intros d1 d2 v x1 x2.
    destruct d1.
    * destruct d2.
      - rewrite (unique_colvec_0 (extend_colvec_on_top v (0 + 0)) v).
        rewrite (unique_colvec_0 (colvec_concat x1 x2) x1).
        reflexivity.
      - unfold dot.
        unfold Mmult.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_0_l at 1.
        apply sum_n_ext_loc.
        intros n Hn.
        unfold transpose.
        unfold extend_colvec_at_bottom. unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        simpl in Hn.
        unfold colvec_concat.
        unfold Mplus.
        unfold extend_colvec_at_bottom.
        unfold extend_colvec_on_top.
        unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_sub. simpl.
        unfold coeff_colvec.
        rewrite Rplus_0_l.
        rewrite Nat.sub_0_r.
        reflexivity.
    * destruct d2.
      - unfold dot.
        unfold Mmult.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite sum_O.
        rewrite coeff_mat_default; try lia.
        rewrite Rmult_0_l. rewrite Nat.add_0_r at 1.
        rewrite <- zero_is_0.
        rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) 0 (d1)).
        apply sum_n_ext_loc.
        intros n Hn.
        unfold transpose.
        unfold extend_colvec_on_top.
        unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_sub.
        apply le_lt_n_Sm in Hn.
        rewrite <- Nat.ltb_lt in Hn.
        rewrite Hn.
        apply Rmult_0_l.
      - unfold extend_colvec_on_top.
        unfold colvec_concat.
        unfold dot. unfold Mmult.
        repeat (rewrite coeff_mat_bij; try lia).
        unfold sum_n. simpl.
        rewrite <- (Rplus_0_l (sum_n_m _ 0 (d2))).
        rewrite (sum_n_m_Chasles _ _ d1 (d1 + S d2)); try lia.
        apply f_equal2_plus_R.
        * simpl.
          rewrite <- zero_is_0.
          rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) 0 d1) at 1.
          apply sum_n_m_ext_loc.
          intros k Hk.
          unfold transpose.
          unfold Mplus.
          unfold extend_colvec_at_bottom.
          unfold extend_colvec_on_top.
          unfold mk_colvec.
          repeat (rewrite coeff_mat_bij; try lia).
          simpl.
          rewrite Nat.add_succ_r.
          rewrite <- Nat.add_succ_l.
          rewrite Nat.add_sub.
          destruct Hk.
          apply le_lt_n_Sm in H0.
          rewrite <- Nat.ltb_lt in H0.
          rewrite H0.
          rewrite Rmult_0_l.
          reflexivity.
        * rewrite (sum_n_m_shift _ 0 d2 (S d1)).
          rewrite Nat.add_0_l.
          rewrite Nat.add_succ_r at 1.
          rewrite (Nat.add_succ_r d2 d1).
          rewrite (Nat.add_comm d1 d2).
          apply sum_n_m_ext_loc.
          intros n Hn.
          unfold transpose.
          unfold Mplus.
          unfold extend_colvec_at_bottom.
          unfold extend_colvec_on_top.
          unfold mk_colvec.
          repeat (rewrite coeff_mat_bij; try lia).
          rewrite Nat.add_succ_r at 1.
          do 2 rewrite <- Nat.add_succ_l.
          do 2 rewrite Nat.add_sub.
          destruct Hn.
          rewrite <- Nat.ltb_ge in H.
          rewrite H.
          unfold coeff_colvec.
          rewrite Nat.add_succ_r.
          rewrite <- Nat.add_succ_l.
          rewrite Nat.add_sub.
          rewrite Rplus_0_l.
          reflexivity.
Qed.

Lemma colvec_concat_eq:
    forall d1 d2 (v1: colvec d1) (v2: colvec d2) v3 v4,
        v1 = v3 -> v2 = v4 ->
        colvec_concat v1 v2 = colvec_concat v3 v4.
Proof.
    intros d1 d2 v1 v2 v3 v4 Hv13 Hv24.
    unfold colvec_concat.
    rewrite Hv13. rewrite Hv24.
    reflexivity.
Qed.

Lemma Mplus_colvec_concat:
    forall d1 d2 (v1: colvec d1) (v2: colvec d2) v3 v4,
        Mplus (colvec_concat v1 v2) (colvec_concat v3 v4) =
        colvec_concat (Mplus v1 v3) (Mplus v2 v4).
Proof.
    intros d1 d2 v1 v2 v3 v4.
    unfold colvec_concat.
    rewrite (Mplus_assoc _ (extend_colvec_at_bottom v3 _) _).
    rewrite <- (Mplus_assoc (extend_colvec_at_bottom v1 _) _ _).
    rewrite (Mplus_comm (extend_colvec_on_top v2 _) (extend_colvec_at_bottom v3 _)).
    rewrite (Mplus_assoc (extend_colvec_at_bottom v1 _) _ _).
    rewrite <- (Mplus_assoc _ (extend_colvec_on_top v2 _) _).
    unfold Mplus.
    apply mk_matrix_ext.
    intros i j Hi Hj.
    destruct d1.
    - destruct d2.
      * lia.
      * unfold extend_colvec_at_bottom.
        unfold extend_colvec_on_top.
        unfold mk_colvec. unfold coeff_colvec.
        do 7 (rewrite coeff_mat_bij; try lia).
        simpl. rewrite Nat.sub_diag. simpl.
        repeat rewrite Rplus_0_l.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.sub_0_r.
        reflexivity.
    - destruct d2.
      * unfold extend_colvec_at_bottom.
        unfold extend_colvec_on_top.
        unfold mk_colvec. unfold coeff_colvec.
        do 9 (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_sub.
        rewrite Nat.add_0_r in Hi.
        rewrite <- Nat.ltb_lt in Hi.
        rewrite Hi. rewrite Rplus_0_l. reflexivity.
      * unfold extend_colvec_at_bottom.
        unfold extend_colvec_on_top.
        unfold mk_colvec. unfold coeff_colvec.
        do 7 (rewrite coeff_mat_bij; try lia).
        rewrite (coeff_mat_bij (m:=(S d1 + S d2))); try lia.
        rewrite Nat.add_sub.
        remember (i <? S d1) as r.
        destruct r.
        - repeat rewrite Rplus_0_r.
          symmetry in Heqr. rewrite Nat.ltb_lt in Heqr.
          rewrite coeff_mat_bij; try lia.
          reflexivity.
        - repeat rewrite Rplus_0_l.
          symmetry in Heqr. rewrite Nat.ltb_ge in Heqr.
          rewrite coeff_mat_bij; try lia.
          reflexivity.
Qed.

Lemma MMmult_block_diag_matrix:
    forall m1 n1 m2 n2 (A1: matrix m1 n1) (A2: matrix m2 n2)
        (v1: colvec n1) (v2: colvec n2),
        Mmult (block_diag_matrix A1 A2) (colvec_concat v1 v2) =
        colvec_concat (Mmult A1 v1) (Mmult A2 v2).
Proof.
    intros m1 n1 m2 n2 A1 A2 v1 v2.
    unfold colvec_concat.
    rewrite (Mmult_distr_l (block_diag_matrix A1 A2) _ _).
    unfold Mplus.
    apply mk_matrix_ext.
    intros i j Hi Hj.
    induction j; try lia.
    destruct (lt_dec i m1) as [Hile|Helt].
    - destruct m1. lia. simpl in Hile.
      assert (H1: coeff_mat zero
        (Mmult (block_diag_matrix A1 A2) (extend_colvec_on_top v2 _)) i 0 = 0). {
        unfold Mmult.
        rewrite coeff_mat_bij; try lia.
        unfold sum_n.
        rewrite <- zero_is_0.
        rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) 0 (pred (n1 + n2))).
        destruct (le_gt_dec (n1 + n2) 0).
        - apply le_n_0_eq in l.
          repeat rewrite <- l at 1. simpl.
          repeat rewrite sum_n_n.
          rewrite (coeff_mat_default _ _ _ _ _ 0 0); try lia.
          apply Rmult_0_r.
        - apply sum_n_m_ext_loc.
          intros n Hn.
          unfold extend_colvec_on_top.
          unfold mk_colvec. unfold coeff_colvec.
          rewrite coeff_mat_bij; try lia.
          rewrite Nat.add_sub.
          remember (n <? n1) as r.
          induction r.
          * apply Rmult_0_r.
          * unfold block_diag_matrix.
            rewrite coeff_mat_bij; try lia.
            apply Nat.ltb_lt in Hile.
            rewrite Hile. rewrite <- Heqr.
            apply Rmult_0_l.
      }
      rewrite H1. rewrite Rplus_0_r.
      assert (H2: coeff_mat zero (
        extend_colvec_on_top (Mmult A2 v2) (S m1 + m2)) i 0 = 0). {
        unfold extend_colvec_on_top. unfold mk_colvec.
        rewrite coeff_mat_bij; try lia.
        rewrite Nat.add_sub.
        apply Nat.ltb_lt in Hile.
        rewrite Hile. reflexivity.
      }
      rewrite H2. rewrite Rplus_0_r.
      unfold Mmult at 1.
      repeat rewrite coeff_mat_bij; try lia.
      unfold sum_n. rewrite (sum_n_m_Chasles _ _ (pred n1) _); try lia.
      rewrite <- (Rplus_0_r (coeff_mat zero
        (extend_colvec_at_bottom (Mmult A1 v1) (S m1 + m2)) i 0)).
      apply f_equal2_plus_R.
      * unfold extend_colvec_at_bottom.
        unfold mk_colvec. unfold coeff_colvec.
        rewrite coeff_mat_bij; try lia.
        rewrite <- Nat.ltb_lt in Hile. rewrite Hile.
        unfold Mmult. rewrite Nat.ltb_lt in Hile.
        rewrite coeff_mat_bij; try lia.
        unfold sum_n. apply sum_n_m_ext_loc.
        intros k Hk.
        induction n1.
        * simpl in Hk.
          destruct Hk as [Hk1 Hk2].
          apply le_n_0_eq in Hk2.
          rewrite <- Hk2. simpl.
          induction n2.
          * rewrite coeff_mat_default; try lia.
            rewrite (coeff_mat_default _ _ _ _ v1); try lia.
            rewrite Rmult_0_l. rewrite Rmult_0_r. reflexivity.
          * rewrite coeff_mat_bij; try lia.
            rewrite (coeff_mat_default _ _ _ _ v1); try lia.
            repeat rewrite Rmult_0_r. reflexivity.
        * rewrite coeff_mat_bij; try lia.
          unfold block_diag_matrix.
          rewrite coeff_mat_bij; try lia.
          rewrite <- Nat.ltb_lt in Hile. rewrite Hile.
          remember (k <? S n1) as r.
          induction r.
          - reflexivity.
          - symmetry in Heqr. rewrite Nat.ltb_ge in Heqr. lia.
      * unfold extend_colvec_at_bottom.
        unfold mk_colvec. unfold coeff_colvec.
        rewrite <- zero_is_0.
        rewrite <- (sum_n_m_const_zero
            (G:=R_AbelianGroup) (S (pred n1)) (pred (n1 + n2))).
        apply sum_n_m_ext_loc.
        intros k Hk.
        rewrite coeff_mat_bij; try lia.
        rewrite sum_n_m_const_zero.
        destruct Hk.
        remember (k <? n1) as r.
        induction r.
        * symmetry in Heqr. rewrite Nat.ltb_lt in Heqr. lia.
        * apply Rmult_0_r.
    - apply not_lt in Helt.
      assert (Hib: i <? m1 = false). {
         rewrite Nat.ltb_ge.
         lia.
      }
      apply f_equal2_plus_R.
      * assert (H1: coeff_mat zero
        (Mmult (block_diag_matrix A1 A2) (extend_colvec_at_bottom v1 _)) i 0 = 0).
        {
            unfold Mmult.
            rewrite coeff_mat_bij; try lia.
            unfold sum_n.
            rewrite <- zero_is_0.
            rewrite <- (sum_n_m_const_zero (G:=R_AbelianGroup) 0 (pred (n1 + n2))).
            apply sum_n_m_ext_loc.
            intros n Hn.
            destruct (le_gt_dec (n1 + n2) 0).
            - apply le_n_0_eq in l.
              rewrite (coeff_mat_default _ _ _ _ _ n 0); try lia.
              apply Rmult_0_r.
            - unfold extend_colvec_at_bottom.
              unfold mk_colvec. unfold coeff_colvec.
              rewrite coeff_mat_bij; try lia.
              unfold block_diag_matrix.
              rewrite coeff_mat_bij; try lia.
              rewrite Hib.
              destruct (n <? n1).
              - apply Rmult_0_l.
              - apply Rmult_0_r.
        }
        rewrite H1.
        assert (H2: coeff_mat zero (
            extend_colvec_at_bottom (Mmult A1 v1) (m1 + m2)) i 0 = 0). {
            unfold extend_colvec_at_bottom. unfold mk_colvec.
            rewrite coeff_mat_bij; try lia.
            rewrite Hib.
            reflexivity.
        }
        rewrite H2.
        reflexivity.
      * unfold extend_colvec_on_top. unfold block_diag_matrix.
        unfold Mmult. unfold mk_colvec. unfold coeff_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        repeat rewrite Nat.add_sub.
        rewrite Hib.
        destruct n1.
        * destruct n2.
          * repeat rewrite sum_n_n.
            repeat rewrite coeff_mat_default; try lia.
            reflexivity.
          * apply sum_n_ext_loc.
            intros n Hn. simpl.
            repeat rewrite coeff_mat_bij; try lia.
            rewrite Hib. rewrite <- zero_is_0.
            rewrite Nat.sub_0_r. reflexivity.
        * rewrite <- (Rplus_0_l (sum_n _ (pred n2))).
          unfold sum_n.
          rewrite (sum_n_m_Chasles _ _ (pred (S n1)) _); try lia.
          apply f_equal2_plus_R.
          - rewrite <- zero_is_0.
            rewrite <- (sum_n_m_const_zero
              (G:=R_AbelianGroup) 0 (pred (S n1))).
            apply sum_n_m_ext_loc.
            intros k Hk.
            rewrite coeff_mat_bij; try lia.
            rewrite Hib.
            destruct Hk.
            simpl in H0.
            apply le_lt_n_Sm in H0.
            rewrite <- Nat.ltb_lt in H0.
            rewrite H0.
            rewrite sum_n_m_const_zero.
            rewrite Rmult_0_l. apply zero_is_0.
        - destruct n2.
          * rewrite sum_n_m_zero; try lia.
            rewrite sum_n_n.
            rewrite (coeff_mat_default _ _ _ _ v2); try lia.
            rewrite Rmult_0_r. apply zero_is_0.
          * rewrite (sum_n_m_shift _ 0 _ (S (pred (S n1)))). simpl.
            rewrite <- Nat.add_succ_comm.
            rewrite (Nat.add_comm n2 _).
            apply sum_n_m_ext_loc.
            intros k Hk.
            repeat (rewrite coeff_mat_bij; try lia).
            rewrite Hib.
            remember (k <? S n1) as r.
            induction r.
            * symmetry in Heqr. rewrite Nat.ltb_lt in Heqr. lia.
            * rewrite <- zero_is_0. reflexivity.
Qed.

Lemma dot_concat:
    forall d1 d2 (v1: colvec d1) (v2:colvec d2) v3 v4,
      dot (colvec_concat v1 v2) (colvec_concat v3 v4) =
      dot v1 v3 + dot v2 v4.
Proof.
    intros d1 d2 v1 v2 v3 v4.
    unfold dot.
    unfold Mmult.
    repeat (rewrite coeff_mat_bij; try lia).
    unfold sum_n.
    destruct d1.
    * destruct d2.
      - simpl. repeat rewrite sum_n_n.
        repeat rewrite coeff_mat_default; try lia.
        rewrite Rmult_0_l. rewrite Rplus_0_l. reflexivity.
      - simpl.
        rewrite sum_n_n.
        rewrite coeff_mat_default; try lia.
        rewrite Rmult_0_l. rewrite Rplus_0_l.
        apply sum_n_ext_loc.
        intros n Hn.
        unfold transpose.
        unfold colvec_concat.
        unfold Mplus.
        unfold extend_colvec_at_bottom.
        unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        repeat rewrite extend_colvec_on_top_same_dim.
        simpl. repeat rewrite Rplus_0_l.
        reflexivity.
    * destruct d2.
      - simpl.
        rewrite Nat.add_0_r at 1.
        rewrite sum_n_n.
        rewrite coeff_mat_default; try lia.
        rewrite Rmult_0_l. rewrite Rplus_0_r.
        apply sum_n_m_ext_loc.
        intros k Hk.
        unfold transpose.
        unfold colvec_concat.
        unfold Mplus.
        unfold extend_colvec_on_top.
        unfold extend_colvec_at_bottom.
        unfold mk_colvec.
        repeat (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_sub.
        destruct Hk as [Hk1 Hk2].
        apply le_lt_n_Sm in Hk2.
        rewrite <- Nat.ltb_lt in Hk2.
        rewrite Hk2. repeat rewrite Rplus_0_r.
        reflexivity.
      - rewrite (sum_n_m_Chasles _ _ (d1) (pred (S d1 + S d2))); try lia.
        apply f_equal2_plus_R.
        * simpl.
          apply sum_n_ext_loc.
          intros n Hn.
          unfold transpose.
          unfold colvec_concat.
          unfold Mplus.
          unfold extend_colvec_at_bottom.
          unfold extend_colvec_on_top.
          unfold mk_colvec.
          repeat (rewrite coeff_mat_bij; try lia).
          rewrite Nat.add_sub.
          apply le_lt_n_Sm in Hn.
          rewrite <- Nat.ltb_lt in Hn.
          rewrite Hn.
          repeat rewrite Rplus_0_r.
          unfold coeff_colvec.
          reflexivity.
        * rewrite (sum_n_m_shift _ 0 (pred (S d2)) (S d1)).
          rewrite Nat.add_pred_l; try lia.
          rewrite (Nat.add_comm (S d2) (S d1)).
          rewrite Nat.add_0_l.
          apply sum_n_m_ext_loc.
          intros k Hk.
          unfold transpose.
          unfold colvec_concat.
          unfold Mplus.
          unfold extend_colvec_at_bottom.
          unfold extend_colvec_on_top.
          unfold mk_colvec.
          repeat (rewrite coeff_mat_bij; try lia).
          destruct Hk as [H1 H2].
          rewrite Nat.add_sub.
          rewrite <- Nat.ltb_ge in H1. rewrite H1.
          repeat rewrite Rplus_0_l.
          unfold coeff_colvec.
          reflexivity.
Qed.

Lemma colvec_split:
    forall dim1 dim2 v,
        exists v1 v2,
            v1 = (mk_colvec dim1 (fun i => coeff_colvec 0 v i)) /\
            v2 = (mk_colvec dim2 (fun i => coeff_colvec 0 v (i + dim1))) /\
            v = colvec_concat v1 v2.
Proof.
    intros dim1 dim2 v.
    exists (mk_colvec dim1 (fun i => coeff_colvec 0 v i)).
    exists (mk_colvec dim2 (fun i => coeff_colvec 0 v (i + dim1))).
    repeat (split; try reflexivity).
    unfold colvec_concat.
    unfold extend_colvec_at_bottom.
    unfold extend_colvec_on_top.
    unfold mk_colvec. unfold coeff_colvec.
    unfold Mplus.
    induction dim1.
    - induction dim2.
      * apply unique_colvec_0.
    all: (
        rewrite <- (mk_matrix_bij 0 v);
        apply mk_matrix_ext;
        intros i j Hi Hj
    ).
      * rewrite coeff_mat_bij; try lia.
        rewrite Rplus_0_l.
        rewrite coeff_mat_bij; try lia.
        rewrite Nat.sub_diag.
        rewrite coeff_mat_bij; try lia.
        rewrite coeff_mat_bij; try lia.
        rewrite Nat.add_0_r. rewrite Nat.sub_0_r.
        induction j.
        * reflexivity.
        * lia.
    - induction j; try lia.
      rewrite coeff_mat_bij; try lia.
      remember (i <? S dim1) as r.
      destruct r.
      * symmetry in Heqr. apply Nat.ltb_lt in Heqr.
        do 3 (rewrite coeff_mat_bij; try lia).
        rewrite Nat.add_sub.
        apply Nat.ltb_lt in Heqr. rewrite Heqr.
        rewrite Rplus_0_r. reflexivity.
      * rewrite Rplus_0_l.
        rewrite coeff_mat_bij; try lia.
        rewrite Nat.add_sub.
        symmetry in Heqr.
        rewrite Heqr. apply Nat.ltb_ge in Heqr.
        rewrite coeff_mat_bij; try lia.
        rewrite coeff_mat_bij; try lia.
        rewrite Nat.sub_add; try lia.
        reflexivity.
Qed.

End ReshapeOperations.

Module MatrixNotations.

Declare Scope colvec_scope.
Delimit Scope colvec_scope with v.
Bind Scope colvec_scope with colvec.

Notation "A * B" := (dot A B) : colvec_scope.

Declare Scope matrix_scope.
Delimit Scope matrix_scope with M.

Notation "A * B" := (Mmult A B) : matrix_scope.
Notation "A + B" := (Mplus A B) : matrix_scope.

Declare Scope scalar_scope.
Delimit Scope scalar_scope with scalar.

Notation "c * M" := (scalar_mult c M) : scalar_scope.

End MatrixNotations.


Load "5_bag_more_functions.v".

Theorem count_member_nonzero : forall (s : bag), Nat.leb 1 (count 1 (cons 1 s)) = true.
Proof.
  simpl. intros proof_bag. reflexivity.
Qed.

Theorem ble_n_Sn : forall n, Nat.leb n (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl. reflexivity.
  - (* S n' *)
    simpl. rewrite IHn'. reflexivity.
Qed.

Theorem remove_decreases_count: forall (s : bag), Nat.leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros.
  induction s.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. case (Nat.eqb n 0) eqn:Hn.
    + (* n == 0 *) simpl. rewrite ble_n_Sn. reflexivity.
    + (* n != 0 *) simpl. rewrite Hn. rewrite IHs. reflexivity.
Qed.


(** * 3. Coq でのプログラミング *)
(** 3.2 再帰的な型と関数 *)
Module Section3_2.

(** 自然数 nat について *)
Print nat.
(* Inductive nat : Set :=
   O : nat
 | S : nat -> nat
*)

Eval compute in (S (S (S O))).

(** 自然数の加法 *)
Fixpoint add(n m:nat):nat :=
match n with
| O => m
| S n' => S (add n' m)
end.

Eval compute in (add (S (S O)) (S (S (S O)))).

(** 自然数の比較 *)
Fixpoint eq_nat(n m:nat):bool :=
match n,m with
| O,O => true
| S n', S m' => eq_nat n' m'
| _,_ => false
end.

Eval compute in (eq_nat 3 3).
Eval compute in (eq_nat 3 2).

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

Eval compute in (le_nat 2 3).  (* = true *)
Eval compute in (le_nat 3 3).  (* = true *)
Eval compute in (le_nat 4 3).  (* = false *)

(** 再帰関数の停止性 *)
Fixpoint add'(n m:nat){struct n}:nat :=
match n with
| O => m
| S n' => S (add n' m)
end.

(** 課題２：自然数の関数 *)
(* 1. 掛け算を行う関数 mul を add を参考に定義せよ。 *)
Fixpoint mul(n m:nat) :=
match n with
| O => O
| S n' => add m (mult n' m)
end.

Eval compute in (mul 2 3). (* = 6 *)

(* 2. mul を用いて階乗を計算する関数 fact を定義せよ。*)
Fixpoint fact(n:nat) :=
match n with
| O => 1
| S n' => mult n (fact n')
end.

Eval compute in (fact 4). (* = 24 *)

(* 3. 引き算を行う関数 sub を定義してみよ。但し n = 0 の場合は sub 0 m = 0と定義する。*)
Fixpoint sub(n m:nat):nat :=
match n,m with
| O,_ => O
| _,O => n
| S n',S m' => sub n' m'
end.

Eval compute in (sub 5 2). (* = 3 *)
Eval compute in (sub 4 4). (* = 0 *)
Eval compute in (sub 2 5). (* = 0 *)

(* 4. 次の関数 div3 は何を計算する関数か考えよ。また Eval を用いて 動作を確認してみよ。*)
Fixpoint div3(n:nat) :=
match n with
| S (S (S n')) => S (div3 n')
| _ => O
end.

Eval compute in (div3 2).
Eval compute in (div3 6).
Eval compute in (div3 7).

End Section3_2.

(** 3.3 多相型 *)
Module Section3_3.

(** 多相型とは *)
Definition cond{A:Set}(c:bool)(vt vf:A) : A :=
match c with
| true => vt
| false => vf
end.

Eval compute in (cond true 2 3).
Eval compute in (cond false false true).
Eval compute in (@cond nat false 2 3).

(** option型 *)
Print option.
(* Inductive option (A : Type) : Type :=  Some : A -> option A | None : option A *)

Definition option_map {A B:Type}(f:A->B)(o:option A) :=
match o with
| Some a => Some (f a)
| None => None
end.

Eval compute in (option_map (fun x => x+1) (Some 1)).
Eval compute in (option_map (fun x => x+1) None).

(** prod型とsum型 *)

Print prod.
(* Inductive prod (A B : Type) : Type :=  pair : A -> B -> A * B *)

Print sum.
(* Inductive sum (A B : Type) : Type :=  inl : A -> A + B | inr : B -> A + B *)

Check (2,true,3).

Definition test_sum(s:sum nat bool) :=
match s with
| inl n => n
| inr true => 1
| inr false => 0
end.

(** List型 *)
Require Import List.
Print list.
(* Inductive list (A : Type) : Type :=
    nil : list A
  | cons : A -> list A -> list A
*)

Check (1::2::nil).

(** List に対する再帰関数 *)
(* Listの連結 *)
Fixpoint append{A:Type}(xs ys:list A):=
match xs with
| nil => ys
| x::xs' => x::(append xs' ys)
end.
Eval compute in (append (1::2::nil) (3::4::nil)).

(* Listの最後の要素 *)
Fixpoint olast{A:Type}(xs:list A):option A :=
match xs with
| nil => None
| a::nil => Some a
| _::xs' => olast xs'
end.
Eval compute in (olast (1::2::3::nil)).
Eval compute in (olast (1::nil)).
Eval compute in (olast (@nil nat)).

(** 課題３：Listへの関数 *)
(* 1. リストの長さを与える関数 len{A:Type}(xs:list A):nat を定義 せよ。*)
Fixpoint len{A:Type}(xs:list A):nat :=
match xs with
| nil => O
| _::xs' => S (len xs')
end.

Eval compute in (len (1::2::3::nil)). (* = 3 *)

(* 2. list bool の入力を受け取り、全要素が true の時 true を返す関数
 all_true(xs:list bool):bool を定義せよ。
但し nil に対し ては true を返すとせよ。*)
Fixpoint all_true(xs:list bool):bool :=
match xs with
| nil => true
| x::xs' => andb x (all_true xs')
end.
Eval compute in (all_true (@nil bool)).  (* = true *)
Eval compute in (all_true (true::true::nil)).  (* = true *)
Eval compute in (all_true (true::true::false::nil)).  (* = false *)

(* 3. リストの先頭要素 x があれば Some x を、空リストに対しては
None を返す、関数 ohead{A:Type}(xs:list A):option A を
定義せよ。*)
Definition ohead{A:Type}(xs:list A):option A :=
match xs with
| nil => None
| a::_ => Some a
end.

Eval compute in (ohead (@nil nat)).  (* = None *)
Eval compute in (ohead (1::nil)).  (* = Some 1 *)
Eval compute in (ohead (1::2::nil)).  (* = Some 1 *)

(* 4. 自然数s,nに対してs :: s+1 :: ... :: (s+n-1) :: nilを
 返す関数 nat_list(s n:nat):list nat を定義せよ。*)
Fixpoint nat_list(s n:nat):list nat :=
match n with
| O => nil
| S n' => s::(nat_list (S s) n')
end.

Eval compute in (nat_list 3 5).  (* = 3::4::5::6::7::nil *)

(* 5. リストを反転する関数 reverse{A:Type}(xs:list A):list A を
 定義せよ。必要なら append を使え。*)
Fixpoint reverse{A:Type}(xs:list A):list A :=
match xs with
| nil => nil
| x::xs' => append (reverse xs') (x::nil)
end.

Eval compute in (reverse (1::2::3::nil)). (* =  3::2::1::nil *)

End Section3_3.


(* CS 499 - Mechanized Reasoning about Programs *)
(* Copyright Northern Arizona University        *)
(* All rights reserved                          *)

Require Import Arith ZArith List String Project2.
Import ListNotations.
(** * Arithmetic Expressions *)

Module Aexp.

  (** * The type of arithmetic expressions *)

  Inductive binary_op : Type :=
    Add | Mul | Sub.

  Inductive t : Type :=
  | Int: Z -> t
  | Var: Id.t -> t
  | Binop : binary_op -> t -> t -> t.

  Definition get_op (op: binary_op): Z->Z->Z :=
    match op with
    | Add => Z.add
    | Mul => Z.mul
    | Sub => Z.sub
    end.

  (** ** Evaluation of expressions *)
  Fixpoint A (a:Aexp.t) (s:Id.t -> Z) : Z :=
    match a with
    | Aexp.Int z => z
    | Aexp.Var id => s id
    | Aexp.Binop op a1 a2 => (Aexp.get_op op) (A a1 s) (A a2 s)
    end.

Module Notations.

    (* Coercions *)
    Coercion Int : Z >-> t.
    Coercion Var : Id.t >-> t.

    (* Notations *)
    Notation "a0 + a1" := (Binop Add a0 a1).
    Notation "a0 - a1" := (Binop Sub a0 a1).
    Notation "a0 * a1" := (Binop Mul a0 a1).

End Notations.

  (* Examples of expressions *)
Module Ex_t.
    Import Notations.

    Definition x : Id.t := Id.Id 0.
    Definition y : Id.t := Id.Id 1.
    Definition z : Id.t := Id.Id 2.

    (* Warning: scope Z is not opened! *)
    Definition a0 : t := Binop Add x 1%Z.
    Definition a1 : t := Binop Add x 1.
    Print a0. (* 1%Z is considered as a numerical constant *)
    Print a1. (* 1 is considered as an identifier! *)

    Definition a2 : t := z - (x * (y + 1)).
  End Ex_t.

  (* Examples of evaluation *)
  Module Ex_A.
    Import Ex_t.

    Definition s :=
      fun z =>
        if Id.beq z x then 42%Z else
          if Id.beq z y then 0%Z else 0%Z.

    Example ex0 : A a0 s = 43%Z.
    Proof. simpl. trivial. Qed.

    Example ex1 : A a1 s = 42%Z.
    Proof. simpl. trivial. Qed.

    Example ex2 : A a2 s = 0%Z.
    Proof. simpl. trivial. Qed.

  End Ex_A.

  (** ** Free variables *)

  (* Instead of using a set of variables, we will use lists, and allow
     a variable to be present several times in the list. *)
  Fixpoint FV (a:t) : list Id.t :=
    match a with
    | Int z   => []
    | Var id  => [id]
    | Binop op a1 a2 => List.app (FV a1) (FV a2)
    end.

  Lemma lemma_1_12:
    forall (s s':State.t) (a:t),
      (forall x, In x (FV a) -> s x = s' x) ->
      A a s = A a s'.
  Proof.
    intros s s' a H.
    induction a as [ z | x | op a1 IH1 a2 IH2].
    - simpl. trivial.
    - simpl. apply H.
      simpl. left. reflexivity.
    - assert(A a1 s = A a1 s') as H1.
      {
        apply IH1.
        intros x Hx.
        apply H. simpl.
        apply in_or_app.
        left. assumption.
      }
      assert(A a2 s = A a2 s') as H2.
      {
        apply IH2.
        intros x Hx.
        apply H. simpl.
        apply in_or_app.
        right. assumption.
      }
      simpl.
      rewrite H1, H2.
      trivial.
  Qed.

  (** ** Substitution *)
  Fixpoint subst (a:t) (y:Id.t) (a0:t) : t :=
    match a with
    | Int z  =>  Int z
    | Var id =>  if Id.beq id y
                then a0
                else Var id
    | Binop op a1 a2 =>
      Binop op (subst a1 y a0) (subst a2 y a0)
    end.

  (** Lemma (Exercice) 1.14 (page 18) of Semantics with Applications
      is written as follows: A[a[y →a0]]s = A[a](s[y →A[a0]s]) for all
      states s.

      A direct ``translation'' one could think of in would be: forall
      s a a0 y, A (subst a y a0) s = A a (State.update s y (A a0 s)).

      However (A a0 s) has type option Z, whereas function
      State.update expect its third argument to be of type Z.

      Therefore the correct statement in Coq is as follows: *)
  Lemma lemma_1_14:
    forall (s:State.t)(a a0:t)(y:Id.t),
      A (subst a y a0) s = A a (State.update s y (A a0 s)).
  Proof.
    intros s a a0 y.
    induction a as [ z | x | op a1 IH1 a2 IH2 ].
    - trivial.
    - unfold State.update. simpl.
      destruct (Id.beq x y).
      + trivial.
      + trivial.
    - simpl.
      now rewrite IH1, IH2.
  Qed.

End Aexp.

(** * Boolean expressions *)

Module Bexp.

  (** ** Definition of boolean expressions *)
  Inductive cmp_op : Type :=
    Equal | LowerEq.

  Definition get_cmp (cmp: cmp_op) : Z -> Z -> bool :=
    match cmp with
    | Equal => Z.eqb
    | LowerEq => Z.leb
    end.

  Inductive t : Type :=
  | Bool: bool -> t      (* Constant: true or false *)
  | Neg: t -> t       (* negation of an expression *)
  | And: t -> t -> t   (* conjunction of two boolean expressions *)
  | Cmp: cmp_op -> Aexp.t -> Aexp.t -> t
                     (* comparison of two arithmetic expressions *)
  .

  (** ** Notations *)
  Module Notations.

    Coercion Bool : bool >-> t.
    Notation "! b":=(Neg b)(at level 70).
    Infix "&&" := And.
    Notation "a1 == a2" := (Cmp Equal a1 a2)(at level 70).
    Notation "a1 <= a2" := (Cmp LowerEq a1 a2)(at level 70).

  End Notations.

  (** ** Examples *)
  Module Ex_t.
    Import Aexp.Notations Notations Aexp.Ex_t.

    Definition b1 : t := true.
    Definition b2 : t := !(a1 == 0%Z).
    Definition b3 : t := (0%Z <= x) && (x <= y).

  End Ex_t.

  Fixpoint B (b:Bexp.t) (s:Id.t -> Z) : bool :=
  match b with
  | Bexp.Bool b => b
  | Bexp.Neg b  => negb(B b s)
  | Bexp.And b1 b2 => andb (B b1 s) (B b2 s)
  | Bexp.Cmp cmp a1 a2 => (Bexp.get_cmp  cmp) (Aexp.A a1 s) (Aexp.A a2 s)
  end.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import Coq.Classes.Morphisms
  Coq.micromega.Lia Sigma.Algebra.Hierarchy
  Sigma.Algebra.Monoid Sigma.Algebra.Group
  Sigma.Algebra.Ring.
Require Coq.setoid_ring.Integral_domain
  Coq.setoid_ring.Ncring Coq.setoid_ring.Cring.

(* https://github.com/coq/coq/blob/master/theories/setoid_ring/Integral_domain.v *)
Section IntegralDomain.

  Context
    {T eq zero one opp add sub mul}
    {Hi:@integral_domain T eq zero one opp add sub mul}.

  Lemma nonzero_product_iff_nonzero_factors :
      forall x y : T,
      ~eq (mul x y) zero <-> ~eq x zero /\ ~eq y zero.
  Proof.
    setoid_rewrite ring_zero_product_iff_zero_factor.
    intuition.
  Qed.

  (* This is from the Coq library *)
  Global Instance Intdom :
    @Integral_domain.Integral_domain
      T zero one add mul sub opp eq _ _ _.
  Proof.
    split.
    apply zero_product_zero_factor.
    apply one_neq_zero.
  Defined.

End IntegralDomain.


Require Import Coq.FSets.FSetInterface.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Graph.
Require Import Forest.
Require Import Path.
Require Import Coq.Init.Nat.

Module Type DFSBase (O: UsualOrderedType)(S: FSetInterface.Sfun O)(G: Graph O S)(F: Forest O S).

  Module P := (Path.PathTheories O S G).

  Definition times_function := G.vertex -> nat.

  Parameter dfs : option G.vertex -> G.graph -> (F.forest *  times_function * times_function).

  Parameter state : option G.vertex -> G.graph -> Type.

  Definition d_time o g := match (dfs o g) with
                           | (_, f, _) => f
                           end.

  Definition f_time o g := match (dfs o g) with
                           | (_, _, f) => f
                           end.

  Definition dfs_forest o g := match (dfs o g) with
                           | (f, _, _) => f
                           end.

  (*

  Parameter f_time : G.graph -> G.vertex -> nat.

  Parameter d_time : G.graph -> G.vertex -> nat.*)

  Parameter time_of_state: forall o g, state o g -> nat.

  (* States must exist*)
  Parameter discovery_exists: forall o g v,
    G.contains_vertex g v = true ->
    exists (s: state o g), time_of_state o g s = d_time o g v.

  Parameter finish_exists: forall o g v,
    G.contains_vertex g v = true ->
    exists (s: state o g), time_of_state o g s = f_time o g v.

  Parameter white: forall (o : option G.vertex) (g : G.graph), state o g -> G.vertex -> bool.

  Parameter white_def: forall o g s v,
    white o g s v = true <-> ltb (time_of_state o g s) (d_time o g v) = true.

  Parameter gray: forall (o : option G.vertex) (g : G.graph), state o g -> G.vertex -> bool.

  Parameter gray_def: forall o g s v,
    gray o g s v = true <-> ltb (time_of_state o g s) (f_time o g v) && leb (d_time o g v) (time_of_state o g s) = true.

  Parameter black:forall (o : option G.vertex) (g : G.graph), state o g -> G.vertex -> bool.

  Parameter black_def: forall o g s v,
    black o g s v = true <-> leb (f_time o g v) (time_of_state o g s) = true.

  Parameter state_time_unique: forall g o (s s': state o g),
    time_of_state o g s = time_of_state o g s' <-> s = s'.

  (* Some needed results about uniqueness of times *)
  Parameter d_times_unique: forall o g u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    d_time o g u = d_time o g v <-> u = v.

  Parameter f_times_unique: forall o g u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    f_time o g u = f_time o g v <-> u = v.

  Parameter all_times_unique:
    forall o g u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    f_time o g u <> d_time o g v.

  (*Major Results*)
  Parameter parentheses_theorem: forall o g u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    u <> v ->
    (d_time o g u < d_time o g v /\ d_time o g v < f_time o g v /\ f_time o g v < f_time o g u) \/
    (d_time o g v < d_time o g u /\ d_time o g u < f_time o g u /\ f_time o g u < f_time o g v) \/
    (d_time o g u < f_time o g u /\ f_time o g u < d_time o g v /\ d_time o g v < f_time o g v) \/
    (d_time o g v < f_time o g v /\ f_time o g v < d_time o g u /\ d_time o g u < f_time o g u).

  Parameter descendant_iff_interval: forall o g u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    F.desc (dfs_forest o g) u v <->
     (d_time o g u < d_time o g v /\ d_time o g v < f_time o g v /\ f_time o g v < f_time o g u).

  Parameter white_path_theorem: forall o g u v,
    G.contains_vertex g u = true ->
    F.desc (dfs_forest o g) u v <-> (forall s, time_of_state o g s = d_time o g u ->
    exists l, P.path_list_ind g u v (fun x => white o g s x) l).

  (* Basic results about vertices and edges *)
  Parameter same_vertices: forall o g v,
    G.contains_vertex g v = true <-> F.contains_vertex (dfs_forest o g) v = true.

  Parameter same_edges: forall o g u v,
    F.is_child (dfs_forest o g) u v = true -> G.contains_edge g u v = true.

  (*Why we care about starting from a specific vertex*)
  Parameter start_vertex: forall g v u,
    G.contains_vertex g v = true ->
    G.contains_vertex g u = true ->
    v <> u ->
    d_time (Some v) g v < d_time (Some v) g u.

  (*Definitions for applications of DFS*)

  Parameter back_edge : G.graph -> G.vertex -> G.vertex -> option G.vertex -> Prop.

  (*Gets around declaring definition in interface: see if better way*)
  Parameter back_edge_def: forall g u v o,
    back_edge g u v o <-> (G.contains_edge g u v = true /\ F.desc (dfs_forest o g) v u).

  Parameter rev_f_time: option G.vertex -> G.graph -> G.vertex -> G.vertex -> Prop.

  Parameter rev_f_time_def: forall o g u v,
    rev_f_time o g u v <-> f_time o g u > f_time o g v.

  (*(*The point of using an OrderedType*)
  Parameter root_smallest: forall v g s,
    time_of_state None g s = d_time None g v ->
    F.is_root (dfs_forest None g) v = true ->
    (forall u, G.contains_vertex g u = true -> white None g s u = true -> O.lt v u).*)

End DFSBase.

Module Type DFSWithCycleDetect(O: UsualOrderedType)(S: FSetInterface.Sfun O)(G: Graph O S)(F: Forest O S).
  Include (DFSBase O S G F).

  Parameter cycle_detect: option G.vertex -> G.graph -> bool.

  Parameter cycle_detect_back_edge: forall g o,
    cycle_detect o g = true <-> exists u v, back_edge g u v o.

End DFSWithCycleDetect.

Module Type DFSWithTopologicalSort(O: UsualOrderedType)(S: FSetInterface.Sfun O)(G: Graph O S)(F: Forest O S).
  Include (DFSBase O S G F).

  (*We have an additional function that produces a list of vertices reverse sorted by finish time*)
  Parameter rev_f_time_list: G.graph -> option G.vertex  -> list (G.vertex).

  Parameter topological_sort_condition: forall g o,
    (forall v, G.contains_vertex g v = true <-> In v (rev_f_time_list g o)) /\
    StronglySorted (rev_f_time o g) (rev_f_time_list g o).

End DFSWithTopologicalSort.

Module Type DFSCustomOrder (O: UsualOrderedType)(S: FSetInterface.Sfun O)(G: Graph O S)(F: Forest O S).

  Module P := (Path.PathTheories O S G).
  Module G' := (Graph.GraphOrder O S G).
  Section Whole.
    Context (g: G.graph) (lt' : O.t -> O.t -> bool) (Ho : G'.GraphOrdering g lt').

  Definition times_function := G.vertex -> nat.

  Parameter dfs:
       G'.GraphOrdering g lt' -> option G.vertex -> F.forest * times_function * times_function.

  Parameter state : G'.GraphOrdering g lt' ->
   option G.vertex -> Type.

  Definition d_time o := match (dfs Ho o) with
                           | (_, f, _) => f
                           end.

  Definition f_time o := match (dfs Ho o) with
                           | (_, _, f) => f
                           end.

  Definition dfs_forest o := match (dfs Ho o) with
                           | (f, _, _) => f
                           end.

  (*

  Parameter f_time : G.graph -> G.vertex -> nat.

  Parameter d_time : G.graph -> G.vertex -> nat.*)

  Parameter time_of_state: forall o, state Ho o  -> nat.

  (* States must exist*)
  Parameter discovery_exists: forall o v,
    G.contains_vertex g v = true ->
    exists (s: state Ho o), time_of_state o s = d_time o v.

  Parameter finish_exists: forall o v,
    G.contains_vertex g v = true ->
    exists (s: state Ho o), time_of_state o s = f_time o v.

  Parameter white: forall (o : option G.vertex), state Ho o -> G.vertex -> bool.

  Parameter white_def: forall o s v,
    white o s v = true <-> ltb (time_of_state o s) (d_time o v) = true.

  Parameter gray: forall (o : option G.vertex), state Ho o -> G.vertex -> bool.

  Parameter gray_def: forall o s v,
    gray o s v = true <-> ltb (time_of_state o s) (f_time o v) && leb (d_time o v) (time_of_state o s) = true.

  Parameter black:forall (o : option G.vertex), state Ho o -> G.vertex -> bool.

  Parameter black_def: forall o s v,
    black o s v = true <-> leb (f_time o v) (time_of_state o s) = true.

  Parameter state_time_unique: forall o (s s': state Ho o),
    time_of_state o s = time_of_state o s' <-> s = s'.

  (* Some needed results about uniqueness of times *)
  Parameter d_times_unique: forall o u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    d_time o u = d_time o v <-> u = v.

  Parameter f_times_unique: forall o u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    f_time o u = f_time o v <-> u = v.

  Parameter all_times_unique:
    forall o u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    f_time o u <> d_time o v.

  (*Major Results*)
  Parameter parentheses_theorem: forall o u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    u <> v ->
    (d_time o u < d_time o v /\ d_time o v < f_time o v /\ f_time o v < f_time o u) \/
    (d_time o v < d_time o u /\ d_time o u < f_time o u /\ f_time o u < f_time o v) \/
    (d_time o u < f_time o u /\ f_time o u < d_time o v /\ d_time o v < f_time o v) \/
    (d_time o v < f_time o v /\ f_time o v < d_time o u /\ d_time o u < f_time o u).

  Parameter descendant_iff_interval: forall o u v,
    G.contains_vertex g u = true ->
    G.contains_vertex g v = true ->
    F.desc (dfs_forest o) u v <->
     (d_time o u < d_time o v /\ d_time o v < f_time o v /\ f_time o v < f_time o u).

  Parameter white_path_theorem: forall o u v,
    G.contains_vertex g u = true ->
    F.desc (dfs_forest o) u v <-> (forall s, time_of_state o s = d_time o u ->
    exists l, P.path_list_ind g u v (fun x => white o s x) l).

  (* Basic results about vertices and edges *)
  Parameter same_vertices: forall o v,
    G.contains_vertex g v = true <-> F.contains_vertex (dfs_forest o) v = true.

  Parameter same_edges: forall o u v,
    F.is_child (dfs_forest o) u v = true -> G.contains_edge g u v = true.

  (*Why we care about starting from a specific vertex*)
  Parameter start_vertex: forall v u,
    G.contains_vertex g v = true ->
    G.contains_vertex g u = true ->
    v <> u ->
    d_time (Some v) v < d_time (Some v) u.

 (* (*Definitions for applications of DFS*)

  Parameter back_edge : G.graph -> G.vertex -> G.vertex -> option G.vertex -> Prop.

  (*Gets around declaring definition in interface: see if better way*)
  Parameter back_edge_def: forall u v o,
    back_edge g u v o <-> (G.contains_edge g u v = true /\ F.desc (dfs_forest o) v u).

  Parameter rev_f_time: option G.vertex -> G.graph -> G.vertex -> G.vertex -> Prop.

  Parameter rev_f_time_def: forall o u v,
    rev_f_time o g u v <-> f_time o u > f_time o v.*)

  (*The point of using a GraphOrdering*)
  Parameter root_smallest: forall v s,
    time_of_state None s = d_time None v ->
    F.is_root (dfs_forest None) v = true ->
    (forall u (H2: G.contains_vertex g u = true), white None s u = true -> lt' v u = true).
  End Whole.
End DFSCustomOrder.