Require Import Arith Bool Nat List Omega Logic.
Import ListNotations.
From Block
Require Import pigeonhole lib definitions lemma2choice lemma2nochoice toregularity.

(** Jaffe's pumping condition **)
Definition jaffe_pumpable_with (k : nat) (L : language) :=
  forall (y : word),
    length y = k ->
    exists (u v w : word),
      y = u ++ v ++ w
      /\ v <> []
      /\ forall (h : nat) (z : word),
          L (u ++ napp h v ++ w ++ z) <->
          L (y ++ z).

(** Jaffe's pumping condition explicit with derivatives **)
Definition jaffe_pumpable_with_hide (k : nat) (L : language) :=
  (forall (y : word),
      length y = k ->
      exists (u v w : word),
        y = u ++ v ++ w
        /\ v <> []
        /\ forall (h : nat),
            derivative_of L (u ++ napp h v ++ w) = derivative_of L y).

Theorem jaffe_pumpable_with_equiv :
  forall (k : nat) (L : language),
    jaffe_pumpable_with k L <->
    jaffe_pumpable_with_hide k L.
Proof.
  intros k L; split; intro H;
  intros y H_length;
  spec H y H_length;
  destruct H as [u [v [w [H_split [H_neq H]]]]];
  exists u, v, w.
  - repeat split. assumption. assumption.
    intro h. spec H h.
    apply language_equality. intro w'.
    spec H w'. unfold derivative_of.
    do 2 rewrite <- app_assoc. assumption.
  - repeat split; try assumption; intro;
      spec H h; rewrite language_equality in H;
        spec H z. apply H.
    unfold derivative_of.
    do 2 rewrite <- app_assoc. assumption.
    unfold derivative_of in H.
    do 2 rewrite <- app_assoc in H. apply H.
    assumption.
Qed.

(** Proving Regular <-> Jaffe **)
(* Regular -> Jaffe *)
Theorem reg_to_jaffe :
  forall (L : language),
    regular L ->
    exists (k : nat), jaffe_pumpable_with k L.
Proof.
  intros L H_reg.
  destruct H_reg as [LD H_reg].
  exists (S (length LD)).
  (* For every S (length LD) derivatives you can always
     find a repeat. *)
  (* No prefix x this time! *)
  intros y H_length.
  assert (H_pigeon := @pigeonhole_principle language).
  (* Heavens forbid we construct the derivative list this way.
  spec H_pigeon language (map (fun x => derivative_of L x) (map (fun x => [x]) y)) LD. *)
  (* Instead the list we want is more like this: *)
  remember (deriv_list L y (iota 0 (length y))) as LD'.
  assert (about_LD'_length : length LD' = length y).
  { rewrite HeqLD'. unfold deriv_list, get_prefix_indices.
    rewrite map_length. rewrite length_iota. reflexivity. }
  (* Except we must remember to append the x on,
     because we are trailing prefixes *)
  spec H_pigeon LD' LD.
  (* Proving first pigeon obligation *)
  assert (H_pre :  (forall x : language, In x LD' -> In x LD)).
  { intros l H_mem.
    assert (H_useful := all_derivs_in_list' L LD H_reg LD' (iota 0 (length y)) y).
    assert (In L LD). apply H_reg.
    exists ([] : word). intro w; rewrite app_nil_l; reflexivity.
    spec H_useful H; clear H.
    rewrite HeqLD' in H_mem; spec H_useful l H_mem. exact H_useful. }
  spec H_pigeon H_pre; clear H_pre.
  (* Proving second pigeon obligation *)
  assert (H_pre2 : length LD < length LD').
  { rewrite HeqLD'.
    unfold deriv_list, get_prefix_indices.
    rewrite map_length, length_iota, H_length.
    omega. }
  spec H_pigeon H_pre2; clear H_pre2.
  (* Now we are in place to use pigeon *)
  (* The tactic here is inversion. *)
  inversion H_pigeon.
  destruct H as [rep_lang [H_in1 H_in2]]; clear H_pigeon.
  assert (H_in' : In rep_lang (l1 ++ l2)).
  { apply (in_or_app l1 l2 rep_lang); left; assumption. }
  rewrite H0 in H_in'.
  assert (H_eq_len : length y = length l1 + length l2).
  { rewrite <- about_LD'_length. rewrite <- H0.
    rewrite app_length. reflexivity. }
  (* Now we commence derivative label extraction. *)
  apply (In_nth _ _ (get_prefix y L 0)) in H_in1.
  apply (In_nth _ _ (get_prefix y L 0)) in H_in2.
  destruct H_in1 as [i [H_i H_nth_i]];
    destruct H_in2 as [j [H_j H_nth_j]].
  (* Re-expressing the indices in terms of the entire word *)
  assert (H_rewrite := length_nth_in l1 l2 i (get_prefix y L 0) H_i).
  rewrite <- H_rewrite in H_nth_i; clear H_rewrite.
  rewrite (nth_app_offset l1 l2 j) in H_nth_j.
  rewrite H0 in H_nth_i, H_nth_j.
  rewrite HeqLD' in H_nth_i, H_nth_j.
  unfold deriv_list, get_prefix_indices in H_nth_i, H_nth_j.
  rewrite (map_nth (get_prefix y L) (iota 0 (length y))) in H_nth_i, H_nth_j.
  unfold get_prefix in H_nth_i, H_nth_j.
  rewrite nth_iota in H_nth_i, H_nth_j.
  rewrite Nat.add_0_l in H_nth_i, H_nth_j.
  2 : omega. 2 : omega.
  (* The derivatives labels correspond to the word prefixes
     indexed by i and (j + length l1) in word y *)
  exists (firstn i y), (pumpable_block i (length l1 + j) y), (skipn (length l1 + j) y).
  split.
  (* Proving concatenation *)
  rewrite app_assoc. rewrite (left_mid y i (length l1 + j)).
  rewrite firstn_skipn. reflexivity. split. omega.
  rewrite <- about_LD'_length.
  rewrite <- H0. rewrite app_length. omega.
  (* Proving non-empty middle part *)
  split. intro absurd.
  unfold pumpable_block in absurd.
  apply firstn_nil_inversion in absurd.
  destruct absurd. omega.
  rewrite about_length_skipn in H.
  omega.
  induction h as [|h IHh]; intro z.
  - (* When we Jaffe-cancel *)
    unfold napp. rewrite app_nil_l.
    assert (H_split_y := firstn_skipn (length l1 + j) y).
    rewrite <- H_split_y at 3.
    rewrite chomp_deriv.
    rewrite <- cat_deriv. rewrite H_nth_i.
    rewrite app_assoc_reverse.
    rewrite (chomp_deriv (firstn (length l1 + j) y ++ skipn (length l1 + j) y ++ z)).
    rewrite <- (cat_deriv (firstn (length l1 + j) y)).
    rewrite plus_comm in H_nth_j;
      rewrite H_nth_j. easy.
  - (* When we Jaffe pump, *)
    simpl (* unfold napp *).
    spec IHh z.
    rewrite chomp_deriv in IHh.
    rewrite <- cat_deriv in IHh.
    rewrite H_nth_i in IHh.
    rewrite <- H_nth_j in IHh.
    rewrite cat_deriv in IHh.
    rewrite <- chomp_deriv in IHh.
    replace (firstn (j + length l1) y) with
        (firstn i y ++ (pumpable_block i (length l1 + j) y)) in IHh.
    2 : { rewrite left_mid. rewrite plus_comm.
          reflexivity. split. omega.
          rewrite H_length.
          assert (length (l1 ++ l2) = length LD').
          rewrite H0; reflexivity.
          assert (length l1 + j < length (l1 ++ l2)).
          rewrite app_length; omega.
          unfold deriv_list, get_prefix_indices, get_prefix in HeqLD'.
          rewrite app_length in H.
          omega. }
    rewrite app_assoc_reverse in IHh.
    rewrite app_assoc_reverse. exact IHh.
Qed.

(* Helper lemma for Jaffe -> Regular *)
Lemma jaffe_helper :
  forall (k : nat) (L : language),
    jaffe_pumpable_with k L ->
    forall x, exists v, length v <= k /\
              derivative_of L x = derivative_of L v.
Proof.
  intros k L H_JP x.
  remember (length x) as n.
  assert (H_move := Nat.eq_refl (length x)).
  rewrite <- Heqn in H_move at 2. clear Heqn.
  generalize dependent x.
  induction n as [|n IHn] using strong_induction';
    intros x H_x_length.
  - exists x. split. rewrite H_x_length; omega.
    reflexivity.
  - assert (length x < k \/ length x >= k) by omega.
    destruct H as [H_le | H_gt].
    exists x. split. omega. reflexivity.
    spec H_JP (firstn k x). spec H_JP.
    rewrite firstn_length_le. reflexivity. omega.
    destruct H_JP as [u [v [w [H_split [H_neq H_JP]]]]].
    spec H_JP 0.
    unfold napp in H_JP.
    assert (derivative_of L (u ++ w) = derivative_of L (firstn k x)).
    apply language_equality. intro z.
    spec H_JP z.
    rewrite app_nil_l in H_JP.
    unfold derivative_of. rewrite <- app_assoc. assumption.
    clear H_JP.
    assert (derivative_of L ((u ++ w) ++ (skipn k x)) =
            derivative_of L x).
    { rewrite <- (firstn_skipn k x) at 2.
      apply (extend_deriv_proper L (u++w)).
      assumption. }
    spec IHn (length ((u ++ w) ++ skipn k x)).
    spec IHn. rewrite app_length.
    rewrite about_length_skipn.
    rewrite H_x_length.
    assert (length (u ++ w) < k).
    { assert (length (u ++ w) < length (u ++ v ++ w)).
      repeat rewrite app_length.
      rewrite plus_assoc.
      assert (length v > 0).
      destruct v. contradiction.
      simpl; omega. omega.
      rewrite <- H_split in H1.
      rewrite firstn_length_le in H1.
      assumption. assumption. }
    omega.
    spec IHn (u++w++skipn k x).
    spec IHn. rewrite app_assoc. reflexivity.
    destruct IHn as [v' [v'_length v'_deriv]].
    exists v'. rewrite <- app_assoc in H0.
    split. assumption. rewrite <- H0. rewrite v'_deriv.
    reflexivity.
Qed.

Theorem jaffe_to_reg :
  forall (k : nat) (L : language),
    jaffe_pumpable_with k L ->
    regular L.
Proof.
  intros k L H_JP.
  rewrite jaffe_pumpable_with_equiv in H_JP.
  (* We're going to try for something *)
  exists (map (fun w => derivative_of L w) (generate_words_upto k)).
  intro l; split; intro H.
  - unfold is_deriv.
    rewrite in_map_iff in H.

destruct H as [x [x_label x_length]].
    exists x.
    apply language_equality.
    symmetry; assumption.
  - (* This is the tricky direction, proving that all derivatives of L
       are indeed in this list of derivatives with short labels *)
    rewrite in_map_iff.
    unfold is_deriv in H.
    destruct H as [x H].
    assert (length x <= k \/ length x > k) by omega.
    destruct H0 as [x_le | x_gt].
    + (* In the case that x is sufficiently short *)
      exists x. split. symmetry.
      rewrite language_equality. assumption.
      apply generate_words_upto_correct. assumption.
    + (* In the case that x is too long, we need to find an equivalent *)
      assert (H_useful := jaffe_helper k L).
      spec H_useful. rewrite jaffe_pumpable_with_equiv.
      assumption. spec H_useful x.
      destruct H_useful as [v [v_length v_eq]].
      exists v. split. apply language_equality in H.
      rewrite H. symmetry; assumption.
      rewrite generate_words_upto_correct. assumption.
Qed.
(* This uses prop_ext and functional_extensionality *)


From mathcomp
     Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype ssralg.

Require Import ZArith.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section ZtoRing.
  Lemma Zeq_boolP : Equality.axiom Zeq_bool.
  Proof.
    move => x y.
    by apply: (iffP idP); rewrite Zeq_is_eq_bool.
  Qed.

  Definition Z_eqMixin := EqMixin Zeq_boolP.

  Canonical Z_eqType := Eval hnf in EqType _ Z_eqMixin.

  Definition Z_pickle (z : Z) : nat :=
    if (0 <=? z)%Z then
      (Z.abs_nat(z)).*2
    else
      (Z.abs_nat(-z)).*2.+1.

  Definition Z_unpickle (n :nat) : option Z :=
    if (odd n) then
      Some (- (Z.of_nat n.-1./2))%Z
    else
      Some (Z.of_nat n./2).

  About pcancel.

  Lemma Z_pickleK : pcancel Z_pickle Z_unpickle.
  Proof.
    move => z; rewrite /Z_pickle.
    case: ifP => z0;
                   rewrite /Z_unpickle /= odd_double (half_bit_double _ false) Zabs2Nat.id_abs Z.abs_eq ?Z.opp_nonneg_nonpos ?Z.opp_involutive //.
    -by apply: Zle_bool_imp_le.
     +move /Z.leb_nle : z0.
        by move /Znot_le_gt /Z.gt_lt /Z.lt_le_incl.
  Qed.

End ZtoRing.


Require Export List Permutation Program.
Set Implicit Arguments.
Variable ID : Type.
Inductive LL :=
| LAtomic : ID -> LL
| LInv : ID -> LL
| LTimes : LL -> LL -> LL
| LPlus : LL -> LL -> LL
| LWith : LL -> LL -> LL
| LPar : LL -> LL -> LL
| LOne | LZero | LTrue | LFalse
| LBang : LL -> LL
| LWhyNot : LL -> LL.
Fixpoint Dual l :=
  match l with
  | LAtomic i => LInv i
  | LInv i => LAtomic i
  | LTimes l r => LPar (Dual l) (Dual r)
  | LPlus l r => LWith (Dual l) (Dual r)
  | LPar l r => LTimes (Dual l) (Dual r)
  | LWith l r => LPlus (Dual l) (Dual r)
  | LOne => LFalse
  | LZero => LTrue
  | LTrue => LZero
  | LFalse => LOne
  | LBang l' => LWhyNot (Dual l')
  | LWhyNot l' => LBang (Dual l')
  end.
Theorem DualInvolution l : Dual (Dual l) = l.
  induction l;simpl in *;repeat match goal with H : _ = _ |- _ => rewrite !H end;trivial.
Qed.
Definition LImp l r := LPar (Dual l) r.
Inductive SeqCal : list LL -> Type :=
| SEx : forall l r, Permutation l r -> SeqCal l -> SeqCal r
| SInit : forall A, SeqCal [A;Dual A]
| SCut : forall l r A, SeqCal (A :: l) -> SeqCal (Dual A :: r) -> SeqCal (l ++ r)
| STimes : forall l r A B, SeqCal (A :: l) -> SeqCal (B :: r) ->
    SeqCal (LTimes A B :: l ++ r)
| SPar : forall l A B, SeqCal (A :: B :: l) -> SeqCal (LPar A B :: l)
| SOne : SeqCal [LOne]
| SFalse : forall l, SeqCal (LFalse::l)
| SWith : forall l A B, SeqCal (A :: l) -> SeqCal (B :: l) -> SeqCal (LWith A B :: l)
| SPlusL : forall l A B, SeqCal (A :: l) -> SeqCal (LPlus A B :: l)
| SPlusR : forall l A B, SeqCal (B :: l) -> SeqCal (LPlus A B :: l)
| STrue : forall l, SeqCal (LTrue :: l)
| SWeak : forall l A, SeqCal (LWhyNot A :: l)
| SCon : forall l A, SeqCal (LWhyNot A :: LWhyNot A :: l) -> SeqCal (LWhyNot A :: l)
| SBang : forall l A, SeqCal (A :: map LWhyNot l) -> SeqCal (LBang A :: map LWhyNot l)
| SWhyNot : forall l A, SeqCal (A :: l) -> SeqCal (LWhyNot A :: l).
Hint Constructors SeqCal.
Definition LEq l r := LWith (LImp l r) (LImp r l).
Goal forall A B C, SeqCal [LEq (LTimes A (LPlus B C)) (LPlus (LTimes A B) (LTimes A C))].
  repeat (simpl;constructor).
  eapply SEx with [LWith (Dual B) (Dual C);LPlus (LTimes A B) (LTimes A C);Dual A].
  symmetry.
  eapply perm_trans.
  apply perm_swap.
  apply perm_skip.
  apply perm_swap.
  constructor;(eapply SEx;[apply perm_swap|]).
  apply SPlusL.
  admit.
  apply SPlusR.
  admit.
  eapply SEx with [LTimes A (LPlus B C);Dual A;Dual B].
  eapply perm_trans.
  apply perm_swap.
  apply perm_skip.
  apply perm_swap.
  change [Dual A;Dual B] with ([Dual A] ++ [Dual B]);auto.
  eapply SEx with [LTimes A (LPlus B C);Dual A;Dual C].
  eapply perm_trans.
  apply perm_swap.
  apply perm_skip.
  apply perm_swap.
  change [Dual A;Dual C] with ([Dual A] ++ [Dual C]);auto.
Admitted.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                              Van Chan Ngo                                *)
(*                                                                          *)
(*                        School of Computer Science                        *)
(*                        Carnegie Mellon University                        *)
(*                                                                          *)
(*                                 2017                                     *)
(*                                                                          *)
(****************************************************************************)

(* This file contains a parameterized specification of transitions systems  *)
(* with infinite states and transitions.                                    *)
(* It also contains the definitions of temporal time logic (LTL) operators  *)
(* and some safety and fairness related notions.                            *)

Section ltl.

Require Export Relations.

Set Implicit Arguments.
Unset Strict Implicit.

Variable state : Set.
Variable label : Set.
Variable init_state : state -> Prop.
Variable transition : label -> relation state.
Variable fair : label -> Prop.

(**************************** transitions  **********************************)

Inductive step (s t : state) : Prop :=
    C_trans : forall a : label, transition a s t -> step s t.

Inductive enabled (r : relation state) (s : state) : Prop :=
    c_pos_trans : forall t : state, r s t -> enabled r s.

Inductive none_or_one_step (s : state) : state -> Prop :=
  | none : none_or_one_step s s
  | one : forall t : state, step s t -> none_or_one_step s t.

(********************************** Streams *********************************)

CoInductive stream : Set :=
    cons_str : state -> stream -> stream.

Definition head_str (str : stream) : state :=
  match str with
  | cons_str s _ => s
  end.

Definition tl_str (str : stream) : stream :=
  match str with
  | cons_str _ tl => tl
  end.

Definition stream_formula := stream -> Prop.

Definition state_formula := state -> Prop.

Definition state2stream_formula (P : state_formula) : stream_formula :=
  fun str => P (head_str str).

Definition and (P Q : stream_formula) : stream_formula :=
  fun str => P str /\ Q str.

Definition and_state (P Q : state_formula) : state_formula :=
  fun s => P s /\ Q s.

Definition leads_to (P Q : state_formula) : Prop :=
  forall s t : state, P s -> step s t -> Q t.

(****************************** LTL basic operators *************************)

Definition next (P : stream_formula) : stream_formula :=
  fun str => P (tl_str str).

CoInductive always (P : stream_formula) : stream -> Prop :=
    C_always :
      forall (s0 : state) (str : stream),
      P (cons_str s0 str) -> always P str -> always P (cons_str s0 str).

Definition trace : stream -> Prop :=
  always
    (fun str : stream =>
     none_or_one_step (head_str str) (head_str (tl_str str))).

Definition run (str : stream) : Prop :=
  init_state (head_str str) /\ trace str.

Inductive eventually (P : stream_formula) : stream -> Prop :=
  | ev_h : forall str : stream, P str -> eventually P str
  | ev_t :
      forall (s : state) (str : stream),
      eventually P str -> eventually P (cons_str s str).

Inductive until (P Q : stream_formula) : stream -> Prop :=
  | until_h : forall str : stream, Q str -> until P Q str
  | until_t :
      forall (s : state) (str : stream),
      P (cons_str s str) -> until P Q str -> until P Q (cons_str s str).

CoInductive unless (P Q : stream_formula) : stream -> Prop :=
  | unless_h : forall str : stream, Q str -> unless P Q str
  | unless_t :
      forall (s : state) (str : stream),
      P (cons_str s str) -> unless P Q str -> unless P Q (cons_str s str).

(****************************** LTL derived operators ***********************)

Definition infinitely_often (P : stream_formula) :
  stream -> Prop := always (eventually P).

Definition implies (P Q : stream_formula) : stream -> Prop :=
  always (fun str : stream => P str -> Q str).

Definition is_followed (P Q : stream_formula) (str : stream) : Prop :=
  P str -> eventually Q str.

Definition is_always_followed (P Q : stream_formula) :
  stream -> Prop := always (is_followed P Q).

Definition eventually_permanently (P : stream_formula) :
  stream -> Prop := eventually (always P).

Definition once_always (P Q : stream_formula) : stream -> Prop :=
  implies P (always Q).

Definition leads_to_via (P Q R : stream_formula) :
  stream -> Prop := implies P (until Q R).

Definition once_until (P Q : stream_formula) : stream -> Prop :=
  leads_to_via P P Q.

(********************************** Fairness ********************************)

Definition fairness (a : label) (str : stream) : Prop :=
  infinitely_often (state2stream_formula (enabled (transition a))) str ->
  eventually
    (fun str : stream => transition a (head_str str) (head_str (tl_str str)))
    str.

Inductive fair_step (s1 s2 : state) : Prop :=
    c_fstep :
      forall a : label, fair a -> transition a s1 s2 -> fair_step s1 s2.

Definition fairstr : stream -> Prop :=
  infinitely_often
    (fun str =>
     enabled fair_step (head_str str) ->
     fair_step (head_str str) (head_str (tl_str str))).

Definition strong_fairstr (str : stream) : Prop :=
  always
    (eventually
       (fun str' => fair_step (head_str str') (head_str (tl_str str')))) str.

(************************************  Safety *******************************)

Definition invariant (P : state_formula) : Prop := leads_to P P.

Definition safe (P : stream_formula) : Prop :=
  forall str : stream, run str -> always P str.

End ltl.


Require Import Coq.Lists.List.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Section foldable.
  Variable T A : Type.

  Class Foldable : Type :=
  { fold_mon : forall m {M : Monoid m}, (A -> m) -> T -> m }.

  Variable Foldable_T : Foldable.

  Definition fold (R : Type) (f : A -> R -> R) (init : R) (s : T) : R :=
    @fold_mon Foldable_T (R -> R)
              {| monoid_plus := fun f g x => f (g x)
               ; monoid_unit := fun x => x
               |} f s init.

  Definition toList : T -> list A :=
    fold_mon (M := {| monoid_plus := @List.app A
                    ; monoid_unit := nil |}) (fun x => x :: nil).

  Variable Add : A -> T -> T -> Prop.

  Class FoldableOk : Type :=
  { fold_ind : forall m (M : Monoid m) (t : type m) (ML : MonoidLaws M) (P : m -> Prop) f u,
                 P (monoid_unit M) ->
                 (forall x y z,
                    Add x y z ->
                    P (@fold_mon Foldable_T m M f y) ->
                    P (monoid_plus M (f x) (@fold_mon Foldable_T m M f z))) ->
                 P (@fold_mon Foldable_T m M f u)
  }.

End foldable.


(* Definition of the relation of Perm_R and basic properties. *)

From Coq Require Import CMorphisms Bool PeanoNat Lia.
From OLlibs Require Import List_more Permutation_Type.
Require Import List_nat Fun_nat Transposition length_lia Perm.

Set Implicit Arguments.

Definition Perm_R {A} (l1 l2 : list A) : Type :=
  { p & is_perm p = true & prod (length p = length l1) (l2 = app_nat_fun p l1) }.

Infix "~~" := Perm_R (at level 70).

Definition Perm_R_to_perm {A} {l1 l2 : list A} : Perm_R l1 l2 -> perm := @sigT_of_sigT2 _ _ _.
Definition Perm_R_to_perm_of {A} {l1 l2 : list A} : Perm_R l1 l2 -> perm_of (length l1) := fun P =>
  existT2 _ _ (projT1 (sigT_of_sigT2 P)) (projT2 (sigT_of_sigT2 P)) (fst (projT3 P)).
Definition Perm_R_of_perm_of {A} {l : list A} (p : perm_of (length l)) : l ~~ projT1 (sigT_of_sigT2 p) ∘ l :=
  let (p0,Hp,Hl) as s return (l ~~ projT1 (sigT_of_sigT2 s) ∘ l) := p in existT2 _ _ p0 Hp (Hl, eq_refl).

(* Permutation over lists is an equivalence relation *)

Lemma Perm_R_refl {A} : forall (l : list A), l ~~ l.
Proof.
  intro l; split with (Id (length l)); repeat split.
  - apply Id_is_perm.
  - apply seq_length.
  - symmetry; apply app_Id.
Defined.

Lemma Perm_R_trans {A} : forall (l1 l2 l3 : list A), l1 ~~ l2 -> l2 ~~ l3 -> l1 ~~ l3.
Proof.
  intros l1 l2 l3 [p1 Hperm1 [Hlen1 IHHp1]] [p2 Hperm2 [Hlen2 IHHp2]].
  assert (length p2 = length p1) by (now rewrite Hlen2, IHHp1; apply app_nat_fun_length).
  split with (app_nat_fun p2 p1); repeat split.
  - now apply compo_perm_is_perm.
  - destruct p1.
    + now destruct l1.
    + rewrite app_nat_fun_length_cons; [ lia | intros Heq; inversion Heq ].
  - rewrite asso_app_nat_fun.
    now rewrite<- IHHp1.
Defined.

Lemma Perm_R_sym {A} : forall (l1 l2 : list A), l1 ~~ l2 -> l2 ~~ l1.
Proof.
  intros l1 l2 [p Hperm [Hlen Heq]].
  destruct (perm_inv p Hperm) as [p_inv [Heq_inv _ ] [Hperm_inv Hlen_eq]].
  split with p_inv; repeat split; [ assumption | | ].
  - rewrite Heq, <- Hlen_eq.
    now symmetry; apply app_nat_fun_length.
  - rewrite Heq, <- asso_app_nat_fun, Heq_inv, Hlen.
    symmetry; apply app_Id.
Defined.

#[global]
Instance Perm_R_Equivalence A : Equivalence (@Perm_R A) | 10 := {
  Equivalence_Reflexive := @Perm_R_refl A ;
  Equivalence_Symmetric := @Perm_R_sym A ;
  Equivalence_Transitive := @Perm_R_trans A }.

(* Some facts about Perm_R *)

Section Perm_R_properties.

Context {A : Type}.

Implicit Types a b : A.
Implicit Types l m : list A.

Lemma Perm_R_nil : forall l, nil ~~ l -> l = nil.
Proof. intros l Hperm; destruct Hperm as [f Hp [Hlen Heq]]; now rewrite Heq. Qed.

Lemma Perm_R_nil_cons : forall l a, nil ~~ (a :: l) -> False.
Proof. intros l a Hp; apply Perm_R_nil in Hp; inversion Hp. Qed.

Theorem Perm_R_app : forall l m l' m', l ~~ l' -> m ~~ m' -> l ++ m ~~ l' ++ m'.
Proof.
intros l m l' m' [p Hperm [Hlen Heq]] [p' Hperm' [Hlen' Heq']].
split with (p +++ p'); repeat split; subst.
- now apply append_perm_is_perm.
- length_lia.
- apply andb_prop in Hperm as [Hal _].
  apply andb_prop in Hperm' as [Hal' _]; rewrite Hlen' in Hal'.
  now symmetry; apply pappend_fun_eq.
Defined.

#[global]
Instance Perm_R_app' : Proper (@Perm_R A ==> @Perm_R A ==> @Perm_R A) (@app A) | 10.
Proof. repeat intro; now apply Perm_R_app. Defined.

Lemma Perm_R_app_tail : forall l l' tl, l ~~ l' -> l ++ tl ~~ l' ++ tl.
Proof. intros; now apply Perm_R_app. Defined.

Lemma Perm_R_app_head : forall l tl tl', tl ~~ tl' -> l ++ tl ~~ l ++ tl'.
Proof. intros; now apply Perm_R_app. Defined.

Lemma Perm_R_skip : forall l l' a, l ~~ l' -> a :: l ~~ a :: l'.
Proof.
intros l l' a HP.
change (a :: l) with ((a :: nil) ++ l).
change (a :: l') with ((a :: nil) ++ l').
now apply Perm_R_app_head.
Defined.

#[local]
Instance Perm_R_cons : Proper (Logic.eq ==> @Perm_R A ==> @Perm_R A) (@cons A) | 10.
Proof. repeat intro; subst; now apply Perm_R_skip. Defined.

Lemma Perm_R_swap : forall l a b, a :: b :: l ~~ b :: a :: l.
Proof.
intros l a b.
change (a :: b :: l) with ((a :: b :: nil) ++ l).
change (b :: a :: l) with ((b :: a :: nil) ++ l).
apply Perm_R_app_tail.
now exists (1 :: 0 :: nil); repeat split.
Defined.

(* Compatibility with others operations on lists *)

Lemma Perm_R_length : forall l m, l ~~ m -> length l = length m.
Proof. intros l m [f Hp [Hlen Heq]]; subst; now rewrite app_nat_fun_length. Qed.

#[global]
Instance Perm_R_length' : Proper (@Perm_R A ==> Logic.eq) (@length A) | 10.
Proof. exact Perm_R_length. Qed.

Lemma Perm_R_add_inside : forall a l l' tl tl', l ~~ l' -> tl ~~ tl' -> l ++ a :: tl ~~ l' ++ a :: tl'.
Proof. intros; now apply Perm_R_app; [ | apply Perm_R_skip ]. Defined.

Theorem Perm_R_app_comm : forall l l', l ++ l' ~~ l' ++ l.
Proof.
intros l l'.
split with (cfun (length l) (length l')); repeat split.
- apply cfun_is_perm.
- length_lia.
- symmetry; apply app_cfun_eq.
Defined.

Lemma Perm_R_cons_append : forall l a, a :: l ~~ l ++ a :: nil.
Proof. intros l a; change (a :: l) with ((a :: nil) ++ l); apply Perm_R_app_comm. Defined.

Theorem Perm_R_middle : forall l1 l2 a, a :: l1 ++ l2 ~~ l1 ++ a :: l2.
Proof. intros; now rewrite Perm_R_app_comm, app_comm_cons, Perm_R_app_comm. Defined.

Theorem Perm_R_cons_app : forall l l1 l2 a, l ~~ l1 ++ l2 -> a :: l ~~ l1 ++ a :: l2.
Proof. intros l l1 l2 a Hperm; rewrite Hperm; apply Perm_R_middle. Defined.

Lemma Perm_R_Add_Type a l l' : Add_inf a l l' -> a :: l ~~ l'.
Proof. intros Hadd; induction Hadd; [ reflexivity | rewrite <- IHHadd; apply Perm_R_swap ]. Defined.

Theorem Perm_R_rev : forall l, l ~~ rev l.
Proof. induction l; [ reflexivity | simpl; rewrite <- IHl; apply Perm_R_cons_append ]. Defined.

#[global]
Instance Perm_R_rev' : Proper (@Perm_R A ==> @Perm_R A) (@rev A) | 10.
Proof. repeat intro; now rewrite <- 2 Perm_R_rev. Defined.

Theorem Perm_R_nil_app_cons : forall l m a, nil ~~ l ++ a :: m -> False.
Proof. intros l l' a Hperm; rewrite <- Perm_R_middle in Hperm; apply (Perm_R_nil_cons Hperm). Qed.

Theorem Perm_R_cons_inv l l' a : a :: l ~~ a :: l' -> l ~~ l'.
Proof.
intros [[|n p] Hperm [Hlen Heq]]; [ inversion Heq | ].
destruct (andb_prop _ _ Hperm) as [Hal Had].
simpl in Hal; apply andb_prop in Hal as [_ Hal].
simpl in Had; apply andb_prop in Had as [Had%negb_true_iff _].
destruct (app_nat_fun_vs_cons _ _ _ _ _ Hlen Hperm Heq) as [(la,lb) Heql Hlenla]; subst.
assert (S (length p) = S (length (la ++ lb))) as Hlenp by (rewrite Heql in Hlen; length_lia).
apply downshift_perm with _ (length la) in Hperm; simpl in Hperm; rewrite Nat.eqb_refl in Hperm.
injection Heq; intros Heq'' _; subst; fold (app_nat_fun p (a :: l)) in *.
rewrite Heql, app_nat_fun_downshift.
- transitivity (la ++ lb).
  + destruct la; inversion Heql; subst; [ reflexivity | ].
    symmetry; apply Perm_R_middle.
  + exists (downshift p (length la)); repeat split; [ assumption | ].
    rewrite downshift_length by assumption; lia.
- assumption.
- now rewrite <- Hlenp.
Defined.

Theorem Perm_R_Add_Type_inv a l1 l2 : Perm_R l1 l2 ->
  forall l1' l2', Add_inf a l1' l1 -> Add_inf a l2' l2 -> l1' ~~ l2'.
Proof.
intros Hperm l1' l2' Hadd1 Hadd2.
apply Perm_R_cons_inv with a.
transitivity l1; [ now apply Perm_R_Add_Type | ].
transitivity l2; [ apply Hperm | now symmetry; apply Perm_R_Add_Type ].
Defined.

Theorem Perm_R_app_inv l1 l2 l3 l4 a : l1 ++ a :: l2 ~~ l3 ++ a :: l4 -> l1 ++ l2 ~~l3 ++ l4.
Proof. intros; apply Perm_R_cons_inv with a; now rewrite 2 Perm_R_middle. Defined.

Theorem Perm_R_cons_app_inv l l1 l2 a : a :: l ~~ l1 ++ a :: l2 -> l ~~ l1 ++ l2.
Proof. intros Hperm; rewrite <- (app_nil_l l); now apply Perm_R_app_inv with a. Defined.

Theorem Perm_R_app_inv_l : forall l l1 l2, l ++ l1 ~~ l ++ l2 -> l1 ~~ l2.
Proof. now induction l; intros l1 l2 Hperm; [ | apply IHl; apply Perm_R_cons_inv with a]. Defined.

Theorem Perm_R_app_inv_r l l1 l2 : l1 ++ l ~~ l2 ++ l -> l1 ~~ l2.
Proof. intros Hperm; rewrite 2 (Perm_R_app_comm _ l) in Hperm; apply (Perm_R_app_inv_l _ _ _ Hperm). Defined.

Lemma Perm_R_length_1_inv: forall a l, a :: nil ~~ l -> l = a :: nil.
Proof.
intros a l [p Hperm [Hlen Heq]].
destruct p; try now inversion Hlen.
destruct p; try now inversion Hlen.
rewrite Heq; simpl.
now destruct n.
Qed.

Lemma Perm_R_length_1: forall a b, a :: nil ~~ b :: nil -> a = b.
Proof. intros a b Hperm; apply Perm_R_length_1_inv in Hperm; now inversion Hperm. Qed.

Lemma Perm_R_length_2_inv : forall a1 a2 l,
  a1 :: a2 :: nil ~~ l -> { l = a1 :: a2 :: nil } + { l = a2 :: a1 :: nil }.
Proof.
intros a1 a2 l [p Hperm [Hlen Heq]].
do 3 (destruct p; try now inversion Hlen).
now apply is_perm_length_2_inv in Hperm as [[Hp1 Hp2] | [Hp1 Hp2]]; subst; simpl; [left | right].
Defined.

Lemma Perm_R_length_2 : forall a1 a2 b1 b2,
  a1 :: a2 :: nil ~~ b1 :: b2 :: nil -> { a1 = b1 /\ a2 = b2 } + { a1 = b2 /\ a2 = b1 }.
Proof.
intros a1 a2 b1 b2 Hperm.
now destruct (Perm_R_length_2_inv Hperm) as [Heq | Heq]; inversion Heq; subst; [left | right].
Defined.

Theorem Perm_R_in : forall l m a, l ~~ m -> In a l -> In a m.
Proof.
intros l m a [p Hperm [Hlen Heq]] Hin.
apply In_nth with _ _ _ a in Hin as [n (Hlen' & Heq')].
rewrite <- Heq', Heq; clear Heq'.
destruct l; try now inversion Hlen'.
replace (nth n (a0 :: l) a) with (nth n (a0 :: l) a0) by (apply nth_indep; assumption).
destruct (perm_surj _ 0 n Hperm) as [i Hlen'' Heq'']; [ lia | ]; subst.
rewrite nth_nth_nth_map; [ | left; assumption ].
apply nth_In.
now  rewrite app_nat_fun_length_cons.
Qed.

#[global]
Instance Perm_R_in' : Proper (Logic.eq ==> @Perm_R A ==> iff) (@In A) | 10.
Proof. repeat intro; subst; split; now apply Perm_R_in. Qed.

Theorem Perm_R_in_Type : forall l m a, l ~~ m -> In_inf a l -> In_inf a m.
Proof.
intros l m a [p Hperm [Hlen Heq]] Hin.
apply In_inf_nth with (d := a) in Hin as [n Hlen' Heq'].
rewrite <- Heq', Heq; clear Heq'.
destruct l; try now simpl in Hlen'; exfalso; lia.
replace (nth n (a0 :: l) a) with (nth n (a0 :: l) a0) by (apply nth_indep; assumption).
destruct (perm_surj _ 0 n Hperm) as [i Hlen'' Heq'']; [ lia | ]; subst.
rewrite nth_nth_nth_map; [ | left; assumption ].
apply nth_In_inf.
now  rewrite app_nat_fun_length_cons.
Qed.

#[global]
Instance Perm_R_in_Type' : Proper (Logic.eq ==> @Perm_R A ==> Basics.arrow) (@In_inf A) | 10.
Proof. repeat intro; subst; eapply Perm_R_in_Type; eassumption. Qed.

Lemma Perm_R_concat : forall p (L : list (list A)), length p = length L -> is_perm p = true ->
  Perm_R (concat L) (concat (p ∘ L)).
Proof.
intros p L Hlen Hperm.
destruct (perm_block p L (p ∘ L) Hlen Hperm eq_refl) as [q Hpermq [Hlenq Hcomp]].
rewrite <- Hcomp.
now exists q.
Defined.

End Perm_R_properties.

Section Perm_R_map.

Variable A B : Type.
Variable f : A -> B.

Lemma Perm_R_map l l' : l ~~ l' -> map f l ~~ map f l'.
Proof.
  intros [p Hperm [Hlen Heq]].
  split with p; repeat split; [ assumption | | ].
  - now rewrite map_length.
  - now rewrite app_nat_fun_map, Heq.
Defined.

#[global]
Instance Perm_R_map' : Proper (@Perm_R A ==> @Perm_R B) (map f) | 10.
Proof. exact Perm_R_map. Defined.

End Perm_R_map.

(* INDUCTION PRINCIPLE *)
Theorem Perm_R_rect_transpo {A} :
 forall P : list A -> list A -> Type,
   P nil nil ->
   (forall x l l', l ~~ l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l, P (y :: x :: l) (x :: y :: l)) ->
   (forall l l' l'', l ~~ l' -> P l l' -> l' ~~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~~ l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  intros l l' Hperm.
  destruct Hperm as [p Hperm [Hlen Heq]].
  simpl in Hlen.
  rewrite Heq.
  apply (Perm_rect (fun f => fun l => is_perm f = true -> P l (app_nat_fun f l))); try assumption.
  - clear l l' p Hperm Hlen Heq.
    intros l Hperm.
    rewrite app_Id.
    clear Hperm.
    induction l; [ assumption | ].
    apply Hskip; [ reflexivity | assumption ].
  - clear l l' p Hperm Hlen Heq.
    intros l0 i Hnnil Hperm.
    clear Hperm.
    revert l0 Hnnil.
    induction i; intros l0 Hnnil.
    + unfold transpo.
      destruct l0; try now (exfalso; apply Hnnil).
      destruct l0.
      * simpl.
        apply Hskip; [ reflexivity | assumption ].
      * replace (0 <? (length (a :: a0 :: l0)) - 1) with true by reflexivity.
        simpl.
        replace (app_nat_fun_dflt (seq 2 (length l0 - 0)) (a :: a0 :: l0) a)
           with l0; [apply Hswap | ].
        rewrite Nat.sub_0_r.
        change (app_nat_fun_dflt (seq 2 (length l0)) (a :: a0 :: l0) a)
          with (app_nat_fun (seq 2 (length l0)) ((a :: a0 :: nil) ++ l0)).
        replace 2 with (0 + 2) by lia.
        rewrite <- incr_all_seq.
        rewrite app_nat_fun_right; [rewrite app_Id | | apply all_lt_seq ]; reflexivity.
    + destruct l0; try now (exfalso; apply Hnnil).
      assert (forall n i, transpo (S n) (S i) = 0 :: incr_all (transpo n i) 1) as transpo_S.
      { clear.
        intros n i.
        unfold transpo.
        case_eq (i <? n); intros Hcase.
        - replace (S i <? S n) with true.
          rewrite shift_app.
          simpl.
          rewrite ? incr_all_seq.
          replace (S (S i) + 1) with (S (S (S i))) by lia; reflexivity.
        - replace (S i <? S n) with false.
          rewrite ? incr_all_seq; reflexivity. }
      destruct l0.
      * simpl.
        apply Hskip; [ reflexivity | assumption ].
      * replace (length (a :: a0 :: l0) - 1) with (S (length (a0 :: l0) - 1)) by length_lia.
        rewrite transpo_S.
        app_nat_fun_unfold (shift (transpo (length (a0 :: l0) - 1) i) 0 1) (a0 :: l0) 0 a.
        change 1 with (length (a :: nil)) at 2.
        change (a :: a0 :: l0) with ((a :: nil) ++ a0 :: l0) at 3.
        rewrite app_nat_fun_right; [ | reflexivity | ].
        2:{ replace (length (a0 :: l0)) with (S (length (a0 :: l0) - 1)) at 2 by length_lia.
            apply all_lt_transpo. }
        apply Hskip.
        -- split with (transpo (length (a0 :: l0) - 1) i); repeat split.
           ++ apply transpo_is_perm.
           ++ length_lia.
        -- apply IHi.
           intros H; inversion H.
  - clear l l' p Hperm Hlen Heq.
    intros f1 f2 l Hperm1 Hperm2 Hlen1 Hlen2 IH1 IH2 _.
    specialize (IH1 Hperm1); specialize (IH2 Hperm2).
    apply Htrans with (app_nat_fun f1 l).
    + split with f1; repeat split; [ | symmetry ]; assumption.
    + assumption.
    + split with f2; repeat split.
      * assumption.
      * rewrite Hlen2.
        destruct l; [destruct f1; try now inversion Hlen1 | ].
        rewrite app_nat_fun_length_cons; [ reflexivity | ].
        intro H; inversion H.
      * apply asso_app_nat_fun.
    + rewrite asso_app_nat_fun; assumption.
Qed.

Ltac rect_transpo P Hperm :=
  let x := fresh "x" in
  let y := fresh "y" in
  let la := fresh "la" in
  let lb := fresh "lb" in
  let lc := fresh "lc" in
  let Hperm1 := fresh "Hperm1" in
  let IHHperm1 := fresh "IHHperm1" in
  let Hperm2 := fresh "Hperm2" in
  let IHHperm2 := fresh "IHHperm2" in
  refine (Perm_R_rect_transpo P  _ _ _ _ Hperm); clear Hperm;
    [ | intros x la lb Hperm1 IHHperm1 | intros x y la | intros la lb lc Hperm1 IHHperm1 Hperm2 IHHperm2].

Theorem Perm_R_ind_transpo {A} :
 forall P : list A -> list A -> Prop,
   P nil nil ->
   (forall x l l', l ~~ l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l, P (y :: x :: l) (x :: y :: l)) ->
   (forall l l' l'', l ~~ l' -> P l l' -> l' ~~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~~ l' -> P l l'.
Proof. intros; now apply Perm_R_rect_transpo. Qed.

Ltac ind_transpo P Hperm :=
  let x := fresh "x" in
  let y := fresh "y" in
  let la := fresh "la" in
  let lb := fresh "lb" in
  let lc := fresh "lc" in
  let Hperm1 := fresh "Hperm1" in
  let IHHperm1 := fresh "IHHperm1" in
  let Hperm2 := fresh "Hperm2" in
  let IHHperm2 := fresh "IHHperm2" in
  refine (Perm_R_rect_transpo P  _ _ _ _ Hperm); clear Hperm;
  [ | intros x la lb Hperm1 IHHperm1 | intros x y la | intros la lb lc Hperm1 IHHperm1 Hperm2 IHHperm2].

Theorem Perm_R_rect_transpo_bis {A} :
 forall P : list A -> list A -> Type,
   P nil nil ->
   (forall x l l', l ~~ l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', l ~~ l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', l ~~ l' -> P l l' -> l' ~~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~~ l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  assert (forall l, P l l) as Hrefl by (now induction l; [ | apply Hskip; [ reflexivity | ] ]).
  apply Perm_R_rect_transpo; try assumption.
  now intros x y l; apply Hswap.
Qed.

Theorem Perm_R_ind_transpo_bis {A} :
 forall P : list A -> list A -> Prop,
   P nil nil ->
   (forall x l l', l ~~ l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', l ~~ l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', l ~~ l' -> P l l' -> l' ~~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~~ l' -> P l l'.
Proof. intros; now apply Perm_R_rect_transpo_bis. Qed.

Ltac ind_transpo_bis P Hperm :=
  let x := fresh "x" in
  let y := fresh "y" in
  let la := fresh "la" in
  let lb := fresh "lb" in
  let lc := fresh "lc" in
  let Hperm1 := fresh "Hperm1" in
  let IHHperm1 := fresh "IHHperm1" in
  let Hperm2 := fresh "Hperm2" in
  let IHHperm2 := fresh "IHHperm2" in
  refine (Perm_R_ind_transpo_bis P  _ _ _ _ Hperm); clear Hperm;
  [ | intros x la lb Hperm1 IHHperm1 | intros x y la | intros la lb lc Hperm1 IHHperm1 Hperm2 IHHperm2].

Ltac rect_transpo_bis P Hperm :=
  let x := fresh "x" in
  let y := fresh "y" in
  let la := fresh "la" in
  let lb := fresh "lb" in
  let lc := fresh "lc" in
  let Hperm1 := fresh "Hperm1" in
  let IHHperm1 := fresh "IHHperm1" in
  let Hperm2 := fresh "Hperm2" in
  let IHHperm2 := fresh "IHHperm2" in
  refine (Perm_R_rect_transpo_bis P _ _ _ _ Hperm); clear Hperm;
  [ | intros x la lb Hperm1 IHHperm1
    | intros x y la
    | intros la lb lc Hperm1 IHHperm1 Hperm2 IHHperm2].

(* Permutation_Type = Perm_R *)

Lemma Permutation_Type_to_Perm_R {A} : forall (l1 l2 : list A),
  Permutation_Type l1 l2 -> l1 ~~ l2.
Proof.
intros l1 l2 Hp; induction Hp.
- now split with (Id 0); repeat split.
- now apply Perm_R_skip.
- now apply Perm_R_swap.
- now apply Perm_R_trans with l'.
Defined.

Lemma Perm_R_to_Permutation_Type {A} : forall (l1 l2 : list A),
  l1 ~~ l2 -> Permutation_Type l1 l2.
Proof.
intros l1 l2 Hperm.
apply Perm_R_rect_transpo; (try now (intros; constructor)); [ | assumption ].
clear; intros l l' l'' _ Hperm1 _ Hperm2.
now transitivity l'.
Qed.

(* Canonicity *)

Lemma Perm_R_eq_as_perm {A} (HdecA : forall x y : A, {x = y} + {x <> y}) :
  forall (l1 l2 : list A) (HP1 HP2: Perm_R l1 l2),
    projT1 (sigT_of_sigT2 HP1) = projT1 (sigT_of_sigT2 HP2) -> HP1 = HP2.
Proof.
intros l1 l2 [p1 Hp1 [Heql1 Heqp1]] [p2 Hp2 [Heql2 Heqp2]] Heq; simpl in Heq; subst; repeat f_equal.
- apply (Eqdep_dec.UIP_dec bool_dec).
- apply UIP_nat.
- now apply Eqdep_dec.UIP_dec, list_eq_dec.
Qed.


Require Import Iron.Data.List.Base.

(* Check if any element in a list matches the given predicate. *)
Fixpoint elem {A} (p : A -> bool) (xx : list A)
 := match xx with
    | nil      => false
    | x :: xs  => if p x then true else elem p xs
    end.

Lemma elem_get_not
 :  forall {A} (p : A -> bool) (xx : list A)
 ,  not (exists ix x, get ix xx = Some x /\ p x = true)
 -> elem p xx = false.
Proof.
 intros.
 induction xx.
 - simpl. auto.
 - remember (p a) as X.
   destruct X.
   + simpl.
     rewrite <- HeqX.
     assert (exists ix x, get ix (xx :> a) = Some x /\ p x = true).
      exists 0. exists a. intuition.
     tauto.

   + simpl.
     rewrite <- HeqX.
     eapply IHxx.
     unfold not.
     intros.
     destruct H0 as [ix].
     destruct H0 as [x].
     inversion H0.
     assert (get (S ix) (xx :> a) = Some x).
      simpl. auto.
     assert (exists ix x, get ix (xx :> a) = Some x /\ p x = true).
      exists (S ix). exists x. auto.
     tauto.
Qed.


Set Implicit Arguments.
Require Import Dblib.DblibTactics.
Require Import Dblib.DeBruijn.

(* Application to values & terms. *)

Inductive my_term :=
  | MyTValue: my_value -> my_term
  | MyTApp: my_term -> my_term -> my_term

with my_value :=
  | MyVVar: nat -> my_value
  | MyVAbs: my_term -> my_value.

Instance Var_my_value : Var my_value := {
  var := MyVVar
}.

Fixpoint traverse_my_term (f : nat -> nat -> my_value) l t :=
  match t with
  | MyTValue v =>
      MyTValue (traverse_my_value f l v)
  | MyTApp t1 t2 =>
      MyTApp (traverse_my_term f l t1) (traverse_my_term f l t2)
  end

with traverse_my_value f l v :=
  match v with
  | MyVVar x =>
      f l x
  | MyVAbs t =>
      MyVAbs (traverse_my_term f (1 + l) t)
  end.

Instance Traverse_my_value_my_value : Traverse my_value my_value := {
  traverse := traverse_my_value
}.

Instance Traverse_my_value_my_term : Traverse my_value my_term := {
  traverse := traverse_my_term
}.

(* TEMPORARY It is unfortunate that we have to first prove two
   mutually dependent lemmas using [Lemma ... with ...], then write
   down two independent [Instance] declarations. I would prefer to be
   able to directly write two mutually depdendent instance
   declarations, using [Instance ... with ...]. Here, I am forced to
   duplicate the statement of the properties of interest, which is
   unpleasant. *)

Lemma traverse_my_value_injective:
  forall f,
  (forall x1 x2 l, f l x1 = f l x2 -> x1 = x2) ->
  forall (t1 t2 : my_value) l,
  traverse_var f l t1 = traverse_var f l t2 ->
  t1 = t2

with traverse_my_term_injective:
  forall f,
  (forall x1 x2 l, f l x1 = f l x2 -> x1 = x2) ->
  forall (t1 t2 : my_term) l,
  traverse_var f l t1 = traverse_var f l t2 ->
  t1 = t2.
Proof.
  prove_traverse_var_injective.
  prove_traverse_var_injective.
Qed.

Instance TraverseVarInjective_my_value_my_value :
  @TraverseVarInjective my_value _ my_value _.
Proof.
  constructor. apply traverse_my_value_injective.
Qed.

Instance TraverseVarInjective_my_value_my_term :
  @TraverseVarInjective my_value _ my_term _.
Proof.
  constructor. apply traverse_my_term_injective.
Qed.

Lemma traverse_functorial_value_value:
  forall f g (t : my_value) l,
  traverse g l (traverse f l t) = traverse (fun l x => traverse g l (f l x)) l t

with traverse_functorial_value_term:
  forall f g (t : my_term) l,
  traverse g l (traverse f l t) = traverse (fun l x => traverse g l (f l x)) l t.
Proof.
  prove_traverse_functorial.
  prove_traverse_functorial.
Qed.

Instance TraverseFunctorial_my_value_my_value : @TraverseFunctorial my_value _ my_value _.
Proof. constructor. apply traverse_functorial_value_value. Qed.

Instance TraverseFunctorial_my_term_my_term : @TraverseFunctorial my_value _ my_term _.
Proof. constructor. apply traverse_functorial_value_term. Qed.

Instance TraverseIdentifiesVar_my_value : TraverseIdentifiesVar.
Proof. constructor. prove_traverse_identifies_var. Qed.

Lemma traverse_relative_my_value_my_value:
  forall f g p (t : my_value) m l,
  (forall l x, f (l + p) x = g l x) ->
  m = l + p ->
  traverse f m t =
  traverse g l t

with traverse_relative_my_value_my_term:
  forall f g p (t : my_term) m l,
  (forall l x, f (l + p) x = g l x) ->
  m = l + p ->
  traverse f m t =
  traverse g l t.
Proof.
  prove_traverse_relative.
  prove_traverse_relative.
Qed.

Instance TraverseRelative_my_value_my_value : @TraverseRelative my_value my_value _.
Proof.
  constructor. apply traverse_relative_my_value_my_value.
Qed.

Instance TraverseRelative_my_value_my_term : @TraverseRelative my_value my_term _.
Proof.
  constructor. apply traverse_relative_my_value_my_term.
Qed.

Lemma traverse_my_value_var_is_identity:
  forall f,
  (forall l x, f l x = var x) ->
  forall (t : my_value) l,
  traverse f l t = t

with traverse_my_term_var_is_identity:
  forall f,
  (forall l x, f l x = var x) ->
  forall (t : my_term) l,
  traverse f l t = t.
Proof.
  prove_traverse_var_is_identity.
  prove_traverse_var_is_identity.
Qed.

Instance TraverseVarIsIdentity_my_value_my_value : @TraverseVarIsIdentity my_value _ my_value _.
Proof.
  constructor. apply traverse_my_value_var_is_identity.
Qed.

Instance TraverseVarIsIdentity_my_value_my_term : @TraverseVarIsIdentity my_value _ my_term _.
Proof.
  constructor. apply traverse_my_term_var_is_identity.
Qed.

Lemma lift_MyVAbs:
  forall w k t,
  lift w k (MyVAbs t) = MyVAbs (lift w (1 + k) t).
Proof.
  intros. simpl_lift_goal. reflexivity.
Qed.

Lemma subst_MyVAbs:
  forall v k t,
  subst v k (MyVAbs t) = MyVAbs (subst (shift 0 v) (1 + k) t).
Proof.
  intros. simpl_subst_goal. reflexivity.
Qed.


Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Open Scope char_scope.
Import ListNotations.
Require Import Turing.Util.
Require Import Turing.Lang.

(* Length: *)
Goal length ["c"; "a"; "r"] = 3.
Proof. reflexivity. Qed.

(* Concatenation *)
Goal ["c"] ++ ["a"; "r"] = ["c"; "a"; "r"].
Proof. reflexivity. Qed.

(* Power *)
Goal pow ["c"; "a"; "r"] 3 = ["c"; "a"; "r"; "c"; "a"; "r"; "c"; "a"; "r"].
  Proof. reflexivity. Qed.

Goal pow ["c"; "a"; "r"] 1 = ["c"; "a"; "r"]. Proof. reflexivity. Qed.
Goal pow ["c"; "a"; "r"] 0 = []. Proof. reflexivity. Qed.

Definition L1 (w:word) := w = ["c"; "a"; "r"].

Goal
   In ["c"; "a"; "r"] L1.
Proof.
  unfold L1.
  unfold In.
  reflexivity.
Qed.

Goal
   ~ In [] L1.
Proof.
  unfold In, L1.
  intros N.
  inversion N.
Qed.

Lemma l1_inv:
  forall w,
  In w L1 ->
  w = ["c"; "a"; "r"].
Proof.
  unfold In, L1.
  intros.
  assumption.
Qed.

Definition L2 w := Char "a" w
  \/ Char "e" w
  \/ Char "i" w
  \/ Char "o" w
  \/ Char "u" w.

Goal In ["i"] L2.
Proof.
  unfold In, L2.
  unfold Char.
  right.
  right.
  left.
  reflexivity.
Qed.

Lemma aa_not_in_vowel: ~ In ["a"; "a"] L2.
Proof.
  unfold In, L2.
  intros N.
  destruct N as [N|[N|[N|[N|N]]]]; inversion N.
Qed.

Goal In [] Nil.
Proof.
  reflexivity.
Qed.
(*
Coercion Char: ascii >-> language.
*)
Import LangNotations.

Print Union.
Infix "U" := Union.

Goal
  forall (w:word),
  In w L1 ->
  In w (L1 U L2).
Proof.
  unfold In.
  intros.
  unfold Union.
  left.
  assumption.
Qed.

Definition App L1 L2 w :=
  exists w1 w2,
  In w1 L1 /\
  In w2 L2 /\
  w = w1 ++ w2.

Definition L1' := App (Char "c")
                      (App (Char "a")
                           (Char "r")).

Goal
  In ["c"; "a"; "r"] L1'.
Proof.
  intros.
Qed.


Require Import vcfloat.VCFloat.
Require Import floatlib.
Require Import Coq.Lists.List. Import ListNotations.
Set Bullet Behavior "Strict Subproofs".
Require Import fma_floating_point_model.

Section WITH_NANS.

Context {NANS: Nans}.

Definition diagmatrix t := list (ftype t).

Definition invert_diagmatrix {t} (v: diagmatrix t) : diagmatrix t :=
   map (BDIV (Zconst t 1)) v.

Definition diagmatrix_vector_mult {t}: diagmatrix t -> vector t -> vector t :=
  map2 BMULT.

Definition diagmatrix_matrix_mult {t} (v: diagmatrix t) (m: matrix t) : matrix t :=
  map2 (fun d => map (BMULT d)) v m.

Definition diag_of_matrix {t: type} (m: matrix t) : diagmatrix t :=
  map (fun i => matrix_index m i i) (seq 0 (matrix_rows_nat m)).

Definition remove_diag {t} (m: matrix t) : matrix t :=
 matrix_by_index (matrix_rows_nat m) (matrix_rows_nat m)
  (fun i j => if Nat.eq_dec i j then Zconst t 0 else matrix_index m i j).

Definition matrix_of_diag {t} (d: diagmatrix t) : matrix t :=
 matrix_by_index (length d) (length d)
  (fun i j => if Nat.eq_dec i j then nth i d (Zconst t 0) else Zconst t 0).

Definition jacobi_iter {t: type} (A1: diagmatrix t) (A2: matrix t) (b: vector t) (x: vector t) : vector t :=
   diagmatrix_vector_mult (invert_diagmatrix A1) (vector_sub b (matrix_vector_mult A2 x)).

Definition jacobi_residual {t: type} (A1: diagmatrix t) (A2: matrix t) (b: vector t) (x: vector t) : vector t :=
   diagmatrix_vector_mult A1 (vector_sub (jacobi_iter A1 A2 b x) x).

Definition going {t} (s acc: ftype t) :=
   andb (Binary.is_finite (fprec t) (femax t) s) (BCMP Lt false s acc).

Fixpoint iter_stop {t} {A} (norm2: A -> ftype t) (residual: A -> A) (f : A -> A) (n:nat) (acc: ftype t) (x:A) :=
 let y := f x in
 let s := norm2 (residual x) in
 match n with
 | O => (s, x)
 | S n' => if going s acc
                then iter_stop norm2 residual f n' acc y
                else (s,x)
  end.

Definition jacobi_n {t: type} (A: matrix t) (b: vector t) (x: vector t) (n: nat) : vector t :=
   let A1 := diag_of_matrix  A in
   let A2 := remove_diag A in
   Nat.iter n (jacobi_iter A1 A2 b) x.

Definition dist2 {t: type} (x y: vector t) := norm2 (vector_sub x y).

Definition jacobi {t: type} (A: matrix t) (b: vector t) (x: vector t) (acc: ftype t) (n: nat) :
         ftype t * vector t :=
   let A1 := diag_of_matrix  A in
   let A2 := remove_diag A in
   iter_stop norm2 (jacobi_residual A1 A2 b) (jacobi_iter A1 A2 b) (Nat.pred n) acc x.

End WITH_NANS.

Module PlaceHolder.

(* These definitions and proofs will are "placeholders" and will
 be replaced by the real ones being developed in jacobi_iteration_bound.v *)

Section WITH_NANS.
Context {NANS: Nans}.

Definition jacobi_preconditions {t: type}
  (A: matrix t) (b: vector t) (accuracy: ftype t) (k: nat) : Prop :=
  (* some property of A,b,accuracy holds such that
    jacobi_n will indeed converge within k iterations to this accuracy,
   without ever overflowing *)
   False.

Lemma jacobi_iteration_bound_monotone:
  forall {t: type}  (A: matrix t) (b: vector t) (acc: ftype t) (k k': nat),
   (k <= k')%nat ->
   jacobi_preconditions A b acc k ->
   jacobi_preconditions A b acc k'.
Proof. auto. Qed.

Lemma jacobi_iteration_bound_corollaries:
  forall {t: type}  (A: matrix t) (b: vector t) (acc: ftype t) (k: nat),
   jacobi_preconditions A b acc k ->
   matrix_cols A (matrix_rows A) /\
   Forall (Forall finite) A /\
   Forall finite (invert_diagmatrix (diag_of_matrix A)) /\
   Forall finite b /\ finite acc.
Proof. intros. contradiction. Qed.

Lemma jacobi_iteration_bound_lowlevel {t: type} :
 forall (A: matrix t) (b: vector t) (acc: ftype t) (k: nat),
   jacobi_preconditions A b acc k ->
   let acc2 := BMULT acc acc in
   let x0 := (repeat  (Zconst t 0) (length b)) in
   let resid := jacobi_residual (diag_of_matrix A) (remove_diag A) b in
   finite acc2 /\
   exists j,
    (j <= k)%nat /\
    let y :=  jacobi_n A b x0 j in
    let r2 := norm2 (resid y) in
    (forall i, (i <= j)%nat -> finite (norm2 (resid (jacobi_n A b x0 i)))) /\
    BCMP Lt false (norm2 (resid (jacobi_n A b x0 j))) acc2 = false.
Proof. intros. contradiction. Qed.

End WITH_NANS.
End PlaceHolder.

Module Experiment.
(***************** Some sanity checks about diag_of_matrix and matrix_of_diag ***)

(* This turned out to be much lengthier than I expected.    I had to devel
  a whole theory of extensional matrices.  It started to feel like I was
  recapitulating all of MathComp.  My conclusion
  is that all of these lemmas should be done at the MathComp level
  and not at the list-of-lists level.  None of these lemmas are needed
  by the VST proofs, for example. *)

Section WITH_NANS.
Context {NANS: Nans}.

Local Ltac inv H := inversion H; clear H; subst.

Lemma length_diag_of_matrix: forall {t} (m: matrix t),
   matrix_cols_nat m (matrix_rows_nat m) ->
   length (diag_of_matrix m) = matrix_rows_nat m.
Proof.
 intros.
 unfold diag_of_matrix.
 rewrite map_length. rewrite seq_length. auto.
Qed.

Lemma rows_matrix_of_diag: forall {t} (v: diagmatrix t),
   matrix_rows_nat (matrix_of_diag v) = length v.
Proof.
intros.
unfold matrix_of_diag.
apply matrix_by_index_rows.
Qed.

Lemma cols_matrix_of_diag: forall {t} (v: diagmatrix t),
   matrix_cols_nat (matrix_of_diag v) (length v).
Proof.
intros.
unfold matrix_of_diag.
apply matrix_by_index_cols.
Qed.

Lemma diag_of_matrix_of_diag:
  forall {t} (d: diagmatrix t),
  diag_of_matrix (matrix_of_diag d) = d.
Proof.
intros.
unfold diag_of_matrix, matrix_of_diag.
apply (all_nth_eq (Zconst t 0));
rewrite map_length, seq_length, matrix_by_index_rows. auto.
intros.
set (f := fun _ => _).
transitivity (nth i (map f (seq 0 (length d))) (f (length d))).
f_equal. subst f. simpl.
unfold matrix_by_index.
unfold matrix_index.
rewrite nth_overflow; auto.
rewrite nth_overflow; auto.
simpl; lia.
rewrite map_length. rewrite seq_length. lia.
rewrite map_nth.
rewrite seq_nth by auto.
simpl.
subst f. simpl.
rewrite matrix_by_index_index by auto.
destruct (Nat.eq_dec i); try contradiction; auto.
Qed.

Lemma Forall_diag_of_matrix {t}: forall (P: ftype t -> Prop) (m: matrix t),
 matrix_cols_nat m (matrix_rows_nat m) ->
 Forall (Forall P) m -> Forall P (diag_of_matrix m).
Proof.
intros.
apply Forall_map.
apply Forall_seq.
intros.
red in H.
unfold matrix_index.
unfold matrix_rows_nat in *.
rewrite Forall_nth in H0.
specialize (H0 i nil ltac:(lia)).
rewrite Forall_nth in H0.
apply (H0 i (Zconst t 0)).
rewrite Forall_forall in H.
specialize (H (nth i m nil)).
rewrite H. lia.
apply nth_In. lia.
Qed.

Lemma matrix_binop_by_index:
  forall {t} (op: ftype t -> ftype t -> ftype t) (m1 m2: matrix t) cols,
  matrix_rows_nat m1 = matrix_rows_nat m2 ->
  matrix_cols_nat m1 cols -> matrix_cols_nat m2 cols ->
  Forall2 (Forall2 feq) (map2 (map2 op) m1 m2)
  (matrix_by_index (matrix_rows_nat m1) cols (fun i j => op (matrix_index m1 i j) (matrix_index m2 i j))).
Proof.
intros.
apply (matrix_extensionality _ _ cols); auto.
-
rewrite matrix_by_index_rows.
clear H0 H1.
revert m2 H; induction m1; destruct m2; simpl; intros; inv H; auto.
f_equal; eauto.
-
clear H.
revert m2 H1; induction H0; destruct m2; simpl; intros; constructor.
inv H1.
unfold uncurry, map2.
rewrite map_length.
rewrite combine_length.
rewrite H4. apply  Nat.min_id.
apply IHForall.
inv H1; auto.
-
apply matrix_by_index_cols.
-
intros.
 assert (matrix_rows_nat (map2 (map2 op) m1 m2) = matrix_rows_nat m1). {
  clear - H. revert m2 H; induction m1; destruct m2; simpl; intros; inv H; f_equal; eauto.
 }
 rewrite H4 in *.
 rewrite matrix_by_index_index; auto.
 revert m2 H H1 i H2 H4; induction m1; destruct m2; simpl; intros; inv H.
 + lia.
 + destruct i; simpl.
   * clear IHm1.
       unfold matrix_index.
       unfold map2 at 1. unfold combine. simpl.
       unfold map2.
       inv H0. inv H1.
       clear - H3 H5.
       revert j H3 l H5; induction a; destruct j,l; simpl; intros; inv H5; auto.
       inv H3. inv H3.
       simpl in H3.
       eapply IHa; eauto. lia.
   *  unfold matrix_add.
     change (map2 (map2 ?f) (a::m1) (l::m2)) with (map2 f a l :: map2 (map2 f) m1 m2).
      repeat change (matrix_index (?x::?y) (S i) j) with (matrix_index y i j).
     inv H1. inv H0.
     eapply IHm1; eauto. lia.
Qed.

Lemma matrix_rows_nat_remove_diag: forall {t} (m: matrix t),
    matrix_cols_nat m (matrix_rows_nat m) ->
  matrix_rows_nat m = matrix_rows_nat (remove_diag m).
Proof.
 intros.
 symmetry;
 apply matrix_by_index_rows.
Qed.

Lemma matrix_rows_nat_matrix_binop:
 forall {t} (op: ftype t -> ftype t -> ftype t) (m1 m2: matrix t),
 matrix_rows_nat m1 = matrix_rows_nat m2 ->
 matrix_rows_nat (map2 (map2 op) m1 m2) = matrix_rows_nat m1.
Proof.
intros.
unfold matrix_rows_nat in *.
unfold map2.
rewrite map_length.
rewrite combine_length.
lia.
Qed.

Lemma matrix_cols_nat_matrix_binop:
 forall {t} (op: ftype t -> ftype t -> ftype t) (m1 m2: matrix t) cols,
 matrix_cols_nat m1 cols -> matrix_cols_nat m2 cols ->
 matrix_cols_nat (map2 (map2 op) m1 m2) cols.
Proof.
induction m1; destruct m2; simpl; intros.
constructor.
constructor.
constructor.
inv H.
inv H0.
unfold map2 at 1.
unfold combine; fold (combine m1 m2).
simpl.
constructor; auto.
unfold map2. rewrite map_length.
rewrite combine_length; lia.
apply IHm1; auto.
Qed.

Lemma matrix_cols_nat_matrix_unop:
 forall {t} (op: ftype t -> ftype t) (m: matrix t) cols,
 matrix_cols_nat m cols ->
 matrix_cols_nat (map (map op) m) cols.
Proof.
induction 1.
constructor.
constructor.
rewrite map_length. auto.
apply IHForall.
Qed.

Lemma matrix_cols_nat_remove_diag: forall {t} (m: matrix t),
    matrix_cols_nat m (matrix_rows_nat m) ->
  matrix_cols_nat (remove_diag m) (matrix_rows_nat m).
Proof.
intros.
 apply matrix_by_index_cols.
Qed.

Local Open Scope nat.

Lemma matrix_index_diag:
 forall {t} (d: diagmatrix t) i j,
   i < length d -> j < length d ->
   matrix_index (matrix_of_diag d) i j =
    if (Nat.eq_dec i j) then nth i d (Zconst t 0) else Zconst t 0.
Proof.
intros.
unfold matrix_of_diag.
apply matrix_by_index_index; auto.
Qed.

Lemma binop_matrix_index:
 forall {t} (f: ftype t -> ftype t -> ftype t)
  (m1 m2: matrix t) cols,
  matrix_rows_nat m1 = matrix_rows_nat m2 ->
  matrix_cols_nat m1 cols -> matrix_cols_nat m2 cols ->
  forall i j, i < matrix_rows_nat m1 -> j < cols ->
  matrix_index (map2 (map2 f) m1 m2) i j =
  f (matrix_index m1 i j) (matrix_index m2 i j).
Proof.
unfold matrix_rows_nat.
induction m1; destruct m2; simpl; intros; inv H.
simpl in H2. lia.
inv H0.
inv H1.
destruct i.
unfold matrix_index. simpl.
unfold map2.
clear - H3 H4.
revert j H3 l H4; induction a; destruct l,j; simpl; intros; inv H4; auto.
simpl in H3; lia. simpl in H3; lia.
simpl in H3. apply IHa; auto. lia.
apply (IHm1 m2 (length a)); auto.
lia.
Qed.

Lemma remove_plus_diag: forall {t} (m: matrix t),
   matrix_cols_nat m (matrix_rows_nat m) ->
   Forall (Forall finite) m ->
   Forall2 (Forall2 feq) (matrix_add  (matrix_of_diag (diag_of_matrix m)) (remove_diag m)) m.
Proof.
intros.
apply matrix_extensionality with (cols := matrix_rows_nat m); auto.
unfold matrix_add.
rewrite matrix_rows_nat_matrix_binop.
unfold matrix_of_diag.
rewrite matrix_by_index_rows.
apply length_diag_of_matrix; auto.
unfold matrix_of_diag.
rewrite matrix_by_index_rows.
rewrite length_diag_of_matrix; auto.
unfold remove_diag.
rewrite matrix_by_index_rows; auto.
apply matrix_cols_nat_matrix_binop.
replace (matrix_rows_nat m) with (length (diag_of_matrix m)).
apply matrix_by_index_cols.
apply length_diag_of_matrix; auto.
apply matrix_by_index_cols.
unfold matrix_add at 1.
rewrite matrix_rows_nat_matrix_binop.
2:{ unfold matrix_of_diag. rewrite matrix_by_index_rows.
    unfold remove_diag.  rewrite matrix_by_index_rows.
    apply length_diag_of_matrix; auto.
}
unfold matrix_of_diag at 1.
rewrite matrix_by_index_rows; auto.
rewrite length_diag_of_matrix; auto.
intros.
unfold matrix_add.
rewrite binop_matrix_index with (cols := matrix_rows_nat m); auto.
unfold matrix_of_diag, remove_diag.
rewrite !matrix_by_index_index; auto.
destruct (Nat.eq_dec i j).
unfold diag_of_matrix.
rewrite nth_map_seq; auto.
subst j.
apply BPLUS_0_r.
eapply matrix_index_prop; eauto.
apply BPLUS_0_l.
eapply matrix_index_prop; eauto.
rewrite length_diag_of_matrix; auto.
rewrite length_diag_of_matrix; auto.
unfold matrix_of_diag, remove_diag.
rewrite !matrix_by_index_rows; auto.
apply length_diag_of_matrix; auto.
replace (matrix_rows_nat m) with (length (diag_of_matrix m)).
apply matrix_by_index_cols.
apply length_diag_of_matrix; auto.
apply matrix_by_index_cols.
unfold matrix_of_diag.
rewrite matrix_by_index_rows; auto.
rewrite length_diag_of_matrix; auto.
Qed.
End WITH_NANS.
End Experiment.


Require Import Iron.Language.SimpleData.Step.
Require Import Iron.Language.SimpleData.TyJudge.
Require Import Iron.Language.SimpleData.SubstExpExp.

(* When a well typed expression transitions to the next state
   then its type is preserved. *)
Theorem preservation
 :  forall ds x x' t
 ,  TYPE ds nil x  t
 -> STEP x x'
 -> TYPE ds nil x' t.
Proof.
 intros ds x x' t HT HS. gen t.
 induction HS; intros; inverts_type; eauto.

 (* Evaluation in an arbitrary context. *)
 Case "EsContext".
  destruct H; inverts_type; eauto.

  SCase "XCon".
   eapply TYCon; eauto.
   eapply exps_ctx_Forall2_swap; eauto.

 Case "EsLamApp".
  eapply subst_exp_exp; eauto.

 Case "EsCaseAlt".
  eapply subst_exp_exp_list; eauto.
  eapply getAlt_bodyIsWellTyped_fromCase; eauto.
  assert (tsArgs = tsArgs0).
   lets D: getAlt_ctorArgTypesMatchDataDef H4 H7 H0. auto.
   subst. auto.
Qed.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original. *)
Lemma preservation_steps
 :  forall ds x1 t1 x2
 ,  TYPE ds nil x1 t1
 -> STEPS       x1 x2
 -> TYPE ds nil x2 t1.
Proof.
 intros ds x1 t1 x2 HT HS.
 induction HS; eauto using preservation.
Qed.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original.
   Using the left-linearised form for the evaluation.
 *)
Lemma preservation_stepsl
 :  forall ds x1 t1 x2
 ,  TYPE ds nil x1 t1
 -> STEPSL x1 x2
 -> TYPE ds nil x2 t1.
Proof.
 intros ds x1 t1 x2 HT HSL.
 induction HSL; eauto using preservation.
Qed.


From Coq Require Import Arith Relations Lia.
From Coq Require Import FunctionalExtensionality.

Set Implicit Arguments.
Unset Strict Implicit.
Set Printing Implicit Defensive.
Set Transparent Obligations.

(* **************************************************************
 *                                                              *
 *  Basic setup, inductive trees, and almost-full relations     *
 *                                                              *
 ****************************************************************)

(* Decidable *)
Definition dec_rel (X:Type) (R:X->X->Prop) :=
  forall x y, {~ R y x} + {R y x}.

(* WFT *)
Inductive WFT (X : Type) : Type :=
  | ZT : WFT X
  | SUP : (X -> WFT X) -> WFT X.

(* SecureBy *)
Fixpoint SecureBy (X:Type) (A : X->X->Prop) (p : WFT X) : Prop :=
 match p with
 | ZT _ => forall x y, A x y
 | SUP p =>
     forall x, SecureBy (fun y z => A y z \/ A x y) (p x)
 end.

(* AlmostFull *)
Definition almost_full (X:Type) (A : X->X->Prop) :=
  exists p, SecureBy A p.

Lemma sup_rewrite:
   forall (X:Type) (A : X -> X -> Prop) (f : X -> WFT X),
   SecureBy A (SUP f) =
   forall x, SecureBy (fun y z => A y z \/ A x y) (f x).
Proof. intros; auto. Qed.

Lemma sup_eq : forall (X:Type) (f : X -> WFT X) g, f = g -> SUP f = SUP g.
Proof.
intros.
auto.
rewrite H.
reflexivity.
Qed.

(* SecStrengthen *)
Lemma sec_strengthen:
 forall (X:Type) (p : WFT X) (A B : X -> X -> Prop),
 (forall x y, A x y -> B x y) -> SecureBy A p -> SecureBy B p.
Proof.
intros X p. induction p.
intros A B H H0. simpl in H0. simpl. auto.
intros A B H0 H1. simpl in H1. simpl. intro x.
remember (H1 x) as G. eapply H. 2: apply G.
intros. simpl in H2. destruct H2. left. apply H0. apply H2. right.
apply H0. apply H2.
Qed.

(* SecureBy implies that every infinite chain has two related elements *)
(* InfiniteChain *)
Lemma sec_binary_infinite_chain :
 forall (X:Type) (p : WFT X) R (f : nat -> X) (k : nat),
 SecureBy R p ->
 exists n, exists m, (n > m) /\ (m >= k) /\ R (f m) (f n).
Proof.
intro X. intro p. induction p.
intros. simpl in H. exists (S k). exists k. split. auto. split. auto. apply H.
intros. simpl in H0. remember (H0 (f k)) as G. destruct (H _ _ f (S k) G).
destruct H1. destruct H1. destruct H2. destruct H3.
exists x. exists x0. split. apply H1. split. auto. auto with arith. apply H3.
exists x0. exists k. split. auto with arith. split. auto. apply H3.
Qed.

(* InfiniteChainCorollary *)
Corollary af_inf_chain (X : Type) (R : X -> X -> Prop):
 almost_full R ->
 forall (f : nat -> X), exists n, exists m, (n > m) /\ R (f m) (f n).
Proof.
intros. destruct H as (p,Hsec).
destruct (@sec_binary_infinite_chain X p R f 0 Hsec); firstorder.
Defined.

(****************************************************************
 *                                                              *
 *  From a decidable Well-founded relation to an AlmostFull     *
 *                                                              *
 ****************************************************************)

(* Specific example: <= is AlmostFull *)
Fixpoint ltree_aux m (x:nat) : WFT nat :=
  match m with
  | O   => ZT nat
  | S n => SUP (fun y => if le_lt_dec x y then ZT nat else ltree_aux n y)
  end.

Definition le_tree x := ltree_aux (S x) x.

Lemma aux_le_tree_aux :
  forall n m y, n > y -> m > y -> ltree_aux n y = ltree_aux m y.
Proof.
intro n. induction n. intros. inversion H.
intro m. induction m. intros. inversion H0.
intros. simpl. apply sup_eq. apply functional_extensionality.
intro z. destruct (le_lt_dec y z). auto. apply IHn.
lia. lia.
Qed.

Lemma le_tree_rewrite_aux :
  forall n x, n > x -> ltree_aux n x = le_tree x.
Proof.
intro n. induction n. intros. inversion H.
intros.
destruct ((proj1 (Nat.lt_eq_cases _ _)) (proj2 (Nat.succ_le_mono _ _) H)).
simpl.
unfold le_tree. simpl. apply sup_eq.
apply functional_extensionality. intro y.
destruct (le_lt_dec x y). auto.
apply aux_le_tree_aux. lia. lia.
rewrite H0. unfold le_tree. reflexivity.
Qed.

Lemma le_tree_rewrite : forall (x:nat),
 le_tree x = SUP (fun y => if le_lt_dec x y then ZT nat else le_tree y).
Proof.
intro x. rewrite <- (@le_tree_rewrite_aux (S x) x).
simpl. apply sup_eq. apply functional_extensionality. intro y.
destruct (le_lt_dec x y). auto. apply le_tree_rewrite_aux. firstorder.
firstorder.
Qed.

(* LeTreeLemma *)
Lemma af_le : SecureBy (fun x y => x <= y) (SUP le_tree).
Proof.
rewrite sup_rewrite.
apply (@well_founded_induction nat lt).
apply lt_wf.
intros. unfold le_tree. simpl.
intro y. destruct (le_lt_dec x y). simpl. intros. right. right. apply l.
rewrite -> le_tree_rewrite_aux. eapply sec_strengthen.
2: { apply H. apply l. }
intros. simpl. simpl in H0. destruct H0.
left. left. apply H0. right. left. apply H0.
firstorder.
Qed.

(* Generalization to an arbitrary decidable well-founded relation *)
(* AfTreeIter *)
Fixpoint af_tree_iter (X:Type) (R : X -> X -> Prop)
         (decR : dec_rel R) (x:X) (accX : Acc R x) :=
 match accX with
 | Acc_intro _ f => SUP (fun y =>
     match decR x y with
       | left _ => ZT X
       | right Ry => af_tree_iter decR (f y Ry)
     end)
 end.

(* AfTree *)
Definition af_tree (X:Type) (R : X -> X -> Prop)
 (wfR : well_founded R) (decR : dec_rel R) : X -> WFT X.
Proof.
intro x.
apply af_tree_iter with (R := R) (x := x).
apply decR. apply wfR.
Defined. (* Not Qed because we want to compute with it *)

(* AfFromWf *)
Lemma secure_from_wf :
 forall (X:Type) (R : X -> X -> Prop)
 (wfR : well_founded R) (decR : dec_rel R),
 SecureBy (fun x y => ~ R y x)
          (SUP (af_tree wfR decR)).
Proof.
intros. rewrite sup_rewrite.
unfold af_tree.
intro x. remember (wfR x) as xAcc. clear HeqxAcc.
apply (@well_founded_induction X R wfR
         (fun (x:X) => forall (xAcc : Acc R x),
                       SecureBy (fun y z  => ~ R z y \/ ~ R y x)
                                (af_tree_iter decR xAcc))).
intros y H. intro xAccy.
destruct xAccy. simpl.
intro z. destruct (decR y z). simpl. right. right. apply n.
eapply sec_strengthen. 2: { apply H. apply r. }
intros. simpl in H0. destruct H0. left. left. apply H0.
right. left. apply H0.
Defined. (* Not Qed because we want to compute with it *)

(* AfFromWfCor *)
Corollary af_from_wf (X:Type) (R : X -> X -> Prop) :
  well_founded R ->
  dec_rel R -> almost_full (fun x y => ~ R y x).
Proof.
intros wfR decR. unfold almost_full.
exists (SUP (af_tree wfR decR)).
apply secure_from_wf.
Defined.

(* Example: <= is AF *)
(* LeqAF *)
Corollary leq_af : almost_full le.
Proof.
unfold almost_full.
cut (dec_rel lt). intro decLt.
eexists (SUP (af_tree lt_wf decLt)).
 eapply sec_strengthen. 2: apply secure_from_wf.
intros. simpl in H. lia.
unfold dec_rel. intros. destruct (le_lt_dec x y).
left; lia.
right; lia.
Defined.

(* **************************************************************
 *                                                              *
 *  From an AlmostFull relation to a Well-Founded one           *
 *                                                              *
 ****************************************************************)

Lemma trans_clos_left : forall X (T : X -> X -> Prop) z y z0,
 T z y -> clos_refl_trans X T z0 z -> clos_refl_trans X T z0 y.
Proof.
intros. eapply rt_trans. apply H0. apply rt_step. apply H.
Qed.

Lemma trans_clos_left_aux : forall X (T : X -> X -> Prop) z y z0,
  T z y -> clos_refl_trans X T z0 z -> clos_trans_1n X T z0 y.
Proof.
intros X T z y z0 H Hrt.
remember (@Relation_Operators.t1n_step X T z y H) as G. clear HeqG; clear H.
remember (@clos_rt_rt1n _ T z0 z Hrt) as F. clear HeqF. clear Hrt.
induction F. apply G. econstructor 2. apply H. apply IHF. apply G.
Qed.

(* AccFromAf *)
Lemma acc_from_af:
  forall (X:Type) (p : WFT X) (R : X -> X -> Prop)
  (T : X -> X -> Prop) y,
  (forall x z, clos_refl_trans X T z y ->
               clos_trans_1n X T x z /\ R z x -> False) ->
  SecureBy R p -> Acc T y.
Proof.
intros X p. induction p.
intros. simpl in H0.
apply Acc_intro. intros. edestruct (H y0 y).
apply rt_refl. split. constructor 1. apply H1. apply H0.
intros.
apply Acc_intro. intros z HT.
simpl in H1. remember (H1 y).
eapply H with (R := fun y0 z => R y0 z \/ R y y0).
2: apply s. intros. simpl in H2.
simpl in H3. destruct H3. destruct H4.
eapply H0. eapply trans_clos_left. apply HT. apply H2.
split. apply H3. apply H4. eapply H0. eapply trans_clos_left.
apply HT. apply H2. split. apply H3.
destruct (H0 z0 y). apply rt_refl. split. 2: apply H4.
eapply trans_clos_left_aux. apply HT. apply H2.
Defined.

(* WfFromAf *)
Lemma wf_from_af :
   forall (X:Type) (p : WFT X)
   (R : X -> X -> Prop) (T : X -> X -> Prop),
   (forall x y, clos_trans_1n X T x y /\ R y x -> False)
    -> SecureBy R p -> well_founded T.
Proof.
intros. unfold well_founded. intro y.
eapply acc_from_af. 2: apply H0.
intros. eapply H. apply H2.
Defined.

(* A reassuring lemma *)
(* WfFromWqo *)
Lemma wf_from_wqo :
  forall (X:Type) (p : WFT X) (R : X -> X -> Prop),
         transitive X R -> SecureBy R p ->
         well_founded (fun x y => R x y /\ ~ R y x).
Proof.
intros.
apply wf_from_af with (R := R) (p := p).
intros. destruct H1.
assert (~ R y x).
induction H1. destruct H1. apply H3.
unfold not in *. intros. apply IHclos_trans_1n. destruct H1.
apply (H _ _ _ H4 H1). destruct H1.
apply (H _ _ _ H4 H1). unfold not in H3. apply H3. apply H2. apply H0.
Qed.


(************************************************************************)
(* Copyright (c) 2021, Gergei Bana and Qianli Zhang                     *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Import Core.
Require Import Pair.

(* The Commitment Scheme will include three function symbols: { com, comk, L }

   com  : a commitment function symbol that has two input parameters, with the first a plaintext and the second a commitment key.
   comk : a function symbols that can consume a nonce to generate the commitment key.
   L    : a function symbols that could return the length of input.  *)

(*  Computational Commitment hidding property for a Commitment Scheme: *)

Definition CompHid_prop (t0 : list ppt -> list ppt) (t t1 t2 : ppt) (n1 n2 : nat)
           (L com comk : list ppt -> ppt ): Prop :=
  n1 <> n2 ->
  Fresh (nonce n1) [t; t1; t2] -> Freshc (nonce n1) t0 ->
  Fresh (nonce n2) [t; t1; t2] -> Freshc (nonce n2) t0 ->
  t0 [If (L [t1] ≟ L [t2]) Then (＜(com [t1; (comk [nonce n1])]), (com [t2; (comk [nonce n2])]) ＞) Else t]
 ~
  t0 [If (L [t1] ≟ L [t2]) Then (＜(com [t2; (comk [nonce n1])]), (com [t1; (comk [nonce n2])]) ＞) Else t] .

(* Computational Commitment Binding property for a Commitment Scheme: *)

Definition CompBind_prop (x x' r r': ppt)
           (com : list ppt -> ppt) : Prop :=
    If ((com [x; r]) ≟ (com [x'; r'])) Then (x ≟ x') Else FAlse
    =
    ((com [x; r]) ≟ (com [x'; r'])).


(*H*)

Require Import List.
Import ListNotations.

Fixpoint typelist_to_tuple (t : list Set) : Set := match t with
| x :: [] => x
| x :: r => (x * typelist_to_tuple r)
| [] => True
end.

Fixpoint typelist_to_arrows (t : list Set) : Set := match t with
| x :: [] => x
| x :: r => x -> typelist_to_arrows r
| [] => True
end.

Definition nat_recursion (A : Type) (z : A) (s : A -> A) (n : nat) : A
  := nat_rect (fun _ => A) z (fun _ => s) n.

Definition with_n_arrows (A : Type) (n : nat) : Type :=
  nat_recursion Type A (fun t => Type -> t) n.

Check nat_rect.

Definition collect_n_args {A : Type} (n : nat)
  (continuation : list Type -> A) : with_n_arrows A n :=
let fix collect_n_args' (n : nat) (types : list Type) : with_n_arrows A n
  := match n with
  | O => continuation types
  | S n1 => fun (t : Type) => collect_n_args' n1 (t :: types)
  end
in collect_n_args' n [].

Fixpoint n_to_foralls' (n : nat) (types : list Set)
  (continuation : list Set -> Type) : Type := match n with
| O => continuation (rev types)
| S n1 => forall x, n_to_foralls' n1 (x :: types) continuation
end.

Definition n_to_foralls (n : nat) (continuation : list Set -> Type) : Type
  := n_to_foralls' n [] continuation.

(* Type of curry_n *)
Definition curry_n_t (n : nat) : Type := n_to_foralls n
  (fun types => forall r : Set,
    (typelist_to_tuple types -> r) -> typelist_to_arrows (app types [r])).

Print curry.

Fixpoint curry_n (n : nat) (types : list Type) : _ := match n with
| O => I
| S n1 =>
end.

Compute (curry_n_t 3).

(* Semantics of curry_n *)
Definition curry_n (n : nat) : curry_n_t n :=
  let body := fun types f =>
    _ in
  collect_n_args n body.


Require Export BagsInterface.
Unset Implicit Arguments.

Open Scope list.

Section ListBags.

  Context {TItem : Type}
          {TSearchTerm : Type}
          {TUpdateTerm : Type}
          (star: TSearchTerm)
          (bid : TUpdateTerm)
          (bfind_matcher: TSearchTerm -> TItem -> bool)
          (bupdate_transform : TUpdateTerm -> TItem -> TItem)
          (find_star: forall (i: TItem), bfind_matcher star i = true).

  Definition ListAsBag_bfind
             (container: list TItem)
             (search_term: TSearchTerm) :=
    List.filter (bfind_matcher search_term) container.

  Definition ListAsBag_binsert
             (container: list TItem)
             (item: TItem) :=
    cons item container.

  Definition ListAsBag_bcount
             (container: list TItem)
             (search_term: TSearchTerm) :=
    List.fold_left (fun acc x => acc + if (bfind_matcher search_term x) then 1 else 0) container 0.

  Definition ListAsBag_bdelete
             (container : list TItem)
             (search_term : TSearchTerm) :=
    List.partition (bfind_matcher search_term) container.

  Definition ListAsBag_bupdate
             (container   : list TItem)
             (search_term : TSearchTerm)
             (update_term : TUpdateTerm) :=
    (snd (List.partition (bfind_matcher search_term) container))
      ++ List.map (bupdate_transform update_term)
      (fst (List.partition (bfind_matcher search_term)
                           container)).

  Definition ListBag_RepInv (_ : list TItem) := True.
  Definition ListBag_ValidUpdate (_ : TUpdateTerm) := True.

  Lemma List_BagInsertEnumerate :
    BagInsertEnumerate ListBag_RepInv id (ListAsBag_binsert).
  Proof.
    firstorder.
  Qed.

  Lemma List_BagEnumerateEmpty :
    BagEnumerateEmpty id (@nil TItem).
  Proof.
    firstorder.
  Qed.

  Lemma List_BagFindStar :
    BagFindStar ListBag_RepInv ListAsBag_bfind id star.
  Proof.
    intros; unfold ListBag_RepInv;
    induction container; simpl;
    [ | rewrite find_star, IHcontainer]; trivial.
  Qed.

  Lemma List_BagFindCorrect :
    BagFindCorrect ListBag_RepInv ListAsBag_bfind bfind_matcher id.
  Proof.
    firstorder.
  Qed.

  Require Import Omega.
  Lemma List_BagCountCorrect_aux :
    forall (container: list TItem) (search_term: TSearchTerm) default,
      length (List.filter (bfind_matcher search_term) container) + default =
      List.fold_left
        (fun (acc : nat) (x : TItem) =>
           acc + (if bfind_matcher search_term x then 1 else 0))
        container default.
  Proof.
    induction container; intros.

    + trivial.
    + simpl; destruct (bfind_matcher search_term a);
      simpl; rewrite <- IHcontainer; omega.
  Qed.

  Lemma List_BagCountCorrect :
    BagCountCorrect ListBag_RepInv ListAsBag_bcount ListAsBag_bfind.
  Proof.
    unfold BagCountCorrect, ListAsBag_bcount, ListAsBag_bfind; intros;
    pose proof (List_BagCountCorrect_aux container search_term 0) as temp;
    rewrite plus_0_r in temp; simpl in temp; exact temp.
  Qed.

  Lemma List_BagDeleteCorrect :
    BagDeleteCorrect ListBag_RepInv ListAsBag_bfind bfind_matcher id ListAsBag_bdelete.
  Proof.
    firstorder.
  Qed.

  Lemma List_BagUpdateCorrect :
    BagUpdateCorrect ListBag_RepInv ListBag_ValidUpdate
                     ListAsBag_bfind bfind_matcher id bupdate_transform ListAsBag_bupdate.
  Proof.
    firstorder.
  Qed.

  Global Instance ListAsBag
  : Bag (list TItem) TItem TSearchTerm TUpdateTerm :=
    {|
      bempty            := nil;
      bstar             := star;
      bfind_matcher     := bfind_matcher;
      bupdate_transform := bupdate_transform;

      benumerate := id;
      bfind      := ListAsBag_bfind;
      binsert    := ListAsBag_binsert;
      bcount     := ListAsBag_bcount;
      bdelete    := ListAsBag_bdelete;
      bupdate    := ListAsBag_bupdate
    |}.

  Global Instance ListAsBagCorrect
  : CorrectBag ListBag_RepInv ListBag_ValidUpdate ListAsBag :=
    {|

      binsert_enumerate := List_BagInsertEnumerate;
      benumerate_empty  := List_BagEnumerateEmpty;
      bfind_star        := List_BagFindStar;
      bfind_correct     := List_BagFindCorrect;
      bcount_correct    := List_BagCountCorrect;
      bdelete_correct   := List_BagDeleteCorrect;
      bupdate_correct   := List_BagUpdateCorrect
    |}.
  Proof.
    unfold ListBag_RepInv; eauto.
    unfold binsert_Preserves_RepInv; eauto.
    unfold bdelete_Preserves_RepInv; eauto.
    unfold bupdate_Preserves_RepInv; eauto.
  Qed.

End ListBags.


Require Import init.

Require Import linear_free.
Require Import linear_subspace.
Require Import linear_span.
Require Import linear_bilinear.
Require Import tensor_product_construction.

Require Import set.

Require Import unordered_list.

Require Import module_category.
Require Import category_initterm.

(* begin hide *)
Section TensorProductCategory.

(* end hide *)
Context {F : CRingObj} (M N : ModuleObj F).

(* begin hide *)
Let U := cring_U F.
Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPA := cring_plus_assoc F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMA := cring_mult_assoc F.
Let UMC := cring_mult_comm F.
Let UMO := cring_mult_lid F.
Let UMD := cring_ldist F.
Let V1 := module_V M.
Let VP1 := module_plus M.
Let VZ1 := module_zero M.
Let VN1 := module_neg M.
Let VPA1 := module_plus_assoc M.
Let VPC1 := module_plus_comm M.
Let VPZ1 := module_plus_lid M.
Let VPN1 := module_plus_linv M.
Let SM1 := module_scalar M.
Let SMO1 := module_scalar_id M.
Let SML1 := module_scalar_ldist M.
Let SMR1 := module_scalar_rdist M.
Let SMC1 := module_scalar_comp M.
Let V2 := module_V N.
Let VP2 := module_plus N.
Let VZ2 := module_zero N.
Let VN2 := module_neg N.
Let VPA2 := module_plus_assoc N.
Let VPC2 := module_plus_comm N.
Let VPZ2 := module_plus_lid N.
Let VPN2 := module_plus_linv N.
Let SM2 := module_scalar N.
Let SMO2 := module_scalar_id N.
Let SML2 := module_scalar_ldist N.
Let SMR2 := module_scalar_rdist N.
Let SMC2 := module_scalar_comp N.
Existing Instances UP UZ UN UPA UPC UPZ UPN UM UO UMA UMC UMO UMD VP1 VZ1 VN1
    VPA1 VPC1 VPZ1 VPN1 SM1 SMO1 SML1 SMR1 SMC1 VP2 VZ2 VN2 VPA2 VPC2 VPZ2 VPN2
    SM2 SMO2 SML2 SMR2 SMC2.

(* end hide *)
Definition tensor_product_base := make_module
    F
    (tensor_space M N)
    (tensor_plus M N)
    (tensor_zero M N)
    (tensor_neg M N)
    (tensor_plus_assoc M N)
    (tensor_plus_comm M N)
    (tensor_plus_lid M N)
    (tensor_plus_linv M N)
    (tensor_scalar_mult M N)
    (tensor_scalar_id M N)
    (tensor_scalar_ldist M N)
    (tensor_scalar_rdist M N)
    (tensor_scalar_comp M N).

Record bilinear_from := make_bilinear {
    bilinear_from_module : ModuleObj F;
    bilinear_from_f : V1 → V2 → module_V bilinear_from_module;
    bilinear_from_bi : bilinear
        (H1 := module_plus bilinear_from_module)
        (H4 := module_scalar bilinear_from_module)
        bilinear_from_f;
}.

Definition bilinear_from_set (f g : bilinear_from)
    (h : cat_morphism (MODULE F)
                      (bilinear_from_module f)
                      (bilinear_from_module g))
    := ∀ x y, h (bilinear_from_f f x y) = bilinear_from_f g x y.

Definition bilinear_from_compose {F G H : bilinear_from}
    (f : set_type (bilinear_from_set G H)) (g : set_type (bilinear_from_set F G))
    := [f|] ∘ [g|].

Lemma bilinear_from_set_compose_in
    {F' G H : bilinear_from} : ∀ (f : set_type (bilinear_from_set G H)) g,
    bilinear_from_set F' H (bilinear_from_compose f g).
Proof.
    intros [f f_eq] [g g_eq].
    unfold bilinear_from_set in *.
    unfold bilinear_from_compose; cbn.
    intros x y.
    rewrite g_eq.
    apply f_eq.
Qed.

Lemma bilinear_from_set_id_in : ∀ f : bilinear_from, bilinear_from_set f f 𝟙.
Proof.
    intros f.
    unfold bilinear_from_set.
    intros x y.
    cbn.
    reflexivity.
Qed.

Program Instance BILINEAR_FROM : Category := {
    cat_U := bilinear_from;
    cat_morphism f g := set_type (bilinear_from_set f g);
    cat_compose {F G H} f g := [_|bilinear_from_set_compose_in f g];
    cat_id f := [_|bilinear_from_set_id_in f];
}.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_assoc (MODULE F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_lid (MODULE F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_rid (MODULE F)).
Qed.

(* begin hide *)
Let FR_module := free_linear F (V1 * V2).
Let FR_plus := module_plus FR_module.
Let FR_zero := module_zero FR_module.
Let FR_neg := module_neg FR_module.
Let FR_plus_comm := module_plus_comm FR_module.
Let FR_plus_assoc := module_plus_assoc FR_module.
Let FR_plus_lid := module_plus_lid FR_module.
Let FR_plus_linv := module_plus_linv FR_module.
Let FR_scalar := module_scalar FR_module.
Let FR_scalar_id := module_scalar_id FR_module.
Let FR_scalar_ldist := module_scalar_ldist FR_module.
Let FR_scalar_rdist := module_scalar_rdist FR_module.
Let FR_scalar_comp := module_scalar_comp FR_module.
Let V3P := module_plus tensor_product_base.
Let SM3 := module_scalar tensor_product_base.
Existing Instances FR_plus FR_zero FR_neg FR_plus_comm FR_plus_assoc FR_plus_lid
    FR_plus_linv FR_scalar FR_scalar_id FR_scalar_ldist FR_scalar_rdist
    FR_scalar_comp V3P SM3.

(* end hide *)
Let f x y := tensor_mult_base M N x y.

Lemma tensor_product_bilinear_base : bilinear f.
Proof.
    repeat split.
    -   apply tensor_lscalar_base.
    -   apply tensor_rscalar_base.
    -   apply tensor_rdist_base.
    -   apply tensor_ldist_base.
Qed.

Let f_bilinear_from :=
    make_bilinear tensor_product_base f tensor_product_bilinear_base.

Lemma tensor_product_ex_base : @initial BILINEAR_FROM f_bilinear_from.
Proof.
    unfold f_bilinear_from, initial; cbn.
    intros g.
    pose (tp := module_plus (tensor_product_base)).
    pose (tz := module_zero (tensor_product_base)).
    pose (tn := module_neg (tensor_product_base)).
    pose (tpa := module_plus_assoc (tensor_product_base)).
    pose (tpc := module_plus_comm (tensor_product_base)).
    pose (tpz := module_plus_lid (tensor_product_base)).
    pose (tpn := module_plus_linv (tensor_product_base)).
    pose (tsm := module_scalar (tensor_product_base)).
    pose (tsc := module_scalar_comp (tensor_product_base)).
    pose (tso := module_scalar_id (tensor_product_base)).
    pose (tsl := module_scalar_ldist (tensor_product_base)).
    pose (tsr := module_scalar_rdist (tensor_product_base)).
    pose (gP := module_plus (bilinear_from_module g)).
    pose (gZ := module_zero (bilinear_from_module g)).
    pose (gN := module_neg (bilinear_from_module g)).
    pose (gPA := module_plus_assoc (bilinear_from_module g)).
    pose (gPC := module_plus_comm (bilinear_from_module g)).
    pose (gPZ := module_plus_lid (bilinear_from_module g)).
    pose (gPN := module_plus_linv (bilinear_from_module g)).
    pose (gSM := module_scalar (bilinear_from_module g)).
    pose (gSO := module_scalar_id (bilinear_from_module g)).
    pose (gSL := module_scalar_ldist (bilinear_from_module g)).
    pose (gSR := module_scalar_rdist (bilinear_from_module g)).
    apply singleton_ex; [>split|].
    -   apply ex_set_type.
        pose (h1 x := bilinear_from_f g (fst x) (snd x)).
        pose (h2 := make_free_from F (V1 * V2) (bilinear_from_module g) h1).
        pose proof (free_module_universal F (V1 * V2) h2) as uni.
        cbn in uni.
        apply ex_singleton in uni as [h3 h3_free_from].
        unfold free_from_set in h3_free_from.
        cbn in h3_free_from.
        pose (h4 := module_homo_f h3).
        cbn in h4.
        pose (h3_plus := @module_homo_plus _ _ _ h3).
        pose (h3_scalar := @module_homo_scalar _ _ _ h3).
        assert (∀ x y, eq_equal (subspace_equiv (linear_span_subspace U
            (tensor_product_ideal M N))) x y → h4 x = h4 y) as wd.
        {
            intros x y eq.
            cbn in eq.
            unfold h4.
            apply plus_0_anb_a_b.
            rewrite <- scalar_neg_one.
            rewrite <- h3_scalar.
            rewrite scalar_neg_one.
            rewrite <- h3_plus.
            rewrite (span_linear_combination _ (tensor_product_ideal M N)) in eq.
            destruct eq as [l [l_eq l_in]].
            cbn in *.
            unfold FR_plus in l_eq.
            unfold U, V1, V2 in l_eq.
            unfold U, V1, V2.
            rewrite l_eq; clear l_eq.
            destruct l as [l l_comb]; cbn in *.
            unfold linear_combination; cbn.
            unfold linear_list_in in l_in; cbn in l_in; clear l_comb.
            induction l using ulist_induction.
            -   rewrite ulist_image_end, ulist_sum_end.
                rewrite <- (scalar_lanni (V := module_V (free_linear F (V1 * V2))) 0).
                rewrite h3_scalar.
                rewrite scalar_lanni.
                reflexivity.
            -   prove_parts IHl.
                1: {
                    apply ulist_prop_split.
                    intros [α v] l' l_eq; cbn.
                    subst l.
                    rewrite ulist_swap in l_in.
                    rewrite ulist_prop_add in l_in.
                    apply l_in.
                }
                rewrite ulist_image_add, ulist_sum_add.
                rewrite h3_plus.
                unfold U, V1, V2.
                rewrite <- IHl; clear IHl.
                rewrite plus_rid.
                rewrite h3_scalar.
                assert (tensor_product_ideal M N (snd a)) as a_in.
                {
                    rewrite ulist_prop_add in l_in.
                    apply l_in.
                }
                pose proof (bilinear_from_bi g) as
                    [g_lscalar [g_rscalar [g_rdist g_ldist]]].
                destruct a_in as [[[a_in|a_in]|a_in]|a_in].
                +   destruct a_in as [u [v [w eq]]].
                    unfold U, V1, V2 in eq.
                    rewrite eq; clear eq.
                    rewrite h3_plus.
                    rewrite h3_plus.
                    rewrite <- scalar_neg_one.
                    rewrite <- (scalar_neg_one (V := module_V (free_linear F (V1 * V2)))).
                    do 2 rewrite h3_scalar.
                    do 2 rewrite scalar_neg_one.
                    do 3 rewrite h3_free_from.
                    unfold h1; cbn.
                    rewrite <- plus_assoc.
                    rewrite <- neg_plus.
                    rewrite <- g_rdist.
                    rewrite plus_rinv.
                    rewrite scalar_ranni.
                    reflexivity.
                +   destruct a_in as [u [v [w eq]]].
                    unfold U, V1, V2 in eq.
                    rewrite eq; clear eq.
                    rewrite h3_plus.
                    rewrite h3_plus.
                    rewrite <- scalar_neg_one.
                    rewrite <- (scalar_neg_one (V := module_V (free_linear F (V1 * V2)))).
                    do 2 rewrite h3_scalar.
                    do 2 rewrite scalar_neg_one.
                    do 3 rewrite h3_free_from.
                    unfold h1; cbn.
                    rewrite <- plus_assoc.
                    rewrite <- neg_plus.
                    rewrite <- g_ldist.
                    rewrite plus_rinv.
                    rewrite scalar_ranni.
                    reflexivity.
                +   destruct a_in as [α [u [v eq]]].
                    unfold U, V1, V2 in eq.
                    rewrite eq; clear eq.
                    rewrite h3_plus.
                    rewrite <- scalar_neg_one.
                    do 2 rewrite h3_scalar.
                    rewrite scalar_neg_one.
                    do 2 rewrite h3_free_from.
                    unfold h1; cbn.
                    rewrite g_lscalar.
                    rewrite plus_rinv.
                    rewrite scalar_ranni.
                    reflexivity.
                +   destruct a_in as [α [u [v eq]]].
                    unfold U, V1, V2 in eq.
                    rewrite eq; clear eq.
                    rewrite h3_plus.
                    rewrite <- scalar_neg_one.
                    do 2 rewrite h3_scalar.
                    rewrite scalar_neg_one.
                    do 2 rewrite h3_free_from.
                    unfold h1; cbn.
                    rewrite g_rscalar.
                    rewrite plus_rinv.
                    rewrite scalar_ranni.
                    reflexivity.
        }
        pose (h := unary_op wd).
        cbn in *.
        change (equiv_type (subspace_equiv (linear_span_subspace U
            (tensor_product_ideal M N)))) with (tensor_space M N) in h.
        assert (∀ u v, h (u + v) = h u + h v) as h_plus.
        {
            intros u v.
            equiv_get_value u v.
            unfold h.
            unfold plus at 1; cbn.
            equiv_simpl.
            apply h3_plus.
        }
        assert (∀ a v, h (a · v) = a · h v) as h_scalar.
        {
            intros a v.
            equiv_get_value v.
            unfold h.
            unfold scalar_mult at 1; cbn.
            equiv_simpl.
            apply h3_scalar.
        }
        exists (make_module_homomorphism _ tensor_product_base _ h h_plus h_scalar).
        unfold bilinear_from_set; cbn.
        intros x y.
        unfold h, f.
        unfold tensor_mult_base, to_quotient.
        equiv_simpl.
        unfold h4.
        rewrite h3_free_from.
        unfold h1.
        cbn.
        reflexivity.
    -   intros [h1 h1_from] [h2 h2_from].
        unfold bilinear_from_set in h1_from, h2_from; cbn in *.
        pose (h1_plus := @module_homo_plus _ _ _ h1).
        pose (h2_plus := @module_homo_plus _ _ _ h2).
        pose (h1_scalar := @module_homo_scalar _ _ _ h1).
        pose (h2_scalar := @module_homo_scalar _ _ _ h2).
        apply set_type_eq; cbn.
        apply module_homomorphism_eq.
        intros x.
        cbn in x.
        pose proof (tensor_sum_base M N x) as [l x_eq].
        rewrite x_eq; clear x_eq.
        induction l using ulist_induction.
        +   rewrite ulist_image_end, ulist_sum_end.
            rewrite <- (scalar_lanni 0).
            rewrite h1_scalar, h2_scalar.
            do 2 rewrite scalar_lanni.
            reflexivity.
        +   rewrite ulist_image_add, ulist_sum_add.
            rewrite h1_plus, h2_plus.
            rewrite IHl; clear IHl.
            apply rplus.
            destruct a as [a [u [v a_eq]]]; cbn.
            subst a.
            rewrite h1_from, h2_from.
            reflexivity.
Qed.

Theorem tensor_product_ex : ∃ T, @initial BILINEAR_FROM T.
Proof.
    exists f_bilinear_from.
    exact tensor_product_ex_base.
Qed.

Definition tensor_bilinear_from := ex_val tensor_product_ex.
Definition tensor_product := bilinear_from_module tensor_bilinear_from.
Definition tensor_mult := bilinear_from_f tensor_bilinear_from.
Definition tensor_bilinear := bilinear_from_bi tensor_bilinear_from.

Theorem tensor_product_universal : initial tensor_bilinear_from.
Proof.
    exact (ex_proof tensor_product_ex).
Qed.

Infix "⊗" := tensor_mult : algebra_scope.

(* begin hide *)
Let tensor_plus := module_plus tensor_product.
Let tensor_zero := module_zero tensor_product.
Let tensor_neg := module_neg tensor_product.
Let tensor_plus_comm := module_plus_comm tensor_product.
Let tensor_plus_assoc := module_plus_assoc tensor_product.
Let tensor_plus_lid := module_plus_lid tensor_product.
Let tensor_plus_linv := module_plus_linv tensor_product.
Let tensor_scalar := module_scalar tensor_product.
Let tensor_scalar_comp := module_scalar_comp tensor_product.
Let tensor_scalar_id := module_scalar_id tensor_product.
Let tensor_scalar_rdist := module_scalar_rdist tensor_product.
Existing Instances tensor_plus tensor_zero tensor_neg tensor_plus_comm
    tensor_plus_assoc tensor_plus_lid tensor_plus_linv tensor_scalar
    tensor_scalar_comp tensor_scalar_id tensor_scalar_rdist.

(* end hide *)
Theorem tensor_ldist : ∀ a b c, a ⊗ (b + c) = a ⊗ b + a ⊗ c.
Proof.
    apply tensor_bilinear.
Qed.

Theorem tensor_rdist : ∀ a b c, (a + b) ⊗ c = a ⊗ c + b ⊗ c.
Proof.
    apply tensor_bilinear.
Qed.

Theorem tensor_lscalar : ∀ a u v, (a · u) ⊗ v = a · (u ⊗ v).
Proof.
    apply tensor_bilinear.
Qed.

Theorem tensor_rscalar : ∀ a u v, u ⊗ (a · v) = a · (u ⊗ v).
Proof.
    apply tensor_bilinear.
Qed.

Theorem tensor_mult_lneg : ∀ u v, (-u) ⊗ v = -(u ⊗ v).
Proof.
    intros u v.
    rewrite <- scalar_neg_one.
    rewrite tensor_lscalar.
    apply scalar_neg_one.
Qed.
Theorem tensor_mult_rneg : ∀ u v, u ⊗ (-v) = -(u ⊗ v).
Proof.
    intros u v.
    rewrite <- scalar_neg_one.
    rewrite tensor_rscalar.
    apply scalar_neg_one.
Qed.

Definition simple_tensor T := ∃ a b, T = a ⊗ b.

Theorem tensor_sum : ∀ T, ∃ l : ulist (set_type simple_tensor),
    T = ulist_sum (ulist_image (λ x, [x|]) l).
Proof.
    pose (tp := module_plus (tensor_product_base)).
    pose (tz := module_zero (tensor_product_base)).
    pose (tn := module_neg (tensor_product_base)).
    pose (tpa := module_plus_assoc (tensor_product_base)).
    pose (tpc := module_plus_comm (tensor_product_base)).
    pose (tpz := module_plus_lid (tensor_product_base)).
    pose (tpn := module_plus_linv (tensor_product_base)).
    pose (tsm := module_scalar (tensor_product_base)).
    pose (tsc := module_scalar_comp (tensor_product_base)).
    pose (tso := module_scalar_id (tensor_product_base)).
    pose (tsl := module_scalar_ldist (tensor_product_base)).
    pose (tsr := module_scalar_rdist (tensor_product_base)).
    intros T.
    pose proof (initial_unique  _ _
        tensor_product_universal tensor_product_ex_base) as [g [h [gh hg]]].
    destruct g as [g g_in], h as [h h_in].
    cbn in *.
    apply set_type_eq in gh; cbn in gh.
    apply set_type_eq in hg; cbn in hg.
    unfold module_homo_compose, module_homo_id in gh, hg.
    inversion gh as [gh']; clear gh.
    inversion hg as [hg']; clear hg.
    pose proof (func_eq _ _ gh') as gh; cbn in gh.
    pose proof (func_eq _ _ hg') as hg; cbn in hg.
    clear gh' hg'.
    pose proof (tensor_sum_base M N (g T)) as [l l_eq].
    pose (f' (t : set_type (simple_tensor_base M N))
        := h [t|]).
    assert (∀ t, simple_tensor (f' t)) as f'_in.
    {
        intros [t [u [v t_eq]]].
        subst t.
        unfold f'; cbn.
        exists u, v.
        unfold bilinear_from_set in *; cbn in *.
        unfold f in h_in.
        rewrite h_in.
        reflexivity.
    }
    exists (ulist_image (λ t, [_|f'_in t]) l).
    unfold f'; cbn.
    rewrite ulist_image_comp; cbn.
    clear f' f'_in.
    revert T l_eq.
    induction l using ulist_induction; intros.
    -   rewrite ulist_image_end, ulist_sum_end.
        rewrite ulist_image_end, ulist_sum_end in l_eq.
        apply (f_equal h) in l_eq.
        rewrite hg in l_eq.
        rewrite l_eq.
        rewrite <- (scalar_ranni 0).
        rewrite (@module_homo_scalar _ _ _ h).
        apply scalar_lanni.
    -   rewrite ulist_image_add, ulist_sum_add.
        rewrite ulist_image_add, ulist_sum_add in l_eq.
        apply plus_rlmove in l_eq.
        rewrite <- (gh (-[a|])) in l_eq.
        rewrite <- (@module_homo_plus _ _ _ g) in l_eq.
        specialize (IHl _ l_eq).
        rewrite <- IHl.
        clear IHl l_eq.
        rewrite <- scalar_neg_one.
        rewrite (@module_homo_scalar _ _ _ h).
        rewrite scalar_neg_one.
        rewrite plus_lrinv.
        reflexivity.
Qed.

Theorem tensor_product_lanni : ∀ v, 0 ⊗ v = 0.
Proof.
    intros v.
    apply (plus_rcancel (0 ⊗ v)).
    rewrite <- tensor_rdist.
    do 2 rewrite plus_lid.
    reflexivity.
Qed.
Theorem tensor_product_ranni : ∀ v, v ⊗ 0 = 0.
Proof.
    intros v.
    apply (plus_rcancel (v ⊗ 0)).
    rewrite <- tensor_ldist.
    do 2 rewrite plus_lid.
    reflexivity.
Qed.
Theorem tensor_product_zero : 0 ⊗ 0 = 0.
Proof.
    apply tensor_product_lanni.
Qed.
(* begin hide *)

End TensorProductCategory.
(* end hide *)