Require Import List.
Require Import String.
Require Import ZArith.
Open Scope string_scope.

Definition var := string.

Inductive Expr : Set :=
| Bool : bool -> Expr
| Int : Z -> Expr
| Var : var -> Expr
| App : Expr -> Expr -> Expr
| Cond : Expr -> Expr -> Expr -> Expr
| Prod : Expr -> Expr -> Expr
| ProjL : Expr -> Expr
| ProjR : Expr -> Expr
| SumL : Expr -> Expr
| SumR : Expr -> Expr
| Match : Expr -> var -> Expr -> var -> Expr -> Expr
| Lam : var -> Expr -> Expr.

Notation "'B' b" := (Bool b) (at level 48).
Notation "'I' i" := (Int i) (at level 48).
Notation "'V' x" := (Var x) (at level 48).
Notation "e1 @ e2" := (App e1 e2) (at level 49).
Notation "'WHEN' e1 'THEN' e2 'ELSE' e3" := (Cond e1 e2 e3) (at level 49).
Notation "<( e1 , e2 )>" := (Prod e1 e2) (at level 49).
Notation "'PL' e" := (ProjL e) (at level 49).
Notation "'PR' e" := (ProjR e) (at level 49).
Notation "'SL' e" := (SumL e) (at level 49).
Notation "'SR' e" := (SumR e) (at level 49).
Notation "'MATCH' e1 'WITH' 'L' v2 ===> e2 | 'R' v3 ===> e3" :=
  (Match e1 v2 e2 v3 e3) (at level 49).
Notation "\ x , t" := (Lam x t) (at level 50).

Check (\"x", \"y", V"x").
Check (\"x", \"y", I 5).
Check ((\"x", V"x" @ V"x") @ (\"x", V"x" @ V"x")).

(* e1[e2/x] = e3 *)
Inductive Subst : Expr -> Expr -> var ->
                  Expr -> Prop :=
| SubstBool : forall b e x,
  Subst (B b) e x (B b)
| SubstInt : forall i e x,
  Subst (I i) e x (I i)
| SubstVar_same : forall e x,
  Subst (V x) e x e
| SubstVar_diff : forall e x1 x2,
  x1 <> x2 ->
  Subst (V x1) e x2 (V x1)
| SubstApp : forall eA eB e x eA' eB',
  Subst eA e x eA' ->
  Subst eB e x eB' ->
  Subst (eA @ eB) e x (eA' @ eB')
| SubstCond : forall e1 e2 e3 e x e1' e2' e3',
  Subst e1 e x e1' ->
  Subst e2 e x e2' ->
  Subst e3 e x e3' ->
  Subst (WHEN e1 THEN e2 ELSE e3) e x
        (WHEN e1' THEN e2' ELSE e3')
| SubstProd: forall e1 e2 e x e1' e2',
  Subst e1 e x e1' ->
  Subst e2 e x e2' ->
  Subst (<(e1, e2)>) e x (<(e1', e2')>)
| SubstProjL: forall e1 e x e1',
  Subst e1 e x e1' ->
  Subst (PL e1) e x (PL e1')
| SubstProjR: forall e1 e x e1',
  Subst e1 e x e1' ->
  Subst (PR e1) e x (PR e1')
| SubstSumL: forall e1 e x e1',
  Subst e1 e x e1' ->
  Subst (SL e1) e x (SL e1')
| SubstSumR: forall e1 e x e1',
  Subst e1 e x e1' ->
  Subst (SR e1) e x (SR e1')
| SubstMatch_ls_rs:
  forall em el er e x em',
  Subst em e x em' ->
  Subst (MATCH em WITH L x ===> el | R x ===> er) e x
        (MATCH em' WITH L x ===> el | R x ===> er)
| SubstMatch_ls_rd:
  forall em el vr er e x em' er',
  x <> vr ->
  Subst em e x em' ->
  Subst er e x er' ->
  Subst (MATCH em WITH L x ===> el | R vr ===> er) e x
        (MATCH em' WITH L x ===> el | R vr ===> er')
| SubstMatch_ld_rs:
  forall em vl el er e x em' el',
  x <> vl ->
  Subst em e x em' ->
  Subst el e x el' ->
  Subst (MATCH em WITH L vl ===> el | R x ===> er) e x
        (MATCH em' WITH L vl ===> el' | R x ===> er)
| SubstMatch_ld_rd:
  forall em vl el vr er e x em' el' er',
  x <> vl ->
  x <> vr ->
  Subst em e x em' ->
  Subst el e x el' ->
  Subst er e x er' ->
  Subst (MATCH em WITH L vl ===> el | R vr ===> er) e x
        (MATCH em' WITH L vl ===> el' | R vr ===> er')
| SubstLam_same : forall eA e x,
  Subst (\x, eA) e x (\x, eA)
| SubstLam_diff : forall eA e x1 x2 eA',
  x1 <> x2 ->
  Subst eA e x2 eA' ->
  Subst (\x1, eA) e x2 (\x1, eA').

Lemma subst_test_1:
  Subst (\"x", V"y") (V"z") "y" (\"x", V"z").
Proof.
  constructor.
  { discriminate. }
  { constructor. }
Qed.

Lemma subst_test_2:
  Subst (\"x", V"x") (V"z") "x"
        (\"x", V"x").
Proof.
  constructor.
Qed.

(**
Small Step:
<<
       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

  -----------------------------
    (\x. e1) e2 --> e1[e2/x]
>>
*)

Inductive SStep : Expr -> Expr -> Prop :=
| Scrunch : forall e1 e1' e2,
  SStep e1 e1' ->
  SStep (e1 @ e2) (e1' @ e2)
| Ssubst : forall x e1 e2 e1',
  Subst e1 e2 x e1' ->
  SStep ((\x, e1) @ e2) e1'
| SCond_crunch : forall e1 e1' e2 e3,
  SStep e1 e1' ->
  SStep (WHEN e1 THEN e2 ELSE e3)
        (WHEN e1' THEN e2 ELSE e3)
| SCond_true : forall e2 e3,
  SStep (WHEN (B true) THEN e2 ELSE e3) e2
| SCond_false : forall e2 e3,
  SStep (WHEN (B false) THEN e2 ELSE e3) e3
| SProjL_crunch : forall e e',
  SStep e e' ->
  SStep (PL e) (PL e')
| SProjL_proj : forall e1 e2,
  SStep (PL <(e1, e2)>) e1
| SProjR_crunch : forall e e',
  SStep e e' ->
  SStep (PR e) (PR e')
| SProjR_proj : forall e1 e2,
  SStep (PR <(e1, e2)>) e2
| SMatch_crunch : forall e e' vl el vr er,
  SStep e e' ->
  SStep (MATCH e WITH L vl ===> el | R vr ===> er)
        (MATCH e' WITH L vl ===> el | R vr ===> er)
| SMatch_l : forall e vl el vr er el',
  Subst el e vl el' ->
  SStep (MATCH SL e WITH L vl ===> el | R vr ===> er) el'
| SMatch_r : forall e vl el vr er er',
  Subst er e vr er' ->
  SStep (MATCH SR e WITH L vl ===> el | R vr ===> er) er'.

Notation "e1 --> e2" := (SStep e1 e2) (at level 51).

Inductive SSstar : Expr -> Expr -> Prop :=
| SSrefl : forall e,
  SSstar e e
| SSstep : forall e e' e'',
  SStep e e' ->
  SSstar e' e'' ->
  SSstar e e''.

Notation "e1 -->* e2" := (SSstar e1 e2) (at level 51).

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

Inductive Value : Expr -> Prop :=
| VBool : forall b,
  Value (B b)
| VInt : forall i,
  Value (I i)
| VLam : forall x e,
  Value (\x, e)
| VProd : forall e1 e2,
  Value (<(e1, e2)>)
| VSumL : forall e,
  Value (SL e)
| VSumR : forall e,
  Value (SR e).

Inductive Typ :=
| TBool : Typ
| TInt : Typ
| TFun : Typ -> Typ -> Typ
| TProd : Typ -> Typ -> Typ
| TSum : Typ -> Typ -> Typ.

Notation "t1 ~~> t2" := (TFun t1 t2) (at level 52, right associativity).
Notation "t1 *** t2" := (TProd t1 t2) (at level 52).
Notation "t1 +++ t2" := (TSum t1 t2) (at level 52).

Definition Env := var -> option Typ.

Definition Empty : Env := fun _ => None.

Definition extend (env: Env) x t :=
  fun y => if string_dec x y then Some t else env y.

Inductive WellTyped : Env -> Expr -> Typ -> Prop :=
| WTBool : forall env b,
  WellTyped env (B b) TBool
| WTInt : forall env i,
  WellTyped env (I i) TInt
| WTVar : forall env x t,
  env x = Some t ->
  WellTyped env (V x) t
| WTLam : forall env x e t1 t2,
  WellTyped (extend env x t1) e t2 ->
  WellTyped env (\x, e) (t1 ~~> t2)
| WTApp : forall env e1 e2 t1 t2,
  WellTyped env e1 (t1 ~~> t2) ->
  WellTyped env e2 t1 ->
  WellTyped env (e1 @ e2) t2
| WTCond : forall env e e1 e2 t,
  WellTyped env e TBool ->
  WellTyped env e1 t ->
  WellTyped env e2 t ->
  WellTyped env (WHEN e THEN e1 ELSE e2) t
| WTProd : forall env e1 t1 e2 t2,
  WellTyped env e1 t1 ->
  WellTyped env e2 t2 ->
  WellTyped env (<(e1, e2)>) (t1 *** t2)
| WTProjL : forall env e t1 t2,
  WellTyped env e (t1 *** t2) ->
  WellTyped env (PL e) t1
| WTProjR : forall env e t1 t2,
  WellTyped env e (t1 *** t2) ->
  WellTyped env (PR e) t2
| WTSumL : forall env e t1 t2,
  WellTyped env e t1 ->
  WellTyped env (SL e) (t1 +++ t2)
| WTSumR : forall env e t1 t2,
  WellTyped env e t2 ->
  WellTyped env (SR e) (t1 +++ t2)
| WTMatch : forall env e vl el vr er t1 t2 t3,
  WellTyped env e (t1 +++ t2) ->
  WellTyped (extend env vl t1) el t3 ->
  WellTyped (extend env vr t2) er t3 ->
  WellTyped env (MATCH e WITH L vl ===> el
                            | R vr ===> er) t3.

Lemma test_WT_1:
  WellTyped Empty
    ((\"x", V"x") @ (\"y", V"y"))
    (TInt ~~> TInt).
Proof.
  econstructor.
  { constructor. constructor. reflexivity. }
  { constructor. constructor. reflexivity. }
Qed.

Lemma test_WT_2:
  WellTyped Empty
    ((\"x", V"x") @ (\"y", V"y"))
    (TBool ~~> TBool).
Proof.
  econstructor.
  { constructor. constructor. reflexivity. }
  { constructor. constructor. reflexivity. }
Qed.

Lemma canon_bool:
  forall e,
  Value e ->
  WellTyped Empty e TBool ->
  exists b, e = B b.
Proof.
  intros.
  inversion H; subst;
    inversion H0; subst.
  eauto.
Qed.

Lemma canon_int:
  forall e,
  Value e ->
  WellTyped Empty e TInt ->
  exists i, e = I i.
Proof.
  intros.
  inversion H; subst;
    inversion H0; subst.
  eauto.
Qed.

Lemma cannon_lam:
  forall e t1 t2,
  Value e ->
  WellTyped Empty e (t1 ~~> t2) ->
  exists x, exists e', e = \x, e'.
Proof.
  intros.
  inversion H; subst;
    inversion H0; subst.
  eauto.
Qed.

Lemma canon_prod:
  forall e t1 t2,
  Value e ->
  WellTyped Empty e (t1 *** t2) ->
  exists e1, exists e2, e = <(e1, e2)>.
Proof.
  intros.
  inversion H; subst;
    inversion H0; subst.
  eauto.
Qed.

Lemma canon_sum:
  forall e t1 t2,
  Value e ->
  WellTyped Empty e (t1 +++ t2) ->
  exists e', e = SL e' \/ e = SR e'.
Proof.
  intros.
  inversion H; subst;
    inversion H0; subst.
  eauto. eauto.
Qed.

Lemma Subst_exists:
  forall e1 e2 x,
  exists e3, Subst e1 e2 x e3.
Proof.
  intros. induction e1; firstorder;
    try (econstructor; constructor; eauto; fail).
  - destruct (string_dec v x); subst;
    econstructor; constructor; eauto.
  - destruct (string_dec v x);
    destruct (string_dec v0 x); subst;
    econstructor; constructor; eauto.
  - destruct (string_dec v x); subst;
    econstructor; constructor; eauto.
Qed.

Lemma progress:
  forall e t,
  WellTyped Empty e t ->
  ((exists e', e --> e') \/ Value e).
Proof.
  intros. remember Empty.
  induction H; subst;
    try (right; constructor; auto; fail);
    left.
  - discriminate.
  - destruct IHWellTyped1; auto.
    + destruct H1. econstructor.
      constructor; eauto.
    + apply cannon_lam in H; auto.
      destruct H. destruct H. subst.
      destruct (Subst_exists x0 e2 x).
      econstructor. eapply Ssubst; eauto.
  - destruct IHWellTyped1; auto.
    + destruct H2. econstructor.
      constructor; eauto.
    + apply canon_bool in H; auto.
      destruct H; subst. destruct x.
      * econstructor. eapply SCond_true; eauto.
      * econstructor. eapply SCond_false; eauto.
  - destruct IHWellTyped; auto.
    + destruct H0. econstructor.
      constructor; eauto.
    + apply canon_prod in H; auto.
      destruct H. destruct H. subst.
      econstructor; eapply SProjL_proj; eauto.
  - destruct IHWellTyped; auto.
    + destruct H0. econstructor.
      constructor; eauto.
    + apply canon_prod in H; auto.
      destruct H. destruct H. subst.
      econstructor; eapply SProjR_proj; eauto.
  - destruct IHWellTyped1; auto.
    + destruct H2. econstructor.
      constructor; eauto.
    + apply canon_sum in H; auto.
      destruct H. destruct H; subst.
      * destruct (Subst_exists el x vl); auto.
        econstructor. eapply SMatch_l; eauto.
      * destruct (Subst_exists er x vr); auto.
        econstructor. eapply SMatch_r; eauto.
Qed.

Lemma lkup_extend_same:
  forall env x t,
  (extend env x t) x = Some t.
Proof.
  unfold extend; intros.
  destruct (string_dec x x); auto.
  congruence.
Qed.

Lemma lkup_extend_diff:
  forall env x1 x2 t,
  x1 <> x2 ->
  (extend env x1 t) x2 = env x2.
Proof.
  unfold extend; intros.
  destruct (string_dec x1 x2); auto.
  congruence.
Qed.

Definition env_equiv (e1 e2: Env) :=
  forall x, e1 x = e2 x.

Lemma env_equiv_extend:
  forall env1 env2,
  env_equiv env1 env2 ->
  forall x t,
  env_equiv (extend env1 x t)
            (extend env2 x t).
Proof.
  unfold env_equiv, extend; intros.
  destruct (string_dec x x0); auto.
Qed.

Lemma env_equiv_overwrite:
  forall env x t0 t1,
  env_equiv (extend env x t1)
            (extend (extend env x t0) x t1).
Proof.
  unfold env_equiv, extend; intros.
  destruct (string_dec x x0); auto.
Qed.

Lemma env_equiv_extend_diff:
  forall env x1 t1 x2 t2,
  x1 <> x2 ->
  env_equiv (extend (extend env x1 t1) x2 t2)
            (extend (extend env x2 t2) x1 t1).
Proof.
  unfold env_equiv, extend; intros.
  destruct (string_dec x2 x); subst; auto.
  destruct (string_dec x1 x); subst; auto.
  congruence.
Qed.

Lemma env_equiv_symmetry:
  forall env1 env2,
  env_equiv env1 env2 ->
  env_equiv env2 env1.
Proof.
  congruence.
Qed.

Lemma env_equiv_wt:
  forall env1 e te,
  WellTyped env1 e te ->
  forall env2,
  env_equiv env2 env1 ->
  WellTyped env2 e te.
Proof.
  induction 1; intros;
    try (econstructor; eauto; fail).
  - constructor; auto. congruence.
  - constructor; auto.
    apply IHWellTyped.
    apply env_equiv_extend; auto.
  - econstructor; eauto.
    + apply IHWellTyped2.
      apply env_equiv_extend; auto.
    + apply IHWellTyped3.
      apply env_equiv_extend; auto.
Qed.

Inductive Free : Expr -> var -> Prop :=
| FVar : forall x,
  Free (Var x) x
| FAppL : forall e1 e2 x,
  Free e1 x ->  Free (App e1 e2) x
| FAppR : forall e1 e2 x,
  Free e2 x ->  Free (App e1 e2) x
| FLam : forall x1 e1 x,
  Free e1 x ->
  x <> x1 ->
  Free (Lam x1 e1) x
| FCond_cond : forall e1 e2 e3 x,
  Free e1 x ->
  Free (WHEN e1 THEN e2 ELSE e3) x
| FCond_then : forall e1 e2 e3 x,
  Free e2 x ->
  Free (WHEN e1 THEN e2 ELSE e3) x
| FCond_else : forall e1 e2 e3 x,
  Free e3 x ->
  Free (WHEN e1 THEN e2 ELSE e3) x
| FProdl : forall e1 e2 x,
  Free e1 x ->
  Free (<(e1, e2)>) x
| FProdr : forall e1 e2 x,
  Free e2 x ->
  Free (<(e1, e2)>) x
| FProjL : forall e x,
  Free e x ->
  Free (PL e) x
| FProjR : forall e x,
  Free e x ->
  Free (PR e) x
| FSumL : forall e x,
  Free e x ->
  Free (SL e) x
| FSumR : forall e x,
  Free e x ->
  Free (SR e) x
| FMatchM : forall e vl el vr er x,
  Free e x ->
  Free (MATCH e WITH L vl ===> el | R vr ===> er) x
| FMatchL : forall e vl el vr er x,
  x <> vl ->
  Free el x ->
  Free (MATCH e WITH L vl ===> el | R vr ===> er) x
| FMatchR : forall e vl el vr er x,
  x <> vr ->
  Free er x ->
  Free (MATCH e WITH L vl ===> el | R vr ===> er) x.

Lemma not_free_app_inv:
  forall e1 e2 x,
  ~ Free (e1 @ e2) x ->
  ~ Free e1 x /\ ~ Free e2 x.
Proof.
  intros. split.
  - intro. apply H.
    apply FAppL; auto.
  - intro. apply H.
    apply FAppR; auto.
Qed.

Lemma not_free_cond_inv:
  forall e1 e2 e3 x,
  ~ Free (WHEN e1 THEN e2 ELSE e3) x ->
  (~ Free e1 x) /\ (~ Free e2 x) /\ (~ Free e3 x).
Proof.
  unfold not; firstorder.
  - apply H; apply FCond_cond; auto.
  - apply H; apply FCond_then; auto.
  - apply H; apply FCond_else; auto.
Qed.

Lemma not_free_prod_inv:
  forall e1 e2 x,
  ~ Free (<(e1, e2)>) x ->
  ~ Free e1 x /\ ~ Free e2 x.
Proof.
  unfold not; firstorder.
  - apply H; apply FProdl; auto.
  - apply H; apply FProdr; auto.
Qed.

Lemma not_free_pl_inv:
  forall e x,
  ~ Free (PL e) x ->
  ~ Free e x.
Proof.
  unfold not; firstorder.
  apply H. apply FProjL; auto.
Qed.

Lemma not_free_pr_inv:
  forall e x,
  ~ Free (PR e) x ->
  ~ Free e x.
Proof.
  unfold not; firstorder.
  apply H. apply FProjR; auto.
Qed.

Lemma not_free_sl_inv:
  forall e x,
  ~ Free (SL e) x ->
  ~ Free e x.
Proof.
  unfold not; firstorder.
  apply H. apply FSumL; auto.
Qed.

Lemma not_free_sr_inv:
  forall e x,
  ~ Free (SR e) x ->
  ~ Free e x.
Proof.
  unfold not; firstorder.
  apply H. apply FSumR; auto.
Qed.

Lemma not_free_match_inv:
  forall e1 v2 e2 v3 e3 x,
  ~ Free (MATCH e1 WITH L v2 ===> e2 | R v3 ===> e3) x ->
  (~ Free e1 x) /\
  (v2 <> x -> ~ Free e2 x) /\
  (v3 <> x -> ~ Free e3 x).
Proof.
  unfold not; firstorder.
  - apply H; apply FMatchM; auto.
  - apply H; apply FMatchL; auto.
  - apply H; apply FMatchR; auto.
Qed.

Lemma not_free_lam_inv:
  forall v e x,
  ~ Free (\v, e) x ->
  v = x \/ (v <> x /\ ~ Free e x).
Proof.
  unfold not; firstorder.
  destruct (string_dec v x); subst; auto.
  right. split; intros.
  + congruence.
  + apply H. constructor; auto.
Qed.

Lemma strengthen:
  forall e x,
  ~ Free e x ->
  forall env tx te,
  WellTyped (extend env x tx) e te ->
  WellTyped env e te.
Proof.
  induction e; intros;
    inversion H0; subst;
    try (econstructor; eauto; fail).
  - constructor. unfold extend in H3.
    destruct (string_dec x v); subst; auto.
    destruct H. constructor.
  - apply not_free_app_inv in H. destruct H.
    econstructor; eauto.
  - apply not_free_cond_inv in H.
    destruct H. destruct H1.
    econstructor; eauto.
  - apply not_free_prod_inv in H. destruct H.
    econstructor; eauto.
  - apply not_free_pl_inv in H.
    econstructor; eauto.
  - apply not_free_pr_inv in H.
    econstructor; eauto.
  - apply not_free_sl_inv in H.
    econstructor; eauto.
  - apply not_free_sr_inv in H.
    econstructor; eauto.
  - apply not_free_match_inv in H.
    destruct H. destruct H1.
    econstructor; eauto.
    + destruct (string_dec v x); subst.
      * eapply env_equiv_wt; eauto.
        apply env_equiv_overwrite.
      * eapply IHe2; eauto.
        eapply env_equiv_wt; eauto.
        apply env_equiv_extend_diff; auto.
    + destruct (string_dec v0 x); subst.
      * eapply env_equiv_wt; eauto.
        apply env_equiv_overwrite.
      * eapply IHe3; eauto.
        eapply env_equiv_wt; eauto.
        apply env_equiv_extend_diff; auto.
  - apply not_free_lam_inv in H.
    destruct H.
    + subst. constructor.
      eapply env_equiv_wt; eauto.
      apply env_equiv_overwrite.
    + destruct H. constructor.
      eapply IHe; eauto.
      eapply env_equiv_wt; eauto.
      apply env_equiv_extend_diff; auto.
Qed.

Lemma weaken:
  forall e x,
  ~ Free e x ->
  forall env tx te,
  WellTyped env e te ->
  WellTyped (extend env x tx) e te.
Proof.
  induction e; intros;
    inversion H0; subst;
    try (econstructor; eauto; fail).
  - constructor. unfold extend.
    destruct (string_dec x v); subst; auto.
    destruct H. constructor.
  - apply not_free_app_inv in H. destruct H.
    econstructor; eauto.
  - apply not_free_cond_inv in H.
    destruct H. destruct H1.
    econstructor; eauto.
  - apply not_free_prod_inv in H. destruct H.
    econstructor; eauto.
  - apply not_free_pl_inv in H.
    econstructor; eauto.
  - apply not_free_pr_inv in H.
    econstructor; eauto.
  - apply not_free_sl_inv in H.
    econstructor; eauto.
  - apply not_free_sr_inv in H.
    econstructor; eauto.
  - apply not_free_match_inv in H.
    destruct H. destruct H1.
    econstructor; eauto.
    + destruct (string_dec v x); subst.
      * eapply env_equiv_wt; eauto.
        apply env_equiv_symmetry.
        apply env_equiv_overwrite.
      * eapply IHe2 in H9; eauto.
        eapply env_equiv_wt; eauto.
        apply env_equiv_extend_diff; auto.
    + destruct (string_dec v0 x); subst.
      * eapply env_equiv_wt; eauto.
        apply env_equiv_symmetry.
        apply env_equiv_overwrite.
      * eapply IHe3 in H10; eauto.
        eapply env_equiv_wt; eauto.
        apply env_equiv_extend_diff; auto.
  - apply not_free_lam_inv in H.
    destruct H.
    + subst. constructor.
      eapply env_equiv_wt; eauto.
      apply env_equiv_symmetry.
      apply env_equiv_overwrite.
    + destruct H. constructor.
      eapply IHe in H5; eauto.
      eapply env_equiv_wt; eauto.
      apply env_equiv_extend_diff; auto.
Qed.

Lemma subst_preserve_wt:
  forall e1 e2 x e1',
  Subst e1 e2 x e1' ->
  forall env te2 te1,
    WellTyped (extend env x te2) e1 te1 ->
    WellTyped env e2 te2 ->
    (forall v, ~ Free e2 v) ->
    WellTyped env e1' te1.
Proof.
  induction 1; intros.
  - inversion H; subst.
    constructor; auto.
  - inversion H; subst.
    constructor; auto.
  - inversion H; subst.
    rewrite lkup_extend_same in H4.
    inversion H4; subst. auto.
  - inversion H0; subst.
    rewrite lkup_extend_diff in H5; auto.
    constructor; auto.
  - inversion H1; subst.
    econstructor; eauto.
  - inversion H2; subst.
    constructor; auto.
    + eapply IHSubst1; eauto.
    + eapply IHSubst2; eauto.
    + eapply IHSubst3; eauto.
  - inversion H1; subst.
    constructor; auto.
    + eapply IHSubst1; eauto.
    + eapply IHSubst2; eauto.
  - inversion H0; subst.
    eapply WTProjL; eauto.
  - inversion H0; subst.
    (* woah, found a subst bug here! *)
    eapply WTProjR; eauto.
  - inversion H0; subst.
    eapply WTSumL; eauto.
  - inversion H0; subst.
    eapply WTSumR; eauto.
  - inversion H0; subst.
    econstructor; eauto.
    + eapply env_equiv_wt; eauto.
      apply env_equiv_overwrite.
    + eapply env_equiv_wt; eauto.
      apply env_equiv_overwrite.
  - inversion H2; subst.
    econstructor; eauto.
    + eapply env_equiv_wt; eauto.
      apply env_equiv_overwrite.
    + eapply IHSubst2; eauto.
      * eapply env_equiv_wt; eauto.
        eapply env_equiv_extend_diff; eauto.
      * eapply weaken; eauto.
 - inversion H2; subst.
    econstructor; eauto.
    + eapply IHSubst2; eauto.
      * eapply env_equiv_wt; eauto.
        eapply env_equiv_extend_diff; eauto.
      * eapply weaken; eauto.
    + eapply env_equiv_wt; eauto.
      apply env_equiv_overwrite.
  - inversion H4; subst.
    econstructor; eauto.
    + eapply IHSubst2; eauto.
      * eapply env_equiv_wt; eauto.
        eapply env_equiv_extend_diff; eauto.
      * eapply weaken; eauto.
    + eapply IHSubst3; eauto.
      * eapply env_equiv_wt; eauto.
        eapply env_equiv_extend_diff; eauto.
      * eapply weaken; eauto.
  - inversion H; subst.
    constructor; auto.
    eapply env_equiv_wt; eauto.
    apply env_equiv_overwrite.
  - inversion H1; subst.
    constructor; auto.
    eapply IHSubst; eauto.
    + eapply env_equiv_wt; eauto.
      eapply env_equiv_extend_diff; auto.
    + eapply weaken; eauto.
Qed.

Definition closed e :=
  forall v, ~ Free e v.

Lemma closed_app_inv:
  forall e1 e2,
  closed (e1 @ e2) ->
  closed e1 /\ closed e2.
Proof.
  unfold closed; split; intros; intro.
  - edestruct H; eauto.
    apply FAppL; eauto.
  - edestruct H; eauto.
    apply FAppR; eauto.
Qed.

Lemma closed_app_intro:
  forall e1 e2,
  closed e1 ->
  closed e2 ->
  closed (e1 @ e2).
Proof.
  unfold closed; intros; intro.
  inversion H1; subst.
  - firstorder.
  - firstorder.
Qed.

Lemma closed_cond_inv:
  forall e1 e2 e3,
  closed (WHEN e1 THEN e2 ELSE e3) ->
  closed e1 /\ closed e2 /\ closed e3.
Proof.
  unfold closed; repeat split; intros; intro.
  - edestruct H; eauto.
    eapply FCond_cond; eauto.
  - edestruct H; eauto.
    eapply FCond_then; eauto.
  - edestruct H; eauto.
    eapply FCond_else; eauto.
Qed.

Lemma closed_cond_intro:
  forall e1 e2 e3,
  closed e1 ->
  closed e2 ->
  closed e3 ->
  closed (WHEN e1 THEN e2 ELSE e3).
Proof.
  unfold closed; intros; intro.
  inversion H2; subst; firstorder.
Qed.

Lemma closed_pl_inv:
  forall e,
  closed (PL e) ->
  closed e.
Proof.
  unfold closed; intros; intro.
  edestruct H; eauto.
  constructor; eauto.
Qed.

Lemma closed_pl_intro:
  forall e,
  closed e ->
  closed (PL e).
Proof.
  unfold closed; intros; intro.
  inversion H0; subst; firstorder.
Qed.

Lemma closed_pr_inv:
  forall e,
  closed (PR e) ->
  closed e.
Proof.
  unfold closed; intros; intro.
  edestruct H; eauto.
  constructor; eauto.
Qed.

Lemma closed_pr_intro:
  forall e,
  closed e ->
  closed (PR e).
Proof.
  unfold closed; intros; intro.
  inversion H0; subst; firstorder.
Qed.

Lemma closed_sl_inv:
  forall e,
  closed (SL e) ->
  closed e.
Proof.
  unfold closed; intros; intro.
  edestruct H; eauto.
  constructor; eauto.
Qed.

Lemma closed_sl_intro:
  forall e,
  closed e ->
  closed (SL e).
Proof.
  unfold closed; intros; intro.
  inversion H0; subst; firstorder.
Qed.

Lemma closed_sr_inv:
  forall e,
  closed (SR e) ->
  closed e.
Proof.
  unfold closed; intros; intro.
  edestruct H; eauto.
  constructor; eauto.
Qed.

Lemma closed_sr_intro:
  forall e,
  closed e ->
  closed (SR e).
Proof.
  unfold closed; intros; intro.
  inversion H0; subst; firstorder.
Qed.

Lemma closed_match_inv:
  forall e vl el vr er,
  closed (MATCH e WITH L vl ===> el | R vr ===> er) ->
  closed e.
Proof.
  unfold closed; intros; intro.
  edestruct H; eauto.
  constructor; eauto.
Qed.

Lemma free_in_env:
  forall env e t,
  WellTyped env e t ->
  forall v, Free e v ->
  env v <> None.
Proof.
  induction 1; intros; intro.
  - inversion H.
  - inversion H.
  - inversion H0. subst.
    rewrite H in H1. discriminate.
  - inversion H0. subst.
    destruct IHWellTyped with (v := v); auto.
    rewrite lkup_extend_diff; auto.
  - inversion H1; subst.
    + destruct IHWellTyped1 with (v := v); auto.
    + destruct IHWellTyped2 with (v := v); auto.
  - inversion H2; subst.
    + edestruct IHWellTyped1; eauto.
    + edestruct IHWellTyped2; eauto.
    + edestruct IHWellTyped3; eauto.
  - inversion H1; subst.
    + edestruct IHWellTyped1; eauto.
    + edestruct IHWellTyped2; eauto.
  - inversion H0; subst.
    edestruct IHWellTyped; eauto.
  - inversion H0; subst.
    edestruct IHWellTyped; eauto.
  - inversion H0; subst.
    edestruct IHWellTyped; eauto.
  - inversion H0; subst.
    edestruct IHWellTyped; eauto.
  - inversion H2; subst.
    + edestruct IHWellTyped1; eauto.
    + edestruct IHWellTyped2; eauto.
      unfold extend. destruct (string_dec vl v); subst.
      * congruence.
      * assumption.
    + edestruct IHWellTyped3; eauto.
      unfold extend. destruct (string_dec vr v); subst.
      * congruence.
      * assumption.
Qed.

Lemma empty_closed:
  forall e t,
  WellTyped Empty e t ->
  closed e.
Proof.
  unfold closed; intros; intro.
  apply free_in_env with (v := v) in H; auto.
Qed.

Lemma preserve:
  forall env e t,
  WellTyped env e t ->
  closed e ->
  forall e',
  e --> e' ->
  WellTyped env e' t.
Proof.
  induction 1; intros.
  - inversion H0.
  - inversion H0.
  - inversion H1.
  - inversion H1.
  - apply closed_app_inv in H1; destruct H1.
    inversion H2; subst.
    + econstructor; eauto.
    + inversion H; subst.
      eapply subst_preserve_wt; eauto.
  - apply closed_cond_inv in H2.
    destruct H2. destruct H4.
    inversion H3; subst; auto.
    econstructor; eauto.
  - inversion H2.
  - apply closed_pl_inv in H0.
    inversion H1; subst.
    + econstructor; eauto.
    + inversion H; auto.
  - apply closed_pr_inv in H0.
    inversion H1; subst.
    + econstructor; eauto.
    + inversion H; auto.
  - inversion H1.
  - inversion H1.
  - apply closed_match_inv in H2.
    inversion H3; subst; auto.
    + econstructor; eauto.
    + apply closed_sl_inv in H2.
      inversion H; subst.
      eapply subst_preserve_wt; eauto.
    + apply closed_sr_inv in H2.
      inversion H; subst.
      eapply subst_preserve_wt; eauto.
Qed.

Lemma preserve_star:
  forall e e',
  e -->* e' ->
  forall t,
  WellTyped Empty e t ->
  WellTyped Empty e' t.
Proof.
  induction 1; intros.
  - assumption.
  - apply IHSSstar; auto.
    eapply preserve; eauto.
    eapply empty_closed; eauto.
Qed.

Lemma soundness:
  forall e t,
  WellTyped Empty e t ->
  forall e',
  e -->* e' ->
  (exists e'', e' --> e'') \/ Value e'.
Proof.
  intros. induction H0.
  - eapply progress. eassumption.
  - destruct IHSSstar; auto.
    eapply preserve; eauto.
    eapply empty_closed; eauto.
Qed.


(*
   So-called "summable" double series converge and can be rearranged and
   have the same value also if summed by columns or rows.

   This is used to consturuct the product distribution and also to show
   the equivalence of two defintions of expectation.
*)

From discprob.basic Require Import base order bigop_ext nify Series_Ext.
From discprob.prob Require Import countable rearrange.
From stdpp Require tactics.
Require Import Reals Fourier Omega Psatz.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype seq bigop fintype ssrnat choice.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.

Definition double_summable a :=
  ∃ (r: R), ∀ n, sum_n (λ j, sum_n (λ k, Rabs (a (j, k))) n) n <= r.

Lemma double_summable_mono_cond a:
  (∃ (r: R), ∃ N, ∀ n, n ≥ N → sum_n (λ j, sum_n (λ k, Rabs (a (j, k))) n) n <= r) →
  double_summable a.
Proof.
  intros (r&N&Hcond).
  exists r => n.
  destruct (le_ge_dec N n) as [Hle|Hge].
  - apply Hcond. omega.
  - transitivity (sum_n (λ j, sum_n (λ k, Rabs (a (j, k))) N) N).
    { clear Hcond.
      induction Hge; first reflexivity.
      etransitivity; first eapply IHHge.
      rewrite sum_Sn /plus//=.
      rewrite -[a in a <= _]Rplus_0_r.
      apply Rplus_le_compat.
      * rewrite ?sum_n_bigop.
        apply Rle_bigr => ??. apply sum_n_nonneg_terms_increasing; first omega.
        intros; apply Rle_ge, Rabs_pos.
      * apply sum_n_pos; eauto => ?.
        apply Rle_ge, Rabs_pos.
    }
    eauto.
Qed.

Lemma double_summable_ext a a':
  (∀ j k, Rabs (a (j, k)) = Rabs (a' (j, k))) →
  double_summable a → double_summable a'.
Proof.
  intros Hext (r&Hle).
  exists r => n. etransitivity; last (eapply (Hle n)).
  right.
  apply sum_n_ext => ?.
  apply sum_n_ext => ?.
  rewrite Hext. done.
Qed.

Lemma double_summable_abs a :
  double_summable a → double_summable (Rabs \o a).
Proof.
  apply double_summable_ext; eauto.
  intros. by rewrite Rabs_Rabsolu.
Qed.

Lemma double_summable_by_flip a:
  double_summable a →
  double_summable (λ xy, a (snd xy, fst xy)).
Proof.
  intros (r&Hle).
  exists r => n. rewrite sum_n_switch => //=.
Qed.

Lemma double_summable_flip a:
  double_summable (λ xy, a (snd xy, fst xy)) → double_summable a.
Proof.
  intros (r&Hle).
  exists r => n. rewrite sum_n_switch => //=.
Qed.

Lemma ex_series_rows_ds a:
  (∀ j, ex_series (λ k, Rabs (a (j, k)))) →
  ex_series (λ j, Series (λ k,  Rabs (a (j, k)))) →
  double_summable a.
Proof.
  intros Hrows Hex.
  destruct Hex as (r&Hseries).
  exists r => n.
  transitivity (sum_n (λ j, Series (λ k, Rabs (a (j, k)))) n).
  {  rewrite ?sum_n_bigop. apply Rle_bigr. intros (j&Hle) _.
     edestruct (Hrows j) as (v&Hrow). rewrite (is_series_unique _ _ Hrow).
     apply is_series_partial_pos; first (intros; apply Rle_ge, Rabs_pos); auto.
  }
  apply is_series_partial_pos; eauto.
  intros j. apply Rle_ge, Series_pos => k. apply Rle_ge, Rabs_pos.
Qed.

Lemma ex_series_columns_ds a:
  (∀ k, ex_series (λ j, Rabs (a (j, k)))) →
  ex_series (λ k, Series (λ j,  Rabs (a (j, k)))) →
  double_summable a.
Proof.
  intros. apply double_summable_flip. apply ex_series_rows_ds; eauto.
Qed.

Lemma ex_series_row a (DS: double_summable a) j:
  ex_series (λ k, Rabs (a (j, k))).
Proof.
  destruct DS as (M&HM).
  cut (∃ l: R, is_lim_seq (λ n, sum_n (λ k, Rabs (a (j, k))) n) l).
  { rewrite /ex_lim_seq/is_lim_seq/ex_series/is_series. rewrite //=.  }
  cut (∃ l: Rbar, is_lim_seq (λ n, sum_n (λ k, Rabs (a (j, k))) n) l).
  { intros (l&Hislim).
    assert (Rbar_le l M) as Hle.
    { eapply (is_lim_seq_le _ (λ n, M)); eauto; last by (apply is_lim_seq_const).
      intros n. etransitivity; last apply (HM (max j n)) => //=.
      rewrite ?sum_n_bigop.
      etransitivity; last first.
      { right. apply eq_bigr. intros; rewrite sum_n_bigop. done. }
      rewrite //=pair_big_dep//=/index_enum.
      refine (let σ' := (λ x, match x with
                                | Ordinal k Hle =>
                                  (@Ordinal (S (max j n)) j _, @ Ordinal (S (max j n)) k _)
                              end) : 'I_(S n) → 'I_(S (max j n)) * 'I_(S (max j n)) in _).
      Unshelve. all:swap 1 3.
      { abstract (intros; nify; lia). }
      { abstract (intros; nify; lia). }
      rewrite bigop_cond_non0 [a in _ <= a]bigop_cond_non0.
      eapply (sum_reidx_map_le _ _ _ _ σ').
      - intros (m&?) _. rewrite /σ' //=. right. repeat f_equal.
      - rewrite //=. intros (x&?) ? Hneq0; split; auto.
        rewrite -enumT mem_enum //=.
      - intros. apply Rle_ge, Rabs_pos.
      - rewrite -enumT. apply enum_uniq.
      - rewrite -enumT. apply: enum_uniq.
      - rewrite /σ'; intros (x&?) (y&?).
        rewrite //= => Hneq0. inversion 1. apply ord_inj => //=.
    }
    assert (Rbar_le 0 l) as Hge.
    {
      eapply (is_lim_seq_le (λ n, 0)); eauto; last by (apply is_lim_seq_const).
      intros n => /=. rewrite sum_n_bigop. apply Rle_big0 => ??. apply Rabs_pos.
    }
    destruct l as [l| |].
    * exists l. auto.
    * inversion Hle.
    * inversion Hge.
  }
  apply ex_lim_seq_incr.
  intros n. rewrite sum_Sn/plus//=. specialize (Rabs_pos (a (j, S n))). nra.
Qed.

Lemma ex_series_column a (DS: double_summable a) k:
  ex_series (λ j, Rabs (a (j, k))).
Proof.
  set (flip := λ (x : nat * nat), (snd x, fst x)).
  eapply ex_series_ext; last first.
  { eapply ex_series_row. apply double_summable_by_flip => //=. eapply DS. }
  intros n => //=.
Qed.

Module pre_converge.

Section covering1.

Variable (a: nat * nat → R).
Variable (σ: nat → nat * nat).

Variable (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n').
Variable (COV: ∀ n, a n <> 0 → ∃ m, σ m = n).

Lemma inj_nat_cover1:
  ∀ N, ∃ K, ∀ n, n ≤ N → (fst (σ n) ≤ K ∧ snd (σ n) ≤ K).
Proof.
  induction N.
  - exists (max (fst (σ O)) (snd (σ O))); intros n Hle; inversion Hle; split.
    * apply Max.le_max_l.
    * apply Max.le_max_r.
  - edestruct IHN as (K&HK).
    exists (max (max (fst (σ (S N))) (snd (σ (S N)))) K); intros n Hle; inversion Hle.
    * split.
      ** etransitivity; last apply Max.le_max_l. apply Max.le_max_l.
      ** etransitivity; last apply Max.le_max_l. apply Max.le_max_r.
    * split.
      ** etransitivity; last apply Max.le_max_r. edestruct HK; eauto.
      ** etransitivity; last apply Max.le_max_r. edestruct HK; eauto.
Qed.

Lemma inj_nat_cover2:
  ∀ K1 K2, ∃ N, ∀ l m, l ≤ K1 → m ≤ K2 →
 ( ∃ n, n ≤ N ∧ σ n = (l, m)) ∨ a (l, m) = 0.
Proof.
  induction K1.
  - induction K2.
    * destruct (Req_dec (a (O, O)) 0) as [|Hneq].
      ** exists O => l m. inversion 1; subst. inversion 1; subst.
         right. done.
      ** edestruct (COV _ Hneq) as (N&?).
         exists N => l m. inversion 1; subst. inversion 1; subst.
         left. exists N; split; auto.
    * destruct IHK2 as (N&HN).
      destruct (Req_dec (a (O, S K2)) 0) as [|Hneq].
      ** exists N => l m. inversion 1; subst. inversion 1; subst.
         *** right. done.
         *** eapply HN; auto.
      ** edestruct (COV _ Hneq) as (N'&?).
         exists (max N N') => l m. inversion 1; subst. inversion 1; subst.
         *** left. exists N'. split; auto. apply Max.le_max_r.
         *** edestruct (HN O m) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N; auto.
             apply Max.le_max_l.
  - induction K2.
    * destruct (IHK1 O) as (N&HN).
      destruct (Req_dec (a (S K1, O)) 0) as [|Hneq].
      ** exists N => l m. inversion 1; subst. inversion 1; subst.
         *** right. done.
         *** eapply HN; auto.
      ** edestruct (COV _ Hneq) as (N'&?).
         exists (max N N') => l m. inversion 1; subst; inversion 1; subst.
         *** left. exists N'. split; auto. apply Max.le_max_r.
         *** edestruct (HN l O) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N; auto.
             apply Max.le_max_l.
    * destruct (IHK1 (S K2)) as (N1&HN1).
      destruct IHK2 as (N2&HN2).
      destruct (Req_dec (a (S K1, S K2)) 0) as [|Hneq].
      ** exists (max N1 N2) => l m. inversion 1; subst; inversion 1; subst.
         *** right. done.
         *** edestruct (HN2 (S K1) m) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N2; auto.
             apply Max.le_max_r.
         *** edestruct (HN1 l (S K2)) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N1; auto.
             apply Max.le_max_l.
         *** edestruct (HN1 l m) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N1; auto.
             apply Max.le_max_l.
      ** edestruct (COV _ Hneq) as (N'&?).
         exists (max (max N1 N2) N') => l m. inversion 1; subst; inversion 1; subst.
         *** left.  exists N'; split; auto.
             apply Max.le_max_r.
         *** edestruct (HN2 (S K1) m) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N2; auto.
             etransitivity; first apply Max.le_max_r; apply Max.le_max_l.
         *** edestruct (HN1 l (S K2)) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N1; auto.
             etransitivity; first apply Max.le_max_l; apply Max.le_max_l.
         *** edestruct (HN1 l m) as [(n&?&?)|]; eauto.
             left. exists n. split; auto. transitivity N1; auto.
             etransitivity; first apply Max.le_max_l; apply Max.le_max_l.
Qed.

Lemma sum_n_m_cover_diff_double:
  ∀ N, ∃ K, ∀ l m, l ≥ K → m ≥ K →
  ∃ n, n ≥ N ∧ Rabs (sum_n (λ j, sum_n (λ k, a (j, k)) m) l - sum_n (a \o σ) N)
               <= sum_n_m (Rabs \o a \o σ) (S N) n.
Proof.
  intros N.
  edestruct (inj_nat_cover1 N) as (K&HK).
  exists K => l m Hl Hm.
  edestruct (inj_nat_cover2 l m) as (n&Hn).
  exists (max n N). repeat split.
  { intros; nify; lia. }
  transitivity (Rabs (\big[Rplus/0]_(S N <= i < S (Init.Nat.max n N) |
                                     ((σ i).1 <= l)%N && ((σ i).2 <= m)%N) (a (σ i))));
  last first.
  {
    rewrite sum_n_m_bigop. etransitivity; first apply Rabs_bigop_triang.
    rewrite //=. apply Rabs_bigop_filter. auto.
  }
  assert (sum_n (λ j, sum_n (λ k, a (j, k)) m) l =
          \big[Rplus/0]_(i < S (Init.Nat.max n N) |
                         leq (fst (σ i)) l && leq (snd (σ i)) m) a (σ i)) as Hleft.
  {
    etransitivity.
    { rewrite sum_n_bigop. eapply eq_bigr => ??. rewrite sum_n_bigop. done. }
      rewrite pair_big => //=. rewrite bigop_cond_non0 //=.
      rewrite /index_enum.
      symmetry.
      transitivity (\big[Rplus/0]_(i : {i : 'I_(S (max n N)) | leq (fst (σ i)) l &&
                                                            leq (snd (σ i)) m })
                     a (σ (sval i))).
      {
        rewrite bigop_cond_non0 [a in _ = a]bigop_cond_non0.
        symmetry; eapply (sum_reidx_map _ _ _ _ sval).
        - auto.
        - intros (i&Hpf) _ Hneq0; split.
          * rewrite -enumT mem_enum //.
          * rewrite //=. apply /andP; split; auto.
        - intros i _ Hbound Hfalse.
          move /andP in Hbound. destruct Hbound as (Hbound&Hneq0).
          move /andP in Hbound. destruct Hbound as (Hb1&Hb2).
          exfalso. apply Hfalse. rewrite //=.
          assert (is_true ((leq (σ i).1 l) && (leq (σ i).2 m))) as Hpf'.
          { rewrite //=; apply /andP; split; rewrite //= in Hb1 Hb2; destruct (σ n0); nify;
              omega. }
          exists (exist _ i Hpf'); repeat split.
            ** rewrite /index_enum //= -enumT mem_enum //=.
            ** rewrite //=.
        - rewrite /index_enum//= -enumT. apply enum_uniq.
        - rewrite /index_enum//= -enumT. apply enum_uniq.
        - intros (?&?) (?&?) ? Heq => //=.
          rewrite //= in Heq. subst. f_equal. apply bool_irrelevance.
      }
      refine (let σ' := (λ x, match x with
                              | exist o Hpf =>
                                (@Ordinal _ (fst (σ o)) _, @ Ordinal _ (snd (σ o)) _)
                              end) :
          { x: 'I_(S (max n N)) | leq (fst (σ x)) l && leq (snd (σ x)) m} → 'I_(S l) * 'I_(S m) in _).
      Unshelve. all:swap 1 3.
      { abstract (move: Hpf; move /andP => [? ?]; nify; omega). }
      { abstract (move: Hpf; move /andP => [? ?]; nify; omega). }
      rewrite [a in a = _]bigop_cond_non0.
      eapply (sum_reidx_map _ _ _ _ σ').
        - rewrite /σ'//=. intros (?&?) _ => //=. destruct (σ x) => //.
        - intros (i&Hpf) _ Hneq0; split.
          * rewrite -enumT mem_enum //.
          * rewrite //=. rewrite //= in Hneq0. destruct (σ i); auto.
        - rewrite //=. intros (l0, m0) _. rewrite //=. move /eqP. intros Hneq0 Hfalse.
          exfalso; apply Hfalse. edestruct (Hn l0 m0) as [(n0&Hle&Heq)|]; last by (exfalso; eauto).
          { clear. destruct l0 => //=. nify. omega. }
          { clear. destruct m0 => //=. nify. omega. }
          assert (Hpf1:  (n0 < S (max n N))%nat).
          { nify. specialize (Max.le_max_l n N); omega. }
          set (n0' := Ordinal Hpf1).
          assert (Hpf2: leq (fst (σ n0')) l && leq (snd (σ n0')) m).
          { apply /andP; rewrite Heq//=; destruct l0, m0 => //=; clear; split; nify. }
          exists (exist _ n0' Hpf2).
          repeat split => //=.
          * rewrite /index_enum//= -enumT mem_enum //.
          * rewrite Heq. apply /eqP. done.
          * rewrite /n0' //=; f_equal; apply ord_inj => //=; rewrite Heq; done.
        - rewrite /index_enum//= -enumT enum_uniq //.
        - rewrite /index_enum//= -enumT enum_uniq //.
        - rewrite /σ'//=. intros ?? Hneq0 Heq. cut (sval x = sval x').
          {  destruct x, x'. rewrite //=. intros; subst. f_equal. apply bool_irrelevance. }
          destruct x as ((?&?)&?), x' as ((?&?)&?) => //=.
          apply ord_inj. apply INJ => //=.
          ** apply /eqP; auto.
          ** rewrite //= in Heq. clear -Heq.
             inversion Heq as [[Heq1 Heq2]]. clear -Heq1 Heq2. destruct (σ m0), (σ m1); auto.
  }
  rewrite Hleft.
  assert (sum_n (a \o σ) N =
          \big[Rplus/0]_(i < S N |  ((σ i).1 <= l)%N && ((σ i).2 <= m)%N) a (σ i)) as Hright.
  {
    rewrite sum_n_bigop.
    rewrite bigop_cond_non0 [a in _ = a]bigop_cond_non0.
    eapply (sum_reidx_map _ _ _ _ id).
    * intros (x&Hlex) ? => //=.
    * intros (n'&Hle) ? Hneq0; split; auto. apply /andP; split; auto.
      rewrite //=. apply /andP; split.
      ** nify. transitivity K; auto. edestruct (HK n'); eauto. clear -Hle. nify. omega.
      ** nify. transitivity K; auto. edestruct (HK n'); eauto. clear -Hle. nify. omega.
    * intros i _. move /andP => [? Hneq0] => //= Hfalse.
      exfalso. apply Hfalse. exists i; split; auto.
      rewrite /index_enum -enumT mem_enum //.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * intros (x&?) (y&?) => //=.
  }
  rewrite Hright.
  right.
  rewrite -(@big_mkord _ 0 Rplus (S (max n N)) (λ i, (leq (fst (σ i)) l) && (leq (snd (σ i)) m))
             (a \o σ)).
  assert (S N <= S (max n N))%nat as Hsplit by (nify; lia).
  rewrite (big_cat_nat _ _ _ _ Hsplit) //=.
  rewrite big_mkord.
  assert (∀ a b, a + b - a = b) as -> by (intros; field).
  done.
Qed.

Lemma is_lim_seq_sum_n (f: nat * nat → R) (h: nat → R) l:
  (∀ j, j ≤ l → is_lim_seq (λ m, sum_n (λ k, f (j, k)) m) (h j)) →
  is_lim_seq (λ m, sum_n (λ j, sum_n (λ k, f (j, k)) m) l) (sum_n h l).
Proof.
  intros Hh.
  induction l => //=.
  - intros. rewrite sum_O => //=. apply (is_lim_seq_ext (λ m, sum_n (λ k, f (O, k)) m)).
    * intros. rewrite sum_O. done.
    * by apply Hh.
  - rewrite sum_Sn.
    apply (is_lim_seq_ext (λ m, plus (sum_n (λ j, sum_n (λ k, f (j, k)) m) l)
                                     (sum_n (λ k, f (S l, k)) m))).
    * intros. by rewrite sum_Sn.
    * apply: is_lim_seq_plus; eauto.
      rewrite //=.
Qed.

Lemma is_lim_seq_fin_abs:
  ∀ (u : nat → R) (l : R), is_lim_seq u l → is_lim_seq (λ n : nat, Rabs (u n)) (Rabs l).
Proof.
  intros.
  assert (Rabs l = Rbar_abs l) as -> by auto.
  by apply (is_lim_seq_abs u (Finite l)).
Qed.

End covering1.

Section covering2.
Variable (a: nat * nat → R).
Variable (σ: nat → nat * nat).

Variable (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n').
Variable (COV: ∀ n, a n <> 0 → ∃ m, σ m = n).
Variable (EXS: ex_series (Rabs \o a \o σ)).

Lemma abs_inj: ∀ n n', Rabs (a (σ n)) <> 0 → σ n = σ n' → n = n'.
Proof.
  intros n n' Hneq0. apply INJ; auto.
  intros Heq. rewrite Heq Rabs_right in Hneq0; nra.
Qed.

Lemma abs_cov: ∀ n, Rabs (a n) <> 0 → ∃ m, σ m = n.
Proof.
  intros n Hneq0.
  eapply COV.
  intros Heq. rewrite Heq Rabs_right in Hneq0; nra.
Qed.

Lemma summable_implies_ds:
  double_summable a.
Proof.
  destruct (sum_n_m_cover_diff_double (λ x, Rabs (a x)) σ abs_inj abs_cov O) as (N&HN).
  apply double_summable_mono_cond.
  destruct EXS as (r&His).
  exists r, N. intros n Hge.
  destruct (HN n n) as (N'&Hge'&Hdiff); try omega.
  rewrite sum_O //= in Hdiff.
  setoid_rewrite <-Rabs_triang_inv in Hdiff.
  apply Rle_minus_l in Hdiff.
  rewrite Rplus_comm in Hdiff.
  rewrite /comp//= in Hdiff.

  replace (Rabs (Rabs (a (σ 0))) + sum_n_m (λ x : nat, Rabs (Rabs (a (σ x)))) 1 N')
          with (sum_n_m (λ x, Rabs (Rabs (a (σ x)))) 0 N') in Hdiff; last first.
  { rewrite (sum_Sn_m (λ x, Rabs (Rabs (a (σ x)))) 0 N') //=. }
  etransitivity.
  { eapply Rle_abs. }
  etransitivity; eauto.
  apply is_series_partial_pos.
  * intros; apply Rle_ge, Rabs_pos.
  * eapply is_series_ext; last eassumption.
    intros ? => //=. by rewrite Rabs_Rabsolu.
Qed.

Lemma series_double_covering:
  is_series (λ j, Series (λ k, a (j, k))) (Series (a \o σ)).
Proof.
  destruct (EXS) as (v&Habsconv).
  assert (ex_series (a \o σ)) as (v'&Hconv).
  { apply ex_series_Rabs.  eexists; eauto. }
  assert(Hnorm: ∀ eps : posreal, ∃ N K, ∀ l m, K ≤ l → K ≤ m →
         norm (sum_n (λ j, sum_n (λ k, a (j, k)) m) l - sum_n (a \o σ) N) < eps ∧
         norm (sum_n (a \o σ) N - v') < eps).
  {
    intros eps.

    edestruct (Cauchy_ex_series (Rabs \o a \o σ)) as (N0&IHN).
    { exists v; eauto. }
    assert (∃ N, ∀ N', N' ≥ N → norm (sum_n (a \o σ) N' - v') < eps) as (N2&HN2).
    { rewrite /is_series in Hconv.
      edestruct Hconv as (x&Hball). eapply locally_ball.
      exists x. eapply Hball.
    }
    set (N := max N0 N2).
    edestruct (sum_n_m_cover_diff_double _ _ INJ COV N) as (M&IHM2).
    exists N. exists M => m l Hm Hl.
    rewrite /norm//=/abs//=; repeat split; auto.
    - edestruct (IHM2 m l) as (n&?&Hle); auto.
      eapply Rle_lt_trans; first eapply Hle.
      rewrite /norm//=/abs//= in IHN.
      eapply Rle_lt_trans; first apply Rle_abs.
      assert (N0 <= N)%coq_nat.
      { rewrite /N. apply Max.le_max_l. }
      eapply IHN; auto. omega.
    - eapply HN2.
      rewrite /N. etransitivity; first apply Max.le_max_r. done.
  }
  assert(Hnorm': ∀ eps : posreal, ∃ N K, ∀ l, K ≤ l  →
         norm (sum_n (λ j, Series (λ k, a (j, k))) l - sum_n (a \o σ) N) < eps ∧
         norm (sum_n (a \o σ) N - v') < eps).
  {
    intros eps.
    edestruct (Hnorm (pos_div_2 eps)) as (N&K&Hdiff).
    exists N, K; split.
    - apply (Rle_lt_trans _ (pos_div_2 eps)); last by (destruct eps => //=; nra).
      transitivity (Lim_seq (λ k, norm (sum_n (λ j, sum_n (λ k, a (j, k)) k) l
                                        - sum_n (a \o σ) N))); last first.
      {
        eapply Rbar_le_fin; first by (destruct eps; rewrite //=; nra).
        rewrite -Lim_seq_const. apply Lim_seq_le_loc.
        exists K => m Hle. apply Rlt_le. eapply Hdiff; auto.
      }
      right. symmetry. apply Rbar_eq_fin.
      eapply is_lim_seq_unique.
      rewrite /norm//=/abs//=. apply is_lim_seq_fin_abs.
              eapply is_lim_seq_minus; [ | apply is_lim_seq_const | ].
       eapply (is_lim_seq_sum_n _ (λ j, Series (λ k, a (j, k)))).
       { intros ????.
         edestruct (Series_correct (λ k, a (j, k))) as (n&?).
         { apply ex_series_Rabs, ex_series_row, summable_implies_ds. }
         eauto. rewrite /filtermap. exists n. eauto.
       }
       rewrite //=.
    - edestruct Hdiff; eauto. transitivity (pos_div_2 eps); auto.
      destruct eps => //=; fourier.
  }
  assert (Series (a \o σ) = v') as -> by (eapply is_series_unique; eauto).
    rewrite /is_series. eapply filterlim_locally => eps.
    edestruct (Hnorm' (pos_div_2 eps)) as (N&M&?HNM).
    exists M => m Hle.
    specialize (HNM m Hle) as (?&?).
    rewrite /ball//=/AbsRing_ball//=/abs/AbsRing.abs//=/minus//=/plus//=/opp//=.
    specialize (norm_dist_mid (sum_n (λ j : nat, Series (λ k : nat, a (j, k))) m)
                              v' (sum_n (a \o σ) N)).
    rewrite {1}/norm//={1}/Rminus.
    intros Hle'. eapply Rle_lt_trans; first eapply Hle'.
    destruct eps as (eps&?).
    replace (eps) with (eps/2 + eps/2); last by field.
    apply Rplus_lt_compat; eauto.
Qed.

Lemma series_double_covering':
  is_series (a \o σ) (Series (λ j, Series (λ k, a (j, k)))).
Proof.
  specialize (is_series_unique _ _ (series_double_covering)) => ->.
  apply Series_correct, ex_series_Rabs, EXS.
Qed.

End covering2.
End pre_converge.

Section summable.

Variable (a: nat * nat → R).
Variable (σ: nat → nat * nat).

Variable (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n').
Variable (COV: ∀ n, a n <> 0 → ∃ m, σ m = n).

Variable (DS: double_summable a).

Lemma ex_series_ordering:
  ex_series (Rabs \o a \o σ).
Proof.
  destruct DS as (M&HM).
  cut (∃ l: R, is_lim_seq (λ n, sum_n (Rabs \o a \o σ) n) l).
  { rewrite /ex_lim_seq/is_lim_seq/ex_series/is_series. rewrite //=.  }
  cut (∃ l: Rbar, is_lim_seq (λ n, sum_n (Rabs \o a \o σ) n) l).
  { intros (l&Hislim).
    assert (Rbar_le l M) as Hle.
    { eapply (is_lim_seq_le _ (λ n, M)); eauto; last by (apply is_lim_seq_const).
      intros n. edestruct (pre_converge.inj_nat_cover1 σ n) as (K&HK).
      etransitivity; last apply (HM K) => //=.
      rewrite ?sum_n_bigop.
      etransitivity; last first.
      { right. apply eq_bigr. intros; rewrite sum_n_bigop. done. }
      rewrite //=pair_big_dep//=/index_enum.
      rewrite bigop_cond_non0 [a in _ <= a]bigop_cond_non0.
      set (σ' := λ x: 'I_(S n),
                      match x with
                        | Ordinal k Hle =>
                          let (pf1, pf2) := HK _ (le_S_n _ _ (proj1 (SSR_leq _ _) Hle)) in
                          (Ordinal (proj2 (SSR_leq _ _) (le_n_S _ _ pf1)),
                           Ordinal (proj2 (SSR_leq _ _) (le_n_S _ _ pf2)))
                      end).
      eapply (sum_reidx_map_le _ _ _ _ σ').
      - intros (m&?) _. rewrite /σ' //=. right. repeat f_equal.
        destruct (HK m _) => //=. destruct (σ m) => //=.
      - rewrite //=. intros (x&?) ? Hneq0; split; auto.
        * rewrite -enumT mem_enum //=.
        * move: Hneq0. rewrite /σ'. destruct (HK x _) => //=.
          destruct (σ x) => //=.
      - intros. apply Rle_ge, Rabs_pos.
      - rewrite -enumT. apply enum_uniq.
      - rewrite -enumT. apply: enum_uniq.
      - rewrite /σ'; intros (x&?) (y&?).
        destruct (HK x); destruct (HK y); rewrite //= => Hneq0. inversion 1. apply ord_inj => //=.
        eapply INJ; eauto.
        * move /eqP in Hneq0. intros Heq0. rewrite Heq0 in Hneq0.
          apply Hneq0. rewrite Rabs_R0. done.
        * destruct (σ x), (σ y); auto.
    }
    assert (Rbar_le 0 l) as Hge.
    {
      eapply (is_lim_seq_le (λ n, 0)); eauto; last by (apply is_lim_seq_const).
      intros n => /=. rewrite sum_n_bigop. apply Rle_big0 => ??. apply Rabs_pos.
    }
    destruct l as [l| |].
    * exists l. auto.
    * inversion Hle.
    * inversion Hge.
  }
  apply ex_lim_seq_incr.
  intros n. rewrite sum_Sn/plus//=. specialize (Rabs_pos (a (σ (S n)))). nra.
Qed.

Lemma series_double_covering:
  is_series (λ j, Series (λ k, a (j, k))) (Series (a \o σ)).
Proof.
  apply pre_converge.series_double_covering; eauto.
  apply ex_series_ordering.
Qed.

Lemma series_double_covering':
  is_series (a \o σ) (Series (λ j, Series (λ k, a (j, k)))).
Proof.
  specialize (is_series_unique _ _ (series_double_covering)) => ->.
  apply Series_correct, ex_series_Rabs, ex_series_ordering.
Qed.

End summable.

Lemma series_double_covering_Rabs a σ
      (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n')
      (COV: ∀ n, a n <> 0 → ∃ m, σ m = n)

      (DS: double_summable a):
  is_series (λ j, Series (λ k, Rabs (a (j, k)))) (Series (Rabs \o a \o σ)).
Proof.
  apply pre_converge.series_double_covering; eauto.
  - rewrite //=.  intros n n' Hneq0. eapply INJ; eauto. intros Heq0. rewrite Heq0 in Hneq0.
      rewrite Rabs_R0 in Hneq0. nra.
  - rewrite //=.  intros n Hneq0. eapply COV; eauto. intros Heq0. rewrite Heq0 in Hneq0.
      rewrite Rabs_R0 in Hneq0. nra.
  - apply ex_series_ordering.
    * intros. apply INJ; auto.
      intros HNEQ. apply H => //=. by rewrite HNEQ Rabs_R0.
    * by apply double_summable_abs.
Qed.

Lemma series_double_covering_Rabs' a σ
      (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n')
      (COV: ∀ n, a n <> 0 → ∃ m, σ m = n)

      (DS: double_summable a):

  is_series (Rabs \o a \o σ) (Series (λ j, Series (λ k, Rabs (a (j, k))))).
Proof.
  eapply series_double_covering'; eauto.
  - rewrite //=.  intros n n' Hneq0. eapply INJ; eauto. intros Heq0. rewrite Heq0 in Hneq0.
      rewrite Rabs_R0 in Hneq0. nra.
  - rewrite //=.  intros n Hneq0. eapply COV; eauto. intros Heq0. rewrite Heq0 in Hneq0.
      rewrite Rabs_R0 in Hneq0. nra.
  -  rewrite /double_summable//=. edestruct DS as (r&Hr).
     exists r. intros n. etransitivity; last (apply Hr).
     right. do 2 apply sum_n_ext => ?. rewrite Rabs_Rabsolu. done.
Qed.

Lemma sum_n_m_ext_const_zero: ∀ (G : AbelianGroup) (a : nat → G) (n m : nat),
    (∀ n, a n = zero) →
    sum_n_m a n m = zero.
Proof.
  intros G a n m Hz. rewrite (sum_n_m_ext _ (λ x, zero)) //.
  by rewrite sum_n_m_const_zero.
Qed.

Module double_swap.
Section double_swap.

Variable (a : nat * nat → R).
Variable (DS: double_summable a).

Definition σ := λ x, match pickle_inv [countType of nat * nat] x with
            | Some (m, n) => (S m, S n)
            | None => (O, O)
            end.

Definition a' := λ mn, match mn with
                   | (S m', S n') => a (m', n')
                   | (_, _) => 0
                   end.

Lemma a_a'_Series_ext j: (λ j, Series (λ k, a (j, k))) j = (λ j, Series (λ k, a' (S j, S k))) j.
Proof. by apply Series_ext => //=. Qed.

Lemma a_a'_Series_ext_swap j:
  (λ k, Series (λ j, a (j, k))) j = (λ k, Series (λ j, a' (S j, S k))) j.
Proof. by apply Series_ext => //=. Qed.

Lemma a_a'_finite_sum n m:
  sum_n (λ j, sum_n (λ k, a (j, k)) m) n =
  sum_n (λ j, sum_n (λ k, a' (j, k)) (S m)) (S n).
Proof.
  symmetry. rewrite /sum_n.
  rewrite sum_Sn_m; last by (nify; omega).
  rewrite sum_n_m_ext_const_zero; last first.
  { intros [|] => //=.  }
  rewrite plus_zero_l.
  rewrite -sum_n_m_S.
  apply sum_n_m_ext.
  intros n'.
  rewrite sum_Sn_m; last by (nify; omega).
  rewrite plus_zero_l.
  rewrite -sum_n_m_S.
  done.
Qed.

Lemma a_a'_finite_sum_abs n m:
  sum_n (λ j, sum_n (λ k, Rabs (a (j, k))) m) n =
  sum_n (λ j, sum_n (λ k, Rabs (a' (j, k))) (S m)) (S n).
Proof.
  symmetry. rewrite /sum_n.
  rewrite sum_Sn_m; last by (nify; omega).
  rewrite sum_n_m_ext_const_zero; last first.
  { intros [|] => //=; rewrite Rabs_R0; done. }
  rewrite plus_zero_l.
  rewrite -sum_n_m_S.
  apply sum_n_m_ext.
  intros n'.
  rewrite sum_Sn_m; last by (nify; omega).
  rewrite Rabs_R0 plus_zero_l.
  rewrite -sum_n_m_S.
  done.
Qed.

Lemma ds_a': double_summable a'.
Proof.
  rewrite /double_summable. destruct DS as (r&HDS).
  exists r. intros n. destruct n.
  - rewrite ?sum_O => //=. rewrite Rabs_R0.
    etransitivity; last by (eapply (HDS O)).
    rewrite ?sum_O => //=. apply Rabs_pos.
  - rewrite -a_a'_finite_sum_abs. eauto.
Qed.

Lemma σ_inj:
  ∀ n n' : nat, a' (σ n) ≠ 0 → σ n = σ n' → n = n'.
Proof.
  intros n n'. rewrite /σ.
  specialize (pickle_invK [countType of nat * nat] n).
  specialize (pickle_invK [countType of nat * nat] n').
  destruct (pickle_inv) as [(?&?)|] => //=;
  destruct (pickle_inv) as [(?&?)|] => //=;
  intros <- ? ?. inversion 1. subst => //=.
Qed.

Lemma is_series_a'_σ_rows:
  is_series (λ j : nat, Series (λ k : nat, a' (j, k))) (Series (a' \o σ)).
Proof.
  eapply series_double_covering => //=.
  - apply σ_inj.
  - intros ([|m]&[|n]) ? => //=. exists (pickle (m, n)). rewrite /σ pickleK_inv.
    done.
  - apply ds_a'.
Qed.

Lemma is_series_a'_σ_columns:
  is_series (λ k : nat, Series (λ j : nat, a' (j, k))) (Series (a' \o σ)).
Proof.
  set (σflip := λ x, match pickle_inv [countType of nat * nat] x with
                 | Some (m, n) => pickle (n, m)
                 | None =>  x
                 end).
  set (flip := λ (x : nat * nat), (snd x, fst x)).
  eapply (is_series_ext (λ k, Series (λ j: nat, (a' \o flip) (k, j)))).
  { intros n. apply Series_ext => //=. }
  cut (Series (a' \o σ) = Series ((a' \o flip) \o σ)).
  { intros ->. eapply series_double_covering => //=.
    - intros n n'. rewrite /σ.
      specialize (pickle_invK [countType of nat * nat] n).
      specialize (pickle_invK [countType of nat * nat] n').
    destruct (pickle_inv) as [(?&?)|] => //=;
    destruct (pickle_inv) as [(?&?)|] => //=;
    intros <- ? ?. inversion 1. subst => //=.
    - intros ([|m]&[|n]) ? => //=. exists (pickle (m, n)). rewrite /σ pickleK_inv.
    done.
    - apply double_summable_flip. eapply double_summable_ext; last by eapply ds_a'.
      rewrite //=.
  }
  assert (Series ((a' \o flip) \o σ) = Series ((a' \o σ) \o σflip)) as ->.
  {
    apply Series_ext => n. rewrite //=.
    rewrite /σflip/σ/a'.
    case_eq (pickle_inv [countType of (nat * nat)] n).
    - intros (?&?) => //=. by rewrite pickleK_inv.
    - intros Hnone => //=.
      rewrite Hnone. done.
  }
  apply Series_rearrange_covering.
  - intros n n'. rewrite /σ/σflip/a' => //=.
    case_eq (pickle_inv [countType of (nat * nat)] n).
    * intros (?&?) Heq. rewrite Heq => //=.
      rewrite pickleK_inv.
      case_eq (pickle_inv [countType of (nat * nat)] n').
      ** intros (?&?) Heq'. rewrite Heq' => //=.
         intros ? Heqp.
         apply (f_equal (pickle_inv [countType of (nat * nat)])) in Heqp.
         rewrite ?pickleK_inv in Heqp.
         inversion Heqp; subst.
         rewrite -Heq' in Heq.
         symmetry in Heq. eapply pickle_inv_some_inj in Heq; eauto.
      ** intros Hnone. rewrite Hnone => ? Hfalse. rewrite -Hfalse in Hnone.
         rewrite pickleK_inv in Hnone. congruence.
    * intros Hnone. rewrite ?Hnone.
      case_eq (pickle_inv [countType of (nat * nat)] n').
      ** intros (?&?) Heq'. rewrite Heq' => //=.
      ** intros Hnone'. by rewrite Hnone' => ?? //=.
  - intros n. rewrite //=. rewrite /σ.
    case_eq (pickle_inv [countType of (nat * nat)] n).
    * intros (m', n') Hinv ?. exists (pickle (n', m')).
      rewrite /σflip pickleK_inv.
      apply pickle_inv_some_inv; auto.
    * intros Hnone => //=.
  - apply ex_series_ordering.
    * apply σ_inj.
    * apply ds_a'.
Qed.

Lemma Series_a'_shift:
  (Series (λ n : nat, Series (λ j : nat, a' (j.+1, n.+1)))) =
  (Series (λ n : nat, Series (λ j : nat, a' (j, n)))).
Proof.
  symmetry. rewrite Series_incr_1; first rewrite Series_0.
  * rewrite Rplus_0_l. apply Series_ext.
    intros n'. rewrite Series_incr_1; first by (rewrite //=; nra).
    apply ex_series_Rabs. apply ex_series_column, ds_a'.
  * intros [|] => //=.
  * eexists; eapply is_series_a'_σ_columns.
Qed.

Lemma is_series_a'_shift v:
  is_series (λ j : nat, Series (λ n : nat, a' (j, n))) v →
  is_series (λ j : nat, Series (λ n : nat, a' (j.+1, n.+1))) v.
Proof.
  intros.
  apply (is_series_incr_1 (λ n, Series (λ k, a' (n, S k)))).
  rewrite (Series_0 (λ k, a' (O, S k))); last first.
  { destruct n => //=.  }
  rewrite plus_zero_r.
  eapply is_series_ext; last eauto.
  intros n. rewrite /=. rewrite Series_incr_1 => //=.
  * destruct n; nra.
  * apply ex_series_Rabs.
    apply (ex_series_row a'), ds_a'.
Qed.

Lemma ex_series_a'_shift:
  ex_series (λ j : nat, Series (λ n : nat, a' (j, n))) →
  ex_series (λ j : nat, Series (λ n : nat, a' (j.+1, n.+1))).
Proof.
  intros (v&?).
  exists v. eapply is_series_a'_shift.
  eauto.
Qed.

Lemma series_double_swap:
  is_series (λ j, Series (λ k, a (j, k))) (Series (λ k, Series (λ j, a (j, k)))).
Proof.
  eapply is_series_ext; first eapply a_a'_Series_ext.
  cut (is_series (λ j, Series (λ k, a' (j, k))) (Series (λ k : nat, Series (λ j : nat, a' (j, k)))));
    last first.
  {
    cut (Series (λ k, Series (λ j, a' (j, k))) = Series (a' \o σ)).
    { intros Heq. rewrite Heq. apply is_series_a'_σ_rows. }
    apply is_series_unique, is_series_a'_σ_columns.
  }
  intros Hseries.
  eapply is_series_ext.
  { symmetry.  apply a_a'_Series_ext. }
  erewrite (Series_ext); last first.
  { intros n. apply a_a'_Series_ext_swap. }
  rewrite Series_a'_shift. by apply is_series_a'_shift.
Qed.

End double_swap.
End double_swap.

Lemma series_double_swap a (DS: double_summable a):
  is_series (λ j, Series (λ k, a (j, k))) (Series (λ k, Series (λ j, a (j, k)))).
Proof. by apply double_swap.series_double_swap. Qed.

Lemma Series_double_swap a (DS: double_summable a):
  Series (λ j, Series (λ k, a (j, k))) =  (Series (λ k, Series (λ j, a (j, k)))).
Proof. apply is_series_unique. by apply series_double_swap. Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Definition Mx (C : Prop) (A : Set) :=
  forall (X : Set) (P : Prop) (e : P -> X), (C -> P) -> (A -> X) -> X.

Definition Mx_unit (C : Prop) (A : Set) (a : A) : Mx C A :=
  fun (X : Set) (P : Prop) (e : P -> X) (i : C -> P) (k : A -> X) => k a.

Definition Mx_raise (C : Prop) (A : Set) (c : C) :
  Mx C A :=
  fun (X : Set) (P : Prop) (e : P -> X) (i : C -> P) (k : A -> X) => e (i c).

Definition Mx_try (C : Prop) (A : Set) (m : Mx C A)
  (X : Set) (k : A -> X) (e : C -> X) : X := m X C e (fun p : C => p) k.

Definition Mx_bind (A A' : Set) (C C' : Prop) (m : Mx C A)
  (f : A -> Mx C' A') (j : C -> C') : Mx C' A' :=
  fun (X : Set) (P : Prop) (e : P -> X) (i : C' -> P) (k : A' -> X) =>
  m X P e (fun c : C => i (j c)) (fun a : A => f a X P e i k).


Set Implicit Arguments.

Require Import
        Discrete.DiscreteType
        Finite.FinType
        Tactics.Tactics.

Import ListNotations.

Definition to_sum_listl {A : Type}  (B : Type) (xs : list A): list (A + B) :=
  map inl xs.

Definition to_sum_listr {B : Type}  (A : Type) (xs : list B): list (A + B) :=
  map inr xs.

Lemma count_to_sum_listl {A : discType}  (B : discType) (xs : list A) x
  : count (to_sum_listl B xs) (inl x) = count xs x.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma count_to_sum_listr {B : discType}  (A : discType) (xs : list B) x
  : count (to_sum_listr A xs) (inr x) = count xs x.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma count_to_sum_listl_zero {A : discType}(B : discType)(xs : list A)(y : B)
  : count (to_sum_listl B xs) (inr y) = 0.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma count_to_sum_listr_zero {B : discType}(A : discType)(xs : list B)(x : A)
  : count (to_sum_listr A xs) (inl x) = 0.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma prove_one m n : m = 1 /\ n = 0 \/ n = 1 /\ m = 0 -> m + n = 1.
Proof.
  omega.
Qed.

Lemma to_sum_listl_missing (A B : discType) (y : B) (xs : list A)
  : count (to_sum_listl B xs) (inr y) = 0.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma to_sum_listr_missing (A B : discType) (x : A) (xs : list B)
  : count (to_sum_listr A xs) (inl x) = 0.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma sum_enum_sound (A : finType) (B : finType) x :
  count (to_sum_listl B (elem A) ++ to_sum_listr A (elem B)) x = 1.
Proof.
  rewrite count_app. apply prove_one. destruct x.
  -
    left. split.
    +
      rewrite count_to_sum_listl. apply enum_sound.
    +
      apply to_sum_listr_missing.
  - right. split.
    +
      rewrite count_to_sum_listr. apply enum_sound.
    +
      apply to_sum_listl_missing.
Qed.

Instance FinTypeC_sum (A B : finType) : FinTypeC (DiscSum A B).
Proof.
  econstructor. apply sum_enum_sound.
Defined.

Canonical Structure FinType_sum (A B : finType) : finType := FinType (DiscSum A B).
Notation "A (+) B" := (FinType_sum A B) (at level 50, left associativity).

Lemma cardinality_sum (A B : finType)
  : Cardinality (FinType_sum A B) = Cardinality A + Cardinality B.
Proof.
  unfold Cardinality.
  cbn.
  rewrite app_length.
  unfold to_sum_listl, to_sum_listr. now repeat rewrite map_length.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2007-02-07
- Ducas Leo 2007-08-06

iteration of a relation
*)

Set Implicit Arguments.

From Coq Require Import List.
From CoLoR Require Import Path NatUtil RelUtil LogicUtil Log2.

Section S.

Variables (A : Type) (R : relation A).

Fixpoint iter (n : nat) : relation A :=
  match n with
    | O => R
    | S p => R @ iter p
  end.

(***********************************************************************)
(** properties *)

Lemma iter_tc : forall n, iter n << R!.

Proof.
induction n; intros; simpl. apply incl_tc. refl. unfold inclusion. intros.
do 2 destruct H. apply t_trans with x0. apply t_step. exact H.
apply IHn. exact H0.
Qed.

Lemma iter_iter : forall p q, iter p @ iter q << iter (p+q+1).

Proof.
induction p; simpl; intros. rewrite plus_1_S. simpl. refl.
assoc. comp. apply IHp.
Qed.

Lemma iter_plus_1 : forall p q, iter (p+q+1) << iter p @ iter q.

Proof.
induction p; simpl; intros. rewrite plus_1_S. simpl. refl.
incl_trans (R @ (iter p @ iter q)). comp. apply IHp. apply comp_assoc'.
Qed.

Lemma iter_commut : forall p q, iter p @ iter q << iter q @ iter p.

Proof.
intros. incl_trans (iter (p+q+1)). apply iter_iter.
assert (p+q+1 = q+p+1). lia.
rewrite H. apply iter_plus_1.
Qed.

(***********************************************************************)
(** unions of iterated relations *)

Definition Iter_ge k x y := exists n, n >= k /\ iter n x y.

Definition Iter := Iter_ge 0.

Fixpoint iter_le (n : nat) : relation A :=
  match n with
    | O => R
    | S p => iter n U iter_le p
  end.

(***********************************************************************)
(** properties *)

Lemma tc_iter : R! << Iter.

Proof.
unfold inclusion. induction 1; simpl; intros. exists 0. auto.
destruct IHclos_trans1. destruct IHclos_trans2. intuition.
exists (x0+x1+1). intuition. eapply incl_elim. apply iter_iter.
exists y. auto.
Qed.

Lemma Iter_split : forall n, Iter << iter_le n U Iter_ge (S n).

Proof.
induction n; simpl; intros; unfold inclusion; intros.
do 2 destruct H. destruct x0. left. auto.
right. exists (S x0). intuition.
ded (IHn _ _ H). destruct H0. left. right. exact H0.
do 2 destruct H0. case (le_lt_dec x0 (S n)); intro.
assert (x0 = S n). lia. subst x0. left. left. exact H1.
right. exists x0. intuition.
Qed.

Lemma Iter_ge_split : forall n, Iter_ge n << iter n U Iter_ge (S n).

Proof.
induction n; simpl; intros; unfold inclusion; intros; do 2 destruct H.
case (le_lt_dec x0 0); intro. assert (x0 = 0). lia. subst x0.
left. exact H0.
right. exists x0. intuition.
case (le_lt_dec x0 (S n)); intro. assert (x0 = S n). lia. subst x0.
left. exact H0.
right. exists x0. intuition.
Qed.

Lemma iter_Iter_ge_commut : forall n p,
  iter n @ Iter_ge p << Iter_ge p @ iter n.

Proof.
unfold inclusion. intros. do 2 destruct H. do 2 destruct H0.
assert ((iter x1 @ iter n) x y). eapply incl_elim. apply iter_commut.
exists x0. intuition. do 2 destruct H2. exists x2. intuition.
exists x1. intuition.
Qed.

Lemma iter_Iter_ge : forall n p, iter n @ Iter_ge p << Iter_ge (n+p+1).

Proof.
unfold inclusion. intros. do 2 destruct H. do 2 destruct H0.
exists (n+x1+1). intuition. apply iter_iter. exists x0. intuition.
Qed.

Lemma incl_Iter_ge : forall n p, p <= n -> Iter_ge n << Iter_ge p.

Proof.
unfold inclusion. intros. do 2 destruct H0. exists x0. intuition.
Qed.

(***********************************************************************)
(** Alternative definitions of iter_le *)

Fixpoint iter_le2 n :=
  match n with
    | O => R
    | S i => (R @ iter_le2 i) U iter_le2 i
  end.

Fixpoint iter_le_fast n :=
  match n with
    | O => R
    | S i => let R' := iter_le_fast i in R' @ R' U R'
  end.

(***********************************************************************)
(** Equivalence between the different definitions *)

Lemma iter_le_spec : forall n x y,
  iter_le n x y <-> exists p, p <= n /\ iter p x y.

Proof.
intro; induction n.
intros; simpl in *.
split; intros. exists 0; split; auto with *.
destruct H as [p]; destruct H; assert(p=0); auto with *.
subst; auto with *.
split; intros; simpl in *.
unfold compose in H; destruct H.
destruct H as [z]; exists (S n); split; auto with *.
simpl; unfold compose; exists z; hyp.

rewrite IHn in H; destruct H as [p]; exists p; intuition; auto with *.

destruct H as [p]; destruct H. destruct (le_lt_eq_dec H).
right; apply lt_n_Sm_le in l; rewrite IHn; exists p; auto with *.
subst; left; unfold compose in H0; auto with *.
Qed.

Lemma iter_le2_spec : forall n x y,
  iter_le2 n x y <-> exists p, p <= n /\ iter p x y.

Proof.
intro. induction n.
intros; simpl in *; split; intros. exists 0; split; auto with *.
destruct H as [p]; destruct H; assert(p=0); auto with *.
subst; auto with *.
split; intros; simpl in *.

unfold compose in H; destruct H.
destruct H as [z]; destruct H; rewrite IHn in H0; destruct H0 as [p];
  exists (S p).
split; auto with *. simpl; unfold compose; exists z; intuition; auto with *.

rewrite IHn in H; destruct H as [p]; exists p; intuition; auto with *.

destruct H as [p]; destruct H.
destruct (le_lt_eq_dec H).
right; apply lt_n_Sm_le in l; rewrite IHn; exists p; auto with *.
subst; left; unfold compose in H0; auto with *.
simpl in H0; unfold compose in *; destruct H0 as [z]; exists z.
split; destruct H0; auto with *.
rewrite IHn; exists n; auto.
Qed.

Lemma iter_compose : forall p q, iter p @ iter q << iter (p+q+1).

Proof.
intros; induction p.
assert (S(q) = q+1); auto with *.
simpl; rewrite <- H; simpl; intuition.
unfold inclusion; intros.
simpl in H; repeat destruct H.
simpl; unfold compose.
exists x1; split; auto with *.
unfold inclusion in IHp; eapply IHp.
simpl; unfold compose.
exists x0; split; auto with *.
Qed.

Lemma iter_le_fast_spec : forall n x y,
  iter_le_fast n x y <-> exists p,(S p) <= exp2 n /\ iter p x y.

Proof.
intro. induction n.
intros; simpl in *; split; intros. exists 0; split; auto with *.
destruct H as [p]; destruct H; assert(p=0); auto with *.
subst; auto with *. split; intros; simpl in *.
destruct H.
destruct H as [z]; destruct H. rewrite IHn in H0; rewrite IHn in H.
destruct H0 as [p]; destruct H as [p']; destruct H0; destruct H.
exists (p+p'+1). split. lia.
assert ((iter p' @ iter p) x y). unfold compose; exists z; auto with *.
assert (p+p'+1=p'+p+1); intuition.
rewrite H4; apply iter_compose; auto with *.
rewrite IHn in H; destruct H as [p]; exists p; intuition.
destruct H as [p]; destruct H; simpl in H.

destruct (le_gt_dec (S p) (exp2 n)).
right; rewrite IHn; exists p; split; auto with *.
assert(p = (exp2 n - 1) + (p - exp2 n) +1 ).
lia.
rewrite H1 in H0. ded (iter_plus_1 _ _ _ _ H0).
left; unfold compose in *; destruct H2 as [z]; destruct H2.
exists z; split; rewrite IHn.
exists (exp2 n -1); intuition; lia.
exists (p -exp2 n); intuition; lia.
Qed.

Lemma iter_le_same n x y : iter_le2 n x y <-> iter_le n x y.

Proof. rewrite iter_le_spec, iter_le2_spec. tauto. Qed.

Lemma iter_le_fast_exp2_same n x y :
  iter_le_fast n x y <-> iter_le ((exp2 n)-1) x y.

Proof.
rewrite iter_le_spec, iter_le_fast_spec.
split; intro; destruct H as [p]; exists p; split_all; ded (exp2_pos n); lia.
Qed.

(***********************************************************************)
(** relation with paths *)

Lemma iter_path : forall n x y,
  iter n x y -> exists l, length l = n /\ path R x y l.

Proof.
induction n; simpl; intros. exists nil. intuition.
do 2 destruct H. ded (IHn _ _ H0). do 2 destruct H1. subst n.
exists (x0 :: x1). simpl. intuition.
Qed.

Lemma path_iter : forall l x y, path R x y l -> iter (length l) x y.

Proof.
induction l; simpl; intros. exact H. exists a. intuition.
Qed.

Lemma bpath_iter_le : forall n x y, bpath R n x y -> iter_le n x y.

Proof.
intro; induction n; intros; simpl in *.
inversion H; subst; destruct l; simpl in *; auto with *; inversion H0.
gen (bpath_Sn_n_or_Rn H); intros; destruct H0.
simpl in *; right; apply IHn; auto with *.
destruct H0 as [z]; destruct H0; ded (IHn _ _ H1).
simpl; rewrite iter_le_spec in *; destruct H2 as [p]; destruct H2.
destruct (le_lt_eq_dec H2).
right; rewrite iter_le_spec; exists (S p); intuition.
simpl; unfold compose; exists z; intuition.
left; subst; unfold compose; exists z; intuition.
Qed.

Lemma iter_le_bpath : forall n x y, iter_le n x y -> bpath R n x y .

Proof.
intros.
rewrite iter_le_spec in H; destruct H as [j]; destruct H.
ded (iter_path _ _ _ H0); destruct H1 as [l]; destruct H1.
eapply bp_intro; try ehyp; auto; subst; hyp.
Qed.

End S.

(***********************************************************************)
(** implicit arguments *)

Arguments iter_path [A R n x y] _.
Arguments path_iter [A R l x y] _.


(***************************************************************************
* Variation on FSet from library                                           *
* Brian Aydemir, March 2007, Coq v8.1                                      *
***************************************************************************)

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

(* $Id$ *)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Eqdep_dec.
Require Import FSetList.
Require Import OrderedTypeEx.

Require Import Lib_ListFacts.
Require Import Lib_FinSet.

(* XXX modified functor name and signature *)

(** First, implement only [FSetInterface.S]. *)

Module MakeRaw (X : UsualOrderedType) <: FSetInterface.S with Module E := X.

 Module Raw := Raw X.
 Module E := X.

 (* XXX new code begins here *)

 Module OTFacts := OrderedTypeFacts E.

 Definition sort_bool (xs : Raw.t) :=
   (if (sort_dec E.lt OTFacts.lt_dec xs) then true else false) = true.

 Record slist : Type :=
  {this   :> Raw.t;
   sorted :  sort_bool this}.

 Definition from_sorted : forall (xs : Raw.t), sort E.lt xs -> sort_bool xs.
 Proof.
   intros xs H. unfold sort_bool.
   case (sort_dec E.lt OTFacts.lt_dec xs); tauto.
 Defined.

 Definition to_sorted : forall xs, sort_bool xs -> sort E.lt xs.
 Proof.
   unfold sort_bool. intros xs.
   case (sort_dec E.lt OTFacts.lt_dec xs); auto.
   intros. discriminate.
 Defined.

 Coercion to_sorted : sort_bool >-> sort.

 Definition Build_slist' (xs : Raw.t) (pf : sort E.lt xs) :=
   Build_slist (from_sorted pf).

 (* XXX new code ends here *)

 (* XXX lots of minor minor tweaks *)

 Definition t := slist.
 Definition elt := E.t.

 Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
 Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
 Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
 Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
 Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x.
 Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x.

 Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
 Definition add (x : elt)(s : t) : t := Build_slist' (Raw.add_sort (sorted s) x).
 Definition remove (x : elt)(s : t) : t := Build_slist' (Raw.remove_sort (sorted s) x).
 Definition singleton (x : elt) : t  := Build_slist' (Raw.singleton_sort x).
 Definition union (s s' : t) : t :=
   Build_slist' (Raw.union_sort (sorted s) (sorted s')).
 Definition inter (s s' : t) : t :=
   Build_slist' (Raw.inter_sort (sorted s) (sorted s')).
 Definition diff (s s' : t) : t :=
   Build_slist' (Raw.diff_sort (sorted s) (sorted s')).
 Definition equal (s s' : t) : bool := Raw.equal s s'.
 Definition subset (s s' : t) : bool := Raw.subset s s'.
 Definition empty : t := Build_slist' Raw.empty_sort.
 Definition is_empty (s : t) : bool := Raw.is_empty s.
 Definition elements (s : t) : list elt := Raw.elements s.
 Definition min_elt (s : t) : option elt := Raw.min_elt s.
 Definition max_elt (s : t) : option elt := Raw.max_elt s.
 Definition choose (s : t) : option elt  := Raw.choose s.
 Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s.
 Definition cardinal (s : t) : nat := Raw.cardinal s.
 Definition filter (f : elt -> bool) (s : t) : t :=
   Build_slist' (Raw.filter_sort (sorted s) f).
 Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
 Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
 Definition partition (f : elt -> bool) (s : t) : t * t :=
   let p := Raw.partition f s in
   (@Build_slist' (fst p) (Raw.partition_sort_1 (sorted s) f),
   @Build_slist' (snd p) (Raw.partition_sort_2 (sorted s) f)).
 Definition eq (s s' : t) : Prop := Raw.eq s s'.
 Definition lt (s s' : t) : Prop := Raw.lt s s'.

 Section Spec.
  Variable s s' s'': t.
  Variable x y : elt.

  Lemma In_1 : E.eq x y -> In x s -> In y s.
  Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed.

  Lemma mem_1 : In x s -> mem x s = true.
  Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed.
  Lemma mem_2 : mem x s = true -> In x s.
  Proof. exact (fun H => Raw.mem_2 H). Qed.

  Lemma equal_1 : Equal s s' -> equal s s' = true.
  Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed.
  Lemma equal_2 : equal s s' = true -> Equal s s'.
  Proof. exact (fun H => Raw.equal_2 H). Qed.

  Lemma subset_1 : Subset s s' -> subset s s' = true.
  Proof. exact (Raw.subset_1 s.(sorted) s'.(sorted)). Qed.
  Lemma subset_2 : subset s s' = true -> Subset s s'.
  Proof. exact (fun H => Raw.subset_2 H). Qed.

  Lemma empty_1 : Empty empty.
  Proof. exact Raw.empty_1. Qed.

  Lemma is_empty_1 : Empty s -> is_empty s = true.
  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
  Lemma is_empty_2 : is_empty s = true -> Empty s.
  Proof. exact (fun H => Raw.is_empty_2 H). Qed.

  Lemma add_1 : E.eq x y -> In y (add x s).
  Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed.
  Lemma add_2 : In y s -> In y (add x s).
  Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed.
  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
  Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed.

  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
  Proof. exact (fun H => Raw.remove_1 s.(sorted) H). Qed.
  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
  Proof. exact (fun H H' => Raw.remove_2 s.(sorted) H H'). Qed.
  Lemma remove_3 : In y (remove x s) -> In y s.
  Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed.

  Lemma singleton_1 : In y (singleton x) -> E.eq x y.
  Proof. exact (fun H => Raw.singleton_1 H). Qed.
  Lemma singleton_2 : E.eq x y -> In y (singleton x).
  Proof. exact (fun H => Raw.singleton_2 H). Qed.

  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
  Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed.
  Lemma union_2 : In x s -> In x (union s s').
  Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed.
  Lemma union_3 : In x s' -> In x (union s s').
  Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed.

  Lemma inter_1 : In x (inter s s') -> In x s.
  Proof. exact (fun H => Raw.inter_1 s.(sorted) s'.(sorted) H). Qed.
  Lemma inter_2 : In x (inter s s') -> In x s'.
  Proof. exact (fun H => Raw.inter_2 s.(sorted) s'.(sorted) H). Qed.
  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
  Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed.

  Lemma diff_1 : In x (diff s s') -> In x s.
  Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed.
  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
  Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed.
  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
  Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed.

  Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
      fold f s i = fold_left (fun a e => f e a) (elements s) i.
  Proof. exact (Raw.fold_1 s.(sorted)). Qed.

  Lemma cardinal_1 : cardinal s = length (elements s).
  Proof. exact (Raw.cardinal_1 s.(sorted)). Qed.

  Section Filter.

  Variable f : elt -> bool.

  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s.
  Proof. exact (@Raw.filter_1 s x f). Qed.
  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true.
  Proof. exact (@Raw.filter_2 s x f). Qed.
  Lemma filter_3 :
      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
  Proof. exact (@Raw.filter_3 s x f). Qed.

  Lemma for_all_1 :
      compat_bool E.eq f ->
      For_all (fun x => f x = true) s -> for_all f s = true.
  Proof. exact (@Raw.for_all_1 s f). Qed.
  Lemma for_all_2 :
      compat_bool E.eq f ->
      for_all f s = true -> For_all (fun x => f x = true) s.
  Proof. exact (@Raw.for_all_2 s f). Qed.

  Lemma exists_1 :
      compat_bool E.eq f ->
      Exists (fun x => f x = true) s -> exists_ f s = true.
  Proof. exact (@Raw.exists_1 s f). Qed.
  Lemma exists_2 :
      compat_bool E.eq f ->
      exists_ f s = true -> Exists (fun x => f x = true) s.
  Proof. exact (@Raw.exists_2 s f). Qed.

  Lemma partition_1 :
      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
  Proof. exact (@Raw.partition_1 s f). Qed.
  Lemma partition_2 :
      compat_bool E.eq f ->
      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof. exact (@Raw.partition_2 s f). Qed.

  End Filter.

  Lemma elements_1 : In x s -> InA E.eq x (elements s).
  Proof. exact (fun H => Raw.elements_1 H). Qed.
  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
  Proof. exact (fun H => Raw.elements_2 H). Qed.
  Lemma elements_3 : sort E.lt (elements s).
  Proof. exact (Raw.elements_3 s.(sorted)). Qed.
  Lemma elements_3w : NoDupA E.eq (elements s).
  Proof. exact (Raw.elements_3w s.(sorted)). Qed.

  Lemma min_elt_1 : min_elt s = Some x -> In x s.
  Proof. exact (fun H => Raw.min_elt_1 H). Qed.
  Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
  Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed.
  Lemma min_elt_3 : min_elt s = None -> Empty s.
  Proof. exact (fun H => Raw.min_elt_3 H). Qed.

  Lemma max_elt_1 : max_elt s = Some x -> In x s.
  Proof. exact (fun H => Raw.max_elt_1 H). Qed.
  Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
  Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed.
  Lemma max_elt_3 : max_elt s = None -> Empty s.
  Proof. exact (fun H => Raw.max_elt_3 H). Qed.

  Lemma choose_1 : choose s = Some x -> In x s.
  Proof. exact (fun H => Raw.choose_1 H). Qed.
  Lemma choose_2 : choose s = None -> Empty s.
  Proof. exact (fun H => Raw.choose_2 H). Qed.
  Lemma choose_3 : choose s = Some x -> choose s' = Some y ->
   Equal s s' -> E.eq x y.
  Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed.

  Lemma eq_refl : eq s s.
  Proof. exact (Raw.eq_refl s). Qed.
  Lemma eq_sym : eq s s' -> eq s' s.
  Proof. exact (@Raw.eq_sym s s'). Qed.
  Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
  Proof. exact (@Raw.eq_trans s s' s''). Qed.

  Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
  Proof. exact (@Raw.lt_trans s s' s''). Qed.
  Lemma lt_not_eq : lt s s' -> ~ eq s s'.
  Proof. exact (Raw.lt_not_eq s.(sorted) s'.(sorted)). Qed.

  Definition compare : Compare lt eq s s'.
  Proof.
  elim (Raw.compare s.(sorted) s'.(sorted));
   [ constructor 1 | constructor 2 | constructor 3 ];
   auto.
  Defined.

  Definition eq_dec : { eq s s' } + { ~ eq s s' }.
  Proof.
  change eq with Equal.
  case_eq (equal s s'); intro H; [left | right].
  apply equal_2; auto.
  intro H'; rewrite equal_1 in H; auto; discriminate.
  Defined.

 End Spec.

End MakeRaw.

(* XXX begin new code *)

(** Now, implement the [FinSet] interface. *)

Module Make (X : UsualOrderedType) <: FinSet with Module E := X.

  Module Import E := X.
  Module Import S := MakeRaw X.

  (** Define aliases. *)

  Definition fset := S.t.
  Definition elt := S.elt.

  (** Equality on these sets is extensional. *)

  Lemma bool_dec : forall x y : bool,
    x = y \/ x <> y.
  Proof.
    induction x; induction y; intuition.
  Qed.

  Theorem eq_ext : forall s s' : t, (forall a, In a s <-> In a s') -> s = s'.
  Proof.
    intros [s H] [s' J] K.
    assert (s = s').
      unfold Raw.t in *. eapply Sort_InA_eq_ext; eauto using to_sorted.
        eexact E.lt_trans.
        eexact E.lt_not_eq.
    subst.
    rewrite (eq_proofs_unicity bool_dec H J).
    reflexivity.
  Qed.

  Theorem eq_if_Equal : forall s s' : t, Equal s s' -> s = s'.
  Proof.
    unfold Equal. intros s s'.
    auto using eq_ext.
  Qed.

End Make.


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

  purpose   : test for Matrix implemented with Function
  author    : ZhengPu Shi
  date      : 2021.12
 *)

From FCS Require Import RingType.
From FCS Require Import RingTypeZ.
From FCS Require Import RingTypeR.
From FCS Require Import MatrixSig.

From FCS Require Export Function.MatrixImpl.

(** * Test for matrix on Z *)
Module Test_for_ModuleZ.

  (** Initialized matrix functor to concrete module *)
  Module MatrixZ := MatrixImpl RingTypeZ.
  Import MatrixZ.

  Open Scope nat_scope.
  Open Scope Z_scope.
  Open Scope matrix_scope.

  (** ** Sum of a sequence *)

  (* Definition of sum *)
  Compute Tsum (fun x => Z.of_nat x) 4. (* 0 + 1 + 2 + 3 = 6 *)

  (** dot production of vectors with different dimension *)
  (*
    (1 + 2 + 3) * (4 + 5) =
    m = 3, n = 2, m * n = 6

    x   x/n   x%n   f(x/n)  f(x%n)  f(x/n)*f(x%n)
    0   0     0     1       4       1*4
    1   0     1     1       5       1*5
    2   1     0     2       4       2*4
    3   1     1     2       5       2*5
    4   2     0     3       4       3*4
    5   2     1     3       5       3*5
    So, the equivalent result is
    = 1*4 + 1*5 + 2*4 + 2*5 + 3*4 + 3*5
    It is very ingenious!
   *)

  Section Tsum_product.
    (* 1,2,3 ... *)
    Local Definition f := fun (x : nat) => Z.of_nat (S x).
    (* 4,5 ... *)
    Local Definition g := fun (x : nat) => Z.of_nat (4 + x).

    Compute Tsum f 3.   (* 1 + 2 + 3 = 6 *)
    Compute Tsum g 2.   (* 4 + 5 = 9 *)

    Local Definition m : nat := 3.
    Local Definition n : nat := 2.

    Check Tsum f m * Tsum g n.
    Check Tsum (fun x => f (x / n)%nat * g (x mod n)%nat) (m * n).

    Compute Tsum f m * Tsum g n.
    Compute Tsum (fun x => f (x / n)%nat * g (x mod n)%nat) (m * n).

  End Tsum_product.

  (** Convert between Lists and Vectors / Matrices *)

  Module Cvt_List_Vec_Mat_test.
    Example lst1 := [1;2;3].
    Example lst2 := [4;5;6].
    Example v1 : Vector 3 := l2V lst1.
    Example v2 : Vector 3 := l2V lst2.
    Example m1 : mat 3 3 := l2m [lst1;lst2].
    Compute v1.
    Compute m1 0%nat 0%nat.
    Compute m1 0%nat 2%nat.

    Compute MRow 0 m1.
    Compute MRow 1 m1.
    Compute MRow 2 m1.

    Compute MCol 0 m1.
    Compute MCol 1 m1.
    Compute MCol 2 m1.
    Compute MCol 3 m1.

    Compute V2l v1.
    Compute V2l v2.

    Compute m2l m1.

  End Cvt_List_Vec_Mat_test.

End Test_for_ModuleZ.

Module Test_for_ModuleR.

  (** Initialized matrix functor to concrete module *)
  Module MatrixR := MatrixImpl RingTypeR.
  Export MatrixR.

  Open Scope nat_scope.
  Open Scope R_scope.
  Open Scope matrix_scope.

  (** ** mat Automation *)

  Module matrix_calc_test.
    (* ref:
    https://en.wikipedia.org/wiki/Mat_(mathematics)#Basic_operations
     *)

    Definition m1 := @l2m 2 3 [[1;3;1];[1;0;0]].
    Definition m2 := @l2m 2 3 [[0;0;5];[7;5;0]].
    Definition m3 := @l2m 2 3 [[1;3;6];[8;5;0]].

    Example mplus_m1_m2_eq_m3 : m1 + m2 == m3. lma. Qed.

    Definition m4 := @l2m 2 3 [[1;8;-3];[4;-2;5]].
    Definition m5 := @l2m 2 3 [[2;16;-6];[8;-4;10]].

    Example mscale_2_m4_eq_m5 : 2 c* m4 == m5. lma. Qed.

    Definition m6 := @l2m 2 3 [[1;2;3];[0;-6;7]].
    Definition m7 := @l2m 2 3 [[1;0];[2;-6];[3;7]].
    Example mtrans_m6_eq_m7 : m6 \T == m7. lma. Qed.

    Open Scope R.
    Parameter θ ψ φ : R.
    Definition Rx (α : R) : mat 3 3 :=
      @l2m 3 3
        [[1;  0;        0      ];
         [0;  cos α;    sin α ];
         [0;  -sin α;   cos α ]].

    Definition Ry (β : R) : mat 3 3 :=
      @l2m 3 3
        [[cos β;  0;  -sin β];
         [0;      1;  0     ];
         [sin β;  0;  cos β ]].

    Definition Rz (γ : R) : mat 3 3 :=
      @l2m 3 3
        [[cos γ;    sin γ;  0];
         [-sin γ;   cos γ;  0];
         [0;        0;       1]].

    Definition R_b_e_direct : mat 3 3 :=
      @l2m 3 3 [
          [cos θ * cos ψ;
           cos ψ * sin θ * sin φ - sin ψ * cos φ;
           cos ψ * sin θ * cos φ + sin φ * sin ψ];
          [cos θ * sin ψ;
           sin ψ * sin θ * sin φ + cos ψ * cos φ;
           sin ψ * sin θ * cos φ - cos ψ * sin φ];
          [-sin θ; sin φ * cos θ; cos φ * cos θ]
        ].

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

  End matrix_calc_test.

End Test_for_ModuleR.