Require Import Coq.ZArith.ZArith.
Require Import Coq.Structures.OrderedType.

Require Import compcert.lib.Axioms.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Memtype.

Require Import VST.msl.eq_dec.
Require Import VST.msl.Coqlib2.
Require Import VST.sepcomp.semantics_lemmas.
Require Import VST.concurrency.sepcomp. Import SepComp.
Require Import VST.concurrency.permissions.
Require Import VST.concurrency.lksize.
Set Bullet Behavior "Strict Subproofs".

  Module MiniAddressOrdered <: MiniOrderedType.

    Definition t:= address.
    Definition eq:= @eq t.
    Definition lt' (x y:t): bool :=
      (match x, y with (x1,x2),(y1,y2) =>
        if peq x1 y1 then zlt x2 y2 else plt x1 y1
      end).
    Definition lt x y:= is_true (lt' x y).

    Lemma eq_refl : forall x : t, eq x x. Proof. reflexivity. Qed.
    Lemma eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. intros; symmetry; assumption. Qed.
    Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros. rewrite H, H0; reflexivity. Qed.
    Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
    Proof. intros x y z; destruct x, y, z.
           unfold lt; simpl.
           destruct (peq b b0), (peq b0 b1), (peq b b1),
           (plt b b0), (plt b0 b1), (plt b b1),
           (zlt z0 z1), (zlt z1 z), (zlt z0 z); subst;
             simpl; intros; auto; try omega; (*Solves most*)
             exfalso;
           (* solves al Plt x y /\ Plt y x *)
           try match goal with
             [H1:Plt ?x ?y, H2:Plt ?y ?x |- _ ]=>
             pose (Plt_trans x y x H1 H2)
               end;
           (* solves Plt x x*)
           try match goal with
             [H1:Plt ?x ?x  |- _ ]=>
             apply (Plt_strict x); assumption
               end;
           (* solves al Plt x y /\ Plt y z /\ ~ Plt x z *)
           match goal with
             [H1:Plt ?x ?y, H2:Plt ?y ?z |- _ ]=>
             pose (Plt_trans x y z H1 H2)
           end; auto.
    Qed.
    Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
    Proof. unfold lt, lt'.
           destruct x, y.
           unfold not; intros.
           inversion H0; subst.
           rewrite peq_true in H.
           assert (HH: z0 >= z0) by omega.
           destruct zlt as [a|b]; auto.
    Qed.
   Lemma compare : forall x y : t, Compare lt eq x y.
          destruct x as [x1 x2].
          destruct y as [y1 y2].
          destruct (peq x1 y1) eqn:H0.
          - destruct (Z_dec x2 y2) eqn:H1; [destruct s|].
            + constructor 1.
              unfold lt, lt'.
              rewrite H0; simpl.
              unfold is_true.
              destruct (zlt x2 y2); auto; omega.
            + constructor 3.
              unfold lt, lt'.
              destruct (peq x1 y1); try solve[inversion H0]; subst.
              destruct (peq y1 y1); simpl. clear e e0 H0.
              destruct (zlt y2 x2); auto; omega.
              destruct (zlt x2 y2); auto; omega.
            + constructor 2.
              subst; reflexivity.
          - destruct (plt x1 y1).
            + constructor 1.
              unfold lt, lt'; rewrite H0; simpl.
              destruct (plt x1 y1); auto.
            + constructor 3.
              unfold lt, lt'.
              destruct (peq x1 y1); try solve[inversion H0]; subst.
              destruct (peq y1 x1); simpl.
              exfalso; apply n; symmetry; assumption.
              destruct (plt y1 x1); auto.
              unfold Plt in *.
              destruct (x1 <? y1)%positive eqn:AAA.
              apply Pos.ltb_lt in AAA. auto.
              apply Pos.ltb_ge in AAA.
              apply Pos.le_lteq in AAA; destruct AAA; auto.
   Qed.
  End MiniAddressOrdered.

  Module AddressOrdered <: OrderedType.
     Include MiniAddressOrdered.

     Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }.
     Proof. unfold eq; destruct x, y. simpl.
            destruct (peq b b0);
              destruct (zeq z z0); subst; try solve[left; reflexivity];
              right; unfold not; intros H; inversion H; apply n; auto.
     Qed.
  End AddressOrdered.

  (*This is my map!*)
  Require Import FMaps.
  Module AMap:= Make AddressOrdered.

  Section AMap2PMap.
    (*Need to build a permission map from a finite map*)
    (*The pmap is used in the compcert memory. *)
    Context {lock_info: Type}.
    Variable am: AMap.t lock_info.

    Definition A2PMap (*: Map.PMap*) :=
      fold_left
        (fun (pmap:access_map) (a:address * lock_info)=>
           match a with
           | ((b, ofs), _) => setPermBlock (Some Memtype.Writable) b ofs pmap LKSIZE_nat
           end)
        (AMap.elements am)
        (PMap.init (fun _ => None)).
    End AMap2PMap.

Lemma AMap_find_map {A B} m (f : A -> B) k (x : A) :
  AMap.find k m = Some x ->
  AMap.find k (AMap.map f m) = Some (f x).
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl.
  - intro. discriminate.
  - destruct (AddressOrdered.compare k addr); intros E.
    + discriminate.
    + injection E as <-. eauto.
    + eauto.
Qed.

Lemma AMap_find_map_None {A B} m (f : A -> B) k :
  AMap.find k m = None ->
  AMap.find k (AMap.map f m) = None.
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl.
  - auto.
  - destruct (AddressOrdered.compare k addr); intros E; auto.
    discriminate.
Qed.

Lemma AMap_find_map_inv {A B} m (f : A -> B) k (y : B) :
  AMap.find k (AMap.map f m) = Some y ->
  exists x,
    AMap.find k m = Some x /\
    y = f x.
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl.
  - intro. discriminate.
  - destruct (AddressOrdered.compare k addr); intros E.
    + discriminate.
    + injection E as <-. eauto.
    + eauto.
Qed.

Lemma AMap_map {A B} (f : A -> B) m :
  map snd (AMap.elements (AMap.map f m)) =
  map f (map snd (AMap.elements m)).
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl; auto.
  rewrite IHl; auto.
Qed.

Lemma AMap_find_map_option_map {A B} m (f : A -> B) k :
  AMap.find k (AMap.map f m) =
  option_map f (AMap.find k m).
Proof.
  destruct (AMap.find k m) eqn:E.
  - apply AMap_find_map, E.
  - apply AMap_find_map_None, E.
Qed.

Instance EqDec_AMap_key : EqDec AMap.key.
Proof.
  compute.
  change (forall a a' : positive * Z, {a = a'} + {a <> a'}).
  repeat decide equality.
Qed.

Lemma AMap_find_add {A} m x (y : A) x' :
  AMap.find x' (AMap.add x y m) =
  if eq_dec x x' then Some y else AMap.find x' m.
Proof.
  pose proof AMap.add_1.
  pose proof AMap.add_2.
  pose proof AMap.add_3.
  pose proof AMap.find_1.
  pose proof AMap.find_2.
  assert (SN : forall A, forall o : option A, (forall x, o <> Some x) <-> o = None).
  { intros ? []; split; congruence. }

  destruct (eq_dec x x') as [d|d].
  - eauto.
  - destruct (AMap.find (elt:=A) x' m) eqn:E.
    + eauto.
    + rewrite <-SN in E |- *.
      intros y' Ey'; eapply E.
      eauto.
Qed.

Lemma AMap_find_remove {A} (m : AMap.t A) x x' :
  AMap.find x' (AMap.remove x m) =
  if eq_dec x x' then None else AMap.find x' m.
Proof.
  pose proof AMap.add_1.
  pose proof AMap.add_2.
  pose proof AMap.add_3.
  pose proof AMap.find_1.
  pose proof AMap.find_2.
  pose proof AMap.remove_1.
  pose proof AMap.remove_2.
  pose proof AMap.remove_3.
  assert (SN : forall A, forall o : option A, (forall x, o <> Some x) <-> o = None).
  { intros ? []; split; congruence. }

  destruct (eq_dec x x') as [d|d].
  - destruct (AMap.find _ _) as [o|] eqn:Eo; auto; exfalso.
    apply AMap.find_2 in Eo.
    eapply H4; eauto.
    exists o. apply Eo.
  - destruct (AMap.find (elt:=A) x' m) eqn:E.
    + eauto.
    + rewrite <-SN in E |- *.
      intros y' Ey'; eapply E.
      eauto.
Qed.

Lemma AMap_Raw_map_app {A} (f : A -> A) l1 l2 :
  AMap.Raw.map (option_map f) (app l1 l2) =
  app (AMap.Raw.map (option_map f) l1)
      (AMap.Raw.map (option_map f) l2).
Proof.
  induction l1; simpl; auto.
  rewrite IHl1. destruct a; auto.
Qed.

Lemma AMap_Raw_map_rev {A} (f : A -> A) l :
  AMap.Raw.map (option_map f) (rev l) =
  rev (AMap.Raw.map (option_map f) l).
Proof.
  induction l; simpl; auto.
  rewrite AMap_Raw_map_app. simpl. destruct a.
  rewrite IHl. auto.
Qed.

Lemma A2PMap_option_map {A} (m : AMap.t (option A)) (f : A -> A) :
  A2PMap (AMap.map (option_map f) m) = A2PMap m.
Proof.
  destruct m as [l sorted].
  unfold A2PMap in *.
  do 2 rewrite <-fold_left_rev_right.
  unfold AMap.elements in *.
  unfold AMap.map in *.
  unfold AMap.Raw.elements in *.
  simpl AMap.this.
  clear sorted.
  unfold AMap.Raw.t in *.
  rewrite <-AMap_Raw_map_rev.
  induction (rev l). reflexivity.
  simpl in *. rewrite <-IHl0.
  destruct a. reflexivity.
Qed.

Lemma AMap_map_add {A B} (f : A -> B) m x y :
  AMap.Equal
    (AMap.map f (AMap.add x y m))
    (AMap.add x (f y) (AMap.map f m)).
Proof.
  intros k.
  rewrite AMap_find_map_option_map.
  rewrite AMap_find_add.
  rewrite AMap_find_add.
  rewrite AMap_find_map_option_map.
  destruct (AMap.find (elt:=A) k m); destruct (eq_dec x k); auto.
Qed.

Lemma AMap_Raw_add_fold_left A (EQ : A -> A -> Prop) B f k (x : B) l (e : A) :
  (forall e, EQ e e) ->
  (forall e e', EQ e e' -> EQ e' e) ->
  (forall e e' e'', EQ e e' -> EQ e' e'' -> EQ e e'') ->
  (forall a e e', EQ e e' -> EQ (f e a) (f e' a)) ->
  (forall a b e, fst a = fst b -> EQ (f (f e a) b) (f e a)) ->
  (forall a b e, EQ (f (f e a) b) (f (f e b) a)) ->
  EQ
    (fold_left f (AMap.Raw.add k x l) e)
    (fold_left f ((k, x) :: l) e).
Proof.
  intros re sy tr congr idem comm.
  assert (congr' : forall l e e', EQ e e' -> EQ (fold_left f l e) (fold_left f l e')). {
    clear -congr; intros l; induction l; intros e e' E.
    - apply E.
    - apply IHl, congr, E.
  }
  revert e. induction l; intros e. apply re. simpl.
  destruct a as (k', y).
  destruct (AddressOrdered.compare k k').
  - apply re.
  - simpl. apply congr'. apply sy. apply idem. assumption.
  - simpl. eapply tr. apply IHl. simpl. apply congr'. apply comm.
Qed.

Require Import Coq.Sorting.Permutation.

Lemma AMap_Raw_add_fold_left_permut A (EQ : A -> A -> Prop) B f (l l' : list B) (e : A) :
  (forall e, EQ e e) ->
  (forall e e', EQ e e' -> EQ e' e) ->
  (forall e e' e'', EQ e e' -> EQ e' e'' -> EQ e e'') ->
  (forall a e e', EQ e e' -> EQ (f e a) (f e' a)) ->
  (forall a b e, EQ (f (f e a) b) (f (f e b) a)) ->
  Permutation l l' ->
  EQ
    (fold_left f l e)
    (fold_left f l' e).
Proof.
  intros re sy tr congr comm permut.
  assert (congr' : forall l e e', EQ e e' -> EQ (fold_left f l e) (fold_left f l e')). {
    clear -congr; intros l; induction l; intros e e' E.
    - apply E.
    - apply IHl, congr, E.
  }
  revert e. induction permut; intros e.
  - apply re.
  - apply IHpermut.
  - simpl. eapply tr. apply congr'. 2:apply re. apply comm.
  - eapply tr. apply IHpermut1. apply IHpermut2.
Qed.

Lemma AMap_Raw_add_fold_left_right A (EQ : A -> A -> Prop) B f (l : list B) (e : A) :
  (forall e, EQ e e) ->
  (forall e e', EQ e e' -> EQ e' e) ->
  (forall e e' e'', EQ e e' -> EQ e' e'' -> EQ e e'') ->
  (forall a e e', EQ e e' -> EQ (f e a) (f e' a)) ->
  (forall a b e, EQ (f (f e a) b) (f (f e b) a)) ->
  EQ
    (fold_left f l e)
    (fold_right (fun x y => f y x) e l).
Proof.
  intros re sy tr congr comm.
  replace l with (rev (rev l)) at 2. 2:apply rev_involutive.
  rewrite fold_left_rev_right.
  apply AMap_Raw_add_fold_left_permut; auto.
  apply Permutation_rev.
Qed.

Lemma setPerm_b_comm o b ofs1 ofs2 t :
  setPerm o b ofs1 (setPerm o b ofs2 t) =
  setPerm o b ofs2 (setPerm o b ofs1 t).
Proof.
  unfold setPerm. do 2 rewrite PMap.set2. f_equal.
  extensionality z. do 2 rewrite PMap.gsspec.
  destruct (zeq ofs1 z); destruct (zeq ofs2 z); simpl.
  - auto.
  - if_tac. 2:tauto. destruct (zeq ofs1 z); simpl; auto. tauto.
  - if_tac. 2:tauto. destruct (zeq ofs2 z); simpl; auto. tauto.
  - if_tac. 2:tauto. destruct (zeq ofs2 z); simpl; auto. tauto.
    destruct (zeq ofs1 z); simpl; auto. tauto.
Qed.

Lemma setPerm_b_idem o b ofs t :
  setPerm o b ofs (setPerm o b ofs t) =
  setPerm o b ofs t.
Proof.
  unfold setPerm. rewrite PMap.set2. f_equal.
  extensionality z. rewrite PMap.gsspec.
  destruct (zeq ofs z); simpl; auto. if_tac. 2:tauto. destruct (zeq ofs z); auto. tauto.
Qed.

Definition PMap_eq {A} (m m' : PMap.t (Z -> A)) := forall b' ofs', m !! b' ofs' = m' !! b' ofs'.

Lemma PMap_eq_refl {A} : reflexive _ (@PMap_eq A). intros f g. reflexivity. Qed.
Lemma PMap_eq_sym {A} : symmetric _ (@PMap_eq A). intros f g. unfold PMap_eq; symmetry; auto. Qed.
Lemma PMap_eq_trans {A} : transitive _ (@PMap_eq A). intros ? ? ? E E' ? ?. rewrite E, E'. auto. Qed.

Definition A2P {A} :=
 (fun (pmap : access_map) (a : address * A) =>
      let (a0, _) := a in let (b0, ofs0) := a0 in setPermBlock (Some Writable) b0 ofs0 pmap LKSIZE_nat).

Lemma A2P_congr A e e' a : PMap_eq e e' -> PMap_eq (A2P e a) (@A2P A e' a).
Proof.
  destruct a as ((b_, ofs_), a). intros E b'' ofs''. simpl. unfold setPerm.
  repeat rewrite PMap.gsspec.
  destruct (peq b'' b_) as [-> | ne]. destruct (peq b_ b_); [ | tauto]. 2:now auto.
  repeat match goal with |- (if ssrbool.is_left ?A then _ else _) = _ =>  destruct A; simpl; auto end.
Qed.

Lemma A2P_overwrite A : forall a b e, fst a = fst b -> PMap_eq (@A2P A (A2P e a) b) (@A2P A e a).
Proof.
  intros ((b1, ofs1), x1) (k2, x2) e; simpl. intros <- b'' ofs''.
  f_equal.
 repeat
 match goal with |- setPerm _ _ ?A _ = _ =>
     repeat rewrite (setPerm_b_comm _ _ _ A); rewrite setPerm_b_idem; f_equal
  end.
Qed.

Lemma setPerm_comm b1 o1 b2 o2 e:
  PMap_eq (setPerm (Some Writable) b1 o1 (setPerm (Some Writable) b2 o2 e))
          (setPerm (Some Writable) b2 o2 (setPerm (Some Writable) b1 o1 e)).
Proof.
  intros b' o'.
  unfold setPerm in *.
  repeat rewrite PMap.gsspec.
  destruct (peq b1 b2) as [B|B];
  destruct (peq b2 b1) as [B'|B']; try tauto;
  destruct (peq b' b1) as [B1|B1];
  destruct (peq b' b2) as [B2|B2];
  destruct (zeq o1 o') as [O1|O1];
  destruct (zeq o2 o') as [O2|O2]; simpl; auto; congruence.
Qed.

Lemma setPerm_congr b o e e':
  PMap_eq e e' ->
  PMap_eq (setPerm (Some Writable) b o e)
          (setPerm (Some Writable) b o e').
Proof.
  intros E b' o'; simpl.
  unfold setPerm in *.
  repeat rewrite PMap.gsspec.
  if_tac; destruct (zeq o o'); simpl. auto.
  all: rewrite E; auto.
Qed.

Lemma A2P_comm A e a b : PMap_eq (@A2P A (A2P e a) b) (@A2P A (A2P e b) a).
Proof.
  destruct a as ((b1, o1), a1), b as ((b2, o2), a2); simpl.

repeat (
 repeat
 ( lazymatch goal with |- PMap_eq (setPerm _ _ (o2 + _) _) _ => idtac end;
   eapply PMap_eq_trans;
 [ repeat  lazymatch goal with
  |- PMap_eq (setPerm _ _ (o2 + _) (setPerm _ _ (o2 + _) _)) _ =>
       apply setPerm_congr
 end;
  apply setPerm_comm |
 ]);
 apply setPerm_congr).
  apply PMap_eq_refl.
Qed.

Lemma fold_right_cons : forall A B (f : A -> B -> B) (z : B) (x : A) (y : list A),
    fold_right f z (x :: y) = f x (fold_right f z y).
Proof. reflexivity. Qed.

Lemma setPerm_spec perm m b ofs b' ofs' :
  (setPerm perm b ofs m) !! b' ofs' =
  if eq_dec (b, ofs) (b', ofs') then
    perm
  else
    m !! b' ofs'.
Proof.
  unfold setPerm. rewrite PMap.gsspec.
  if_tac; destruct (zeq ofs ofs'); simpl; if_tac [?|ne]; try congruence.
  destruct ne; auto.
Qed.

Lemma A2PMap_found A m b ofs ofs' o :
  AMap.find (elt:=A) (b, ofs) m = Some o ->
  (ofs <= ofs' < ofs + 4)%Z ->
  (A2PMap m) !! b ofs' = Some Writable.
Proof.
  unfold AMap.find, A2PMap, AMap.elements, AMap.Raw.elements.
  rewrite (AMap_Raw_add_fold_left_right (PMap.t (Z -> option permission)) PMap_eq).
  2: now apply PMap_eq_refl.
  2: now apply PMap_eq_sym.
  2: now apply PMap_eq_trans.
  2: now intros; eapply A2P_congr; auto.
  2: now intros; eapply A2P_comm; auto.

  induction (@AMap.this A m) as [ | ((b0, ofs0), a) ]; [ discriminate | ].
  simpl (AMap.Raw.find _ _).
  destruct (AddressOrdered.compare (b, ofs) (b0, ofs0)) as [C|C|C].
  - discriminate.
  - injection 1 as <-.
    rewrite fold_right_cons.
    simpl.
    repeat rewrite setPerm_spec.
    repeat (if_tac; auto).
    injection C as <- <- .
    intros r.
    exfalso.
    do 8 match goal with H : (b, ?x) <> (b, ?y) |- _ => assert (x <> y) by (intros <-; tauto); clear H end.
    omega.
  - rewrite fold_right_cons.
    simpl.
    repeat rewrite setPerm_spec.
    repeat (if_tac; auto).
Qed.

Lemma fold_right_rev_left:
  forall (A B: Type) (f: A -> B -> A) (l: list B) (i: A),
  fold_left f l i = fold_right (fun x y => f y x) i (rev l).
Proof.
intros. rewrite fold_left_rev_right.
f_equal; extensionality x y; auto.
Qed.

Lemma A2PMap_add_outside T b b' ofs ofs' set o :
  (@A2PMap T (AMap.add (b, ofs) o set)) !! b' ofs' =
  if adr_range_dec (b, ofs) LKSIZE (b', ofs') then
    Some Writable
  else
    (@A2PMap T set) !! b' ofs'.
Proof.
  unfold A2PMap in *.
  unfold AMap.elements in *.
  unfold AMap.Raw.elements in *.
  unfold AMap.add in *.
  simpl (AMap.this _).

  etransitivity.
  {
    apply (AMap_Raw_add_fold_left _ (fun t t' => forall b' ofs', t !! b' ofs' = t' !! b' ofs')).
    - apply PMap_eq_refl.
    - apply PMap_eq_sym.
    - apply PMap_eq_trans.
    - intros; eapply A2P_congr; auto.
    - intros; eapply A2P_overwrite; auto.
    - intros; eapply A2P_comm; auto.
  }
  assert (P : Permutation ((b, ofs, o) :: AMap.this set) (AMap.this set ++ (b, ofs, o) :: nil)).
  { apply Permutation_cons_append. }
  etransitivity.
  {
    eapply (AMap_Raw_add_fold_left_permut _ (fun t t' => forall b' ofs', t !! b' ofs' = t' !! b' ofs')).
    - apply PMap_eq_refl.
    - apply PMap_eq_sym.
    - apply PMap_eq_trans.
    - intros; eapply A2P_congr; auto.
    - intros; eapply A2P_comm; auto.
    - apply P.
  }
  remember (AMap.this set) as l. clear set Heql.
  do 2 rewrite fold_right_rev_left.
  rewrite rev_app_distr. simpl (app _ _).
  remember (rev l) as l'; clear l Heql' P.
  rewrite (* canon. *)fold_right_cons.
  set (fold_right _ _ _) as m; clearbody m; clear.
  simpl.
  unfold setPerm in *.
  repeat rewrite PMap.gsspec.
  if_tac [->|ne]; swap 1 2.
  { if_tac. destruct H. congruence. reflexivity. }
  destruct (peq b b). 2:tauto.
 repeat
 lazymatch goal with |- context [zeq ?A ?B] =>
   destruct (zeq A B) as [<- | ?]; simpl;
    [if_tac; auto; destruct H; split; auto; unfold LKSIZE; omega | ]
 end.
  if_tac; auto. destruct H. unfold LKSIZE in H0. omega.
Qed.

Lemma find_too_small A y a x l :
  (AddressOrdered.lt y a \/ AddressOrdered.eq y a) ->
  Sorted (AMap.Raw.PX.ltk (elt:=A)) l ->
  HdRel (AMap.Raw.PX.ltk (elt:=A)) (a, x) l ->
  AMap.Raw.find (elt:=A) y l = None.
Proof.
  intros toosmall.
  induction l as [ | [b z] l]; auto.
  intros sorted below.
  inversion below as [ | b0 l0 Hab H ]; subst.
  change (AddressOrdered.lt a b) in Hab.
  simpl.
  destruct (AddressOrdered.compare y b).
  - reflexivity.
  - exfalso.
    destruct toosmall as [t|t].
    + pose proof AddressOrdered.lt_trans t Hab.
      eapply AddressOrdered.lt_not_eq; eauto.
    + hnf in t. subst.
      eapply AddressOrdered.lt_not_eq; eauto.
  - apply IHl; auto.
    inv sorted; eauto.
    inv sorted; eauto.
    eapply AMap.Raw.PX.Inf_lt; eauto.
    simpl; auto.
Qed.

Lemma sorted_find A a x l l'
      (sorted : Sorted (AMap.Raw.PX.ltk (elt:=A)) ((a, x) :: l))
      (sorted' : Sorted (AMap.Raw.PX.ltk (elt:=A)) ((a, x) :: l')) :
  (forall y : AMap.key,
      AMap.Raw.find (elt:=A) y ((a, x) :: l) =
      AMap.Raw.find (elt:=A) y ((a, x) :: l')) ->
  forall y : AMap.key,
    AMap.Raw.find (elt:=A) y l =
    AMap.Raw.find (elt:=A) y l'.
Proof.
  intros E.
  inversion sorted as [ | a0 l0 S B ]; subst. clear sorted.
  inversion sorted' as [ | a0 l0 S' B' ]; subst. clear sorted'.
  intros y; specialize (E y).
  simpl in E.
  destruct (AddressOrdered.compare y a).
  - erewrite find_too_small; eauto.
    erewrite find_too_small; eauto.
  - erewrite find_too_small; eauto.
    erewrite find_too_small; eauto.
  - auto.
Qed.

Lemma AMap_Equal_PMap_eq {A} m m' : AMap.Equal m m' -> @A2PMap A m = @A2PMap A m'.
Proof.
  intros E.
  unfold A2PMap in *.
  f_equal.
  unfold AMap.elements in *.
  destruct m as [l sorted], m' as [l' sorted']; simpl in *.
  unfold AMap.Equal in *.
  unfold AMap.find in *.
  unfold AMap.Raw.elements in *.
  simpl in *.
  revert l' sorted' E.
  induction l as [ | [a x] l]; intros l' sorted' E.
  - destruct l' as [ | [a' x] l']; auto. exfalso.
    specialize (E a'). simpl in E.
    destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a')) as [p R]. rewrite R in E.
    discriminate.
  - destruct l' as [ | [a' x'] l'].
    + specialize (E a). simpl in E.
      destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a)) as [p R]. rewrite R in E.
      discriminate.
    + assert (Ea : a = a' /\ x = x'). {
        pose (E a) as Ea. simpl in Ea.
        destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a)) as [p R]. rewrite R in Ea.
        pose (E a') as Ea'. simpl in Ea'.
        destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a')) as [p' R']. rewrite R' in Ea'.
        destruct (AddressOrdered.compare a a') eqn:Ec; try (split; congruence).
        destruct (AddressOrdered.compare a' a) eqn:Ec'; try (split; congruence).
        exfalso. eapply (@AddressOrdered.lt_not_eq a' a); eauto.
        exfalso. eapply (@AddressOrdered.lt_not_eq a a); auto.
        eapply AddressOrdered.lt_trans; eauto.
      }
      destruct Ea as [<- <-].
      f_equal.
      apply IHl.
      * inv sorted; auto.
      * inv sorted'; auto.
      * eapply sorted_find; eauto.
Qed.

Lemma AMap_remove_add {A} (m : AMap.t A) x y :
  AMap.find x m = Some y ->
  AMap.Equal m (AMap.add x y (AMap.remove x m)).
Proof.
  intros find.
  intros x'.
  rewrite AMap_find_add, AMap_find_remove.
  if_tac.
  - subst x'. auto.
  - reflexivity.
Qed.


Require Import Crypto.Spec.WeierstrassCurve.
Require Import Crypto.Util.Decidable Crypto.Algebra.Field.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.SetoidSubst.
Require Import Crypto.Util.Notations Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Sum Crypto.Util.Prod Crypto.Util.Sigma.

Module Projective.
  Section Projective.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {a b:F}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos (BinNat.N.two))}
            {Feq_dec:DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "-" := Fsub.
    Local Infix "*" := Fmul. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x). Local Notation "x ^ 3" := (x*x^2).
    Local Notation Wpoint := (@W.point F Feq Fadd Fmul a b).

    (* Originally from
    <http://www.mat.uniroma3.it/users/pappa/CORSI/CR510_13_14/BosmaLenstra.pdf>
    "Commplete Systems of Addition Laws" by Bosma and Lenstra;
    optimized in <https://eprint.iacr.org/2015/1060.pdf> "Complete
    addition formulas for prime order elliptic curves" Algorithm 1
    "Complete, projective point addition for arbitrary prime order
    short Weierstrass curves" by Joost Renes, Craig Costello, and
    Lejla Batina. *)

    Ltac t :=
      repeat match goal with
             | _ => solve [ discriminate | contradiction | trivial ]
             | _ => progress cbv zeta
             | _ => progress intros
             | _ => progress destruct_head' @W.point
             | _ => progress destruct_head' sum
             | _ => progress destruct_head' prod
             | _ => progress destruct_head' unit
             | _ => progress destruct_head' and
             | _ => progress specialize_by assumption
             | _ => progress cbv [W.eq W.add W.coordinates proj1_sig] in *
             | _ => progress break_match_hyps
             | _ => progress break_match
             | |- _ /\ _ => split | |- _ <-> _ => split
             | [H:~ _ <> _ |- _ ] => rewrite (not_not (_ = _)) in H
             | [H: not ?P, G: ?P -> _ |- _ ] => clear G
             | [H: ?P, G: not ?P -> _ |- _ ] => clear G
             | [H: ?x = ?x |- _ ] => clear H
             | [H: True |- _ ] => clear H
             end.

    Definition point : Type := { P : F*F*F | let '(X,Y,Z) := P in Y^2*Z = X^3 + a*X*Z^2 + b*Z^3 /\ (Z = 0 -> Y <> 0) }.

    Program Definition to_affine (P:point) : Wpoint :=
      match proj1_sig P return F*F+_ with
      | (X, Y, Z) =>
        if dec (Z = 0) then inr tt
        else inl (X/Z, Y/Z)
      end.
    Next Obligation. Proof. t. fsatz. Qed.

    Program Definition of_affine (P:Wpoint) : point :=
      match W.coordinates P return F*F*F with
      | inl (x, y) => (x, y, 1)
      | inr _ => (0, 1, 0)
      end.
    Next Obligation. Proof. t; fsatz. Qed.

    Definition eq (P Q:point) : Prop :=
      match proj1_sig P, proj1_sig Q with
      | (X1, Y1, Z1), (X2, Y2, Z2) =>
        if dec (Z1 = 0) then Z2 = 0
        else if dec (Z2 = 0) then False
             else X1*Z2 = X2*Z1 /\ Y1*Z2 = Y2*Z1
      end.

    Lemma eq_iff_Weq P Q : eq P Q <-> W.eq (to_affine P) (to_affine Q).
    Proof.
      cbv [W.eq eq to_affine] in *; t; specialize_by_assumption; fsatz.
    Qed.

    Program Definition opp (P:point) : point :=
      match proj1_sig P return F*F*F with
      | (X, Y, Z) => (X, Fopp Y, Z)
      end.
    Next Obligation. Proof. t; fsatz. Qed.

    Context (three_b:F) (three_b_correct: three_b = b+b+b).
    Local Notation "4" := (1+1+1+1). Local Notation "27" := (4*4 + 4+4 +1+1+1).
    Context {discriminant_nonzero: id(4*a*a*a + 27*b*b <> 0)}.

    Let not_exceptional_y (P Q:point) :=
      match W.coordinates (W.add (to_affine P) (to_affine (opp Q))) return Prop with
      | inr _ => True
      | inl (_, y) => y <> 0
      end.

    Global Instance DecidableRel_not_exceptional_y : DecidableRel not_exceptional_y.
    Proof.
      cbv [not_exceptional_y]; intros; break_match; exact _.
    Defined.

    Lemma exceptional_P_neq_Q P Q (H:~not_exceptional_y P Q) :
      ~ W.eq (to_affine P) (to_affine Q).
    Proof using three_b_correct three_b.
      destruct P as [p ?]; destruct p as [p Z1]; destruct p as [X1 Y1].
      destruct Q as [q ?]; destruct q as [q Z2]; destruct q as [X2 Y2].
      cbv [not_exceptional_y opp to_affine] in *; clear not_exceptional_y.
      t; try exact id.
      all: repeat match goal with
                    [H:~ _ <> _ |- _ ] => rewrite (not_not (_ = _)) in H
                  end.
      all: intro HX; destruct HX; fsatz.
    Qed.

    Import BinPos.
    Context {char_ge_21 : @Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 21}.
    Lemma exceptional_2P_eq_2Q P Q (H:~not_exceptional_y P Q) :
      W.eq
        (W.add (to_affine P) (to_affine P))
        (W.add (to_affine Q) (to_affine Q)).
    Proof using three_b_correct three_b discriminant_nonzero char_ge_21 .
      destruct P as [p ?]; destruct p as [p Z1]; destruct p as [X1 Y1].
      destruct Q as [q ?]; destruct q as [q Z2]; destruct q as [X2 Y2].
      cbv [not_exceptional_y opp to_affine] in *; clear not_exceptional_y.
      t.
      par: abstract solve [ fsatz | cbv [id] in * ; fsatz ].
   Qed.

    Definition not_exceptional P Q :=
      let p := to_affine P in
      let q := to_affine Q in
      (W.eq (W.add p p) (W.add q q) -> W.eq p q).
    Lemma not_exceptional_y_of_not_exceptional P Q
       : not_exceptional P Q -> not_exceptional_y P Q.
    Proof.
      cbv [not_exceptional].
      pose proof exceptional_2P_eq_2Q P Q.
      pose proof exceptional_P_neq_Q P Q.
      intro Himpl.
      rewrite <-not_not by typeclasses eauto.
      intuition trivial.
    Qed.

    Program Definition add (P Q:point) (except: not_exceptional P Q) : point :=
      match proj1_sig P, proj1_sig Q return F*F*F with (X1, Y1, Z1), (X2, Y2, Z2) =>
        let t0 := X1*X2 in
        let t1 := Y1*Y2 in
        let t2 := Z1*Z2 in
        let t3 := X1+Y1 in
        let t4 := X2+Y2 in
        let t3 := t3*t4 in
        let t4 := t0+t1 in
        let t3 := t3-t4 in
        let t4 := X1+Z1 in
        let t5 := X2+Z2 in
        let t4 := t4*t5 in
        let t5 := t0+t2 in
        let t4 := t4-t5 in
        let t5 := Y1+Z1 in
        let X3 := Y2+Z2 in
        let t5 := t5*X3 in
        let X3 := t1+t2 in
        let t5 := t5-X3 in
        let Z3 := a*t4 in
        let X3 := three_b*t2 in
        let Z3 := X3+Z3 in
        let X3 := t1-Z3 in
        let Z3 := t1+Z3 in
        let Y3 := X3*Z3 in
        let t1 := t0+t0 in
        let t1 := t1+t0 in
        let t2 := a*t2 in
        let t4 := three_b*t4 in
        let t1 := t1+t2 in
        let t2 := t0-t2 in
        let t2 := a*t2 in
        let t4 := t4+t2 in
        let t0 := t1*t4 in
        let Y3 := Y3+t0 in
        let t0 := t5*t4 in
        let X3 := t3*X3 in
        let X3 := X3-t0 in
        let t0 := t3*t1 in
        let Z3 := t5*Z3 in
        let Z3 := Z3+t0 in
        (X3, Y3, Z3)
      end.
    Next Obligation.
    Proof using three_b three_b_correct discriminant_nonzero char_ge_21.
      apply not_exceptional_y_of_not_exceptional in except.
      cbv [not_exceptional_y to_affine opp] in except. clear not_exceptional_y.
      destruct P as [p ?]; destruct p as [p Z1]; destruct p as [X1 Y1].
      destruct Q as [q ?]; destruct q as [q Z2]; destruct q as [X2 Y2].
      t.
      par: abstract solve [ fsatz | cbv [id] in * ; fsatz ].
    Qed.

    Lemma to_affine_add P Q except :
      W.eq
        (to_affine (add P Q except))
        (WeierstrassCurve.W.add (to_affine P) (to_affine Q)).
    Proof using Type.
      destruct P as [p ?]; destruct p as [p Z1]; destruct p as [X1 Y1].
      destruct Q as [q ?]; destruct q as [q Z2]; destruct q as [X2 Y2].
      pose proof (not_exceptional_y_of_not_exceptional _ _ except).
      cbv [not_exceptional_y opp to_affine add] in *; t;
        clear except not_exceptional_y;
        specialize_by_assumption.
      all: try abstract fsatz.

      (* zero + P = P   -- cases for x and y *)
      { assert (X1 = 0) by (setoid_subst_rel Feq; Nsatz.nsatz_power 3%nat); t; fsatz. }
      { assert (X1 = 0) by (setoid_subst_rel Feq; Nsatz.nsatz_power 3%nat); t; fsatz. }

      (* P  + zero = P   -- cases for x and y *)
      { assert (X2 = 0) by (setoid_subst_rel Feq; Nsatz.nsatz_power 3%nat); t; fsatz. }
      { assert (X2 = 0) by (setoid_subst_rel Feq; Nsatz.nsatz_power 3%nat); t; fsatz. }
    Qed.
  End Projective.
End Projective.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file is deprecated, for a tree on list, use [Mergesort.v]. *)

(** A development of Treesort on Heap trees. It has an average
    complexity of O(n.log n) but of O(n²) in the worst case (e.g. if
    the list is already sorted) *)

(* G. Huet 1-9-95 uses Multiset *)

Require Import List Multiset PermutSetoid Relations Sorting.

Section defs.

  (** * Trees and heap trees *)

  (** ** Definition of trees over an ordered set *)

  Variable A : Type.
  Variable leA : relation A.
  Variable eqA : relation A.

  Let gtA (x y:A) := ~ leA x y.

  Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
  Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
  Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
  Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.

  Hint Resolve leA_refl.
  Hint Immediate eqA_dec leA_dec leA_antisym.

  Let emptyBag := EmptyBag A.
  Let singletonBag := SingletonBag _ eqA_dec.

  Inductive Tree :=
    | Tree_Leaf : Tree
    | Tree_Node : A -> Tree -> Tree -> Tree.

  (** [a] is lower than a Tree [T] if [T] is a Leaf
      or [T] is a Node holding [b>a] *)

  Definition leA_Tree (a:A) (t:Tree) :=
    match t with
      | Tree_Leaf => True
      | Tree_Node b T1 T2 => leA a b
    end.

  Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf.
  Proof.
    simpl; auto with datatypes.
  Qed.

  Lemma leA_Tree_Node :
    forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D).
  Proof.
    simpl; auto with datatypes.
  Qed.

  (** ** The heap property *)

  Inductive is_heap : Tree -> Prop :=
    | nil_is_heap : is_heap Tree_Leaf
    | node_is_heap :
      forall (a:A) (T1 T2:Tree),
        leA_Tree a T1 ->
        leA_Tree a T2 ->
        is_heap T1 -> is_heap T2 -> is_heap (Tree_Node a T1 T2).

  Lemma invert_heap :
    forall (a:A) (T1 T2:Tree),
      is_heap (Tree_Node a T1 T2) ->
      leA_Tree a T1 /\ leA_Tree a T2 /\ is_heap T1 /\ is_heap T2.
  Proof.
    intros; inversion H; auto with datatypes.
  Qed.

  (* This lemma ought to be generated automatically by the Inversion tools *)
  Lemma is_heap_rect :
    forall P:Tree -> Type,
      P Tree_Leaf ->
      (forall (a:A) (T1 T2:Tree),
	leA_Tree a T1 ->
	leA_Tree a T2 ->
	is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
      forall T:Tree, is_heap T -> P T.
  Proof.
    simple induction T; auto with datatypes.
    intros a G PG D PD PN.
    elim (invert_heap a G D); auto with datatypes.
    intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
    apply X0; auto with datatypes.
  Qed.

  (* This lemma ought to be generated automatically by the Inversion tools *)
  Lemma is_heap_rec :
    forall P:Tree -> Set,
      P Tree_Leaf ->
      (forall (a:A) (T1 T2:Tree),
	leA_Tree a T1 ->
	leA_Tree a T2 ->
	is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
      forall T:Tree, is_heap T -> P T.
  Proof.
    simple induction T; auto with datatypes.
    intros a G PG D PD PN.
    elim (invert_heap a G D); auto with datatypes.
    intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
    apply X; auto with datatypes.
  Qed.

  Lemma low_trans :
    forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T.
  Proof.
    simple induction T; auto with datatypes.
    intros; simpl; apply leA_trans with b; auto with datatypes.
  Qed.

  (** ** Merging two sorted lists *)

  Inductive merge_lem (l1 l2:list A) : Type :=
    merge_exist :
    forall l:list A,
      Sorted leA l ->
      meq (list_contents _ eqA_dec l)
      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
      (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) ->
      merge_lem l1 l2.
  Import Morphisms.

  Instance: Equivalence (@meq A).
  Proof. constructor; auto with datatypes. red. apply meq_trans. Defined.

  Instance: Proper (@meq A ++> @meq _ ++> @meq _) (@munion A).
  Proof. intros x y H x' y' H'. now apply meq_congr. Qed.

  Lemma merge :
    forall l1:list A, Sorted leA l1 ->
    forall l2:list A, Sorted leA l2 -> merge_lem l1 l2.
  Proof.
    fix merge 1; intros; destruct l1.
    apply merge_exist with l2; auto with datatypes.
    rename l1 into l.
    revert l2 H0. fix merge0 1. intros.
    destruct l2 as [|a0 l0].
    apply merge_exist with (a :: l); simpl; auto with datatypes.
    induction (leA_dec a a0) as [Hle|Hle].

    (* 1 (leA a a0) *)
    apply Sorted_inv in H. destruct H.
    destruct (merge l H (a0 :: l0) H0) as [l1 H2 H3 H4].
    apply merge_exist with (a :: l1). clear merge merge0.
      auto using cons_sort, cons_leA with datatypes.
    simpl. rewrite H3. now rewrite munion_ass.
    intros. apply cons_leA.
    apply (@HdRel_inv _ leA) with l; trivial with datatypes.

    (* 2 (leA a0 a) *)
    apply Sorted_inv in H0. destruct H0.
    destruct (merge0 l0 H0) as [l1 H2 H3 H4]. clear merge merge0.
    apply merge_exist with (a0 :: l1);
      auto using cons_sort, cons_leA with datatypes.
    simpl; rewrite H3. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm.
    repeat rewrite munion_ass. setoid_rewrite munion_comm at 3. reflexivity.
    intros. apply cons_leA.
    apply (@HdRel_inv _ leA) with l0; trivial with datatypes.
  Qed.

  (** ** From trees to multisets *)

  (** contents of a tree as a multiset *)

  (** Nota Bene : In what follows the definition of SingletonBag
      in not used. Actually, we could just take as postulate:
      [Parameter SingletonBag : A->multiset].  *)

  Fixpoint contents (t:Tree) : multiset A :=
    match t with
      | Tree_Leaf => emptyBag
      | Tree_Node a t1 t2 =>
	munion (contents t1) (munion (contents t2) (singletonBag a))
    end.

  (** equivalence of two trees is equality of corresponding multisets *)
  Definition equiv_Tree (t1 t2:Tree) := meq (contents t1) (contents t2).

  (** * From lists to sorted lists *)

  (** ** Specification of heap insertion *)

  Inductive insert_spec (a:A) (T:Tree) : Type :=
    insert_exist :
    forall T1:Tree,
      is_heap T1 ->
      meq (contents T1) (munion (contents T) (singletonBag a)) ->
      (forall b:A, leA b a -> leA_Tree b T -> leA_Tree b T1) ->
      insert_spec a T.

  Lemma insert : forall T:Tree, is_heap T -> forall a:A, insert_spec a T.
  Proof.
    simple induction 1; intros.
    apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf);
      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    simpl; unfold meq, munion; auto using node_is_heap with datatypes.
    elim (leA_dec a a0); intros.
    elim (X a0); intros.
    apply insert_exist with (Tree_Node a T2 T0);
      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    simpl; apply treesort_twist1; trivial with datatypes.
    elim (X a); intros T3 HeapT3 ConT3 LeA.
    apply insert_exist with (Tree_Node a0 T2 T3);
      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
    apply low_trans with a; auto with datatypes.
    apply LeA; auto with datatypes.
    apply low_trans with a; auto with datatypes.
    simpl; apply treesort_twist2; trivial with datatypes.
  Qed.

  (** ** Building a heap from a list *)

  Inductive build_heap (l:list A) : Type :=
    heap_exist :
    forall T:Tree,
      is_heap T ->
      meq (list_contents _ eqA_dec l) (contents T) -> build_heap l.

  Lemma list_to_heap : forall l:list A, build_heap l.
  Proof.
    simple induction l.
    apply (heap_exist nil Tree_Leaf); auto with datatypes.
    simpl; unfold meq; exact nil_is_heap.
    simple induction 1.
    intros T i m; elim (insert T i a).
    intros; apply heap_exist with T1; simpl; auto with datatypes.
    apply meq_trans with (munion (contents T) (singletonBag a)).
    apply meq_trans with (munion (singletonBag a) (contents T)).
    apply meq_right; trivial with datatypes.
    apply munion_comm.
    apply meq_sym; trivial with datatypes.
  Qed.

  (** ** Building the sorted list *)

  Inductive flat_spec (T:Tree) : Type :=
    flat_exist :
    forall l:list A,
      Sorted leA l ->
      (forall a:A, leA_Tree a T -> HdRel leA a l) ->
      meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T.

  Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T.
  Proof.
    intros T h; elim h; intros.
    apply flat_exist with (nil (A:=A)); auto with datatypes.
    elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2.
    elim (merge _ s1 _ s2); intros.
    apply flat_exist with (a :: l); simpl; auto with datatypes.
    apply meq_trans with
      (munion (list_contents _ eqA_dec l1)
	(munion (list_contents _ eqA_dec l2) (singletonBag a))).
    apply meq_congr; auto with datatypes.
    apply meq_trans with
      (munion (singletonBag a)
	(munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2))).
    apply munion_rotate.
    apply meq_right; apply meq_sym; trivial with datatypes.
  Qed.

  (** * Specification of treesort *)

  Theorem treesort :
    forall l:list A,
    {m : list A | Sorted leA m & permutation _ eqA_dec l m}.
  Proof.
    intro l; unfold permutation.
    elim (list_to_heap l).
    intros.
    elim (heap_to_list T); auto with datatypes.
    intros.
    exists l0; auto with datatypes.
    apply meq_trans with (contents T); trivial with datatypes.
  Qed.

End defs.


(** test the elpi plugin by tassi on nested inductive types **)

From elpi Require Import derive.

Elpi derive nat.
Elpi derive list.

Print list_is_list.
Print list_is_list_full. (* is proof *)
Print list_is_list_trivial.
Print list_induction.

(* Goal forall A (xs:list A), xs=nil.
Proof.
    intros A xs.
    elim xs using list_induction.
    eapply list_induction.
    induction xs using list_induction. *)

(*
Comment = could not be generated
there were many universe errors
and some principles took very look

TODO:
compare rT5 with PI2
compare PI2 with PI3
 *)
Require Import nested_datatypes.

Inductive brtree A : nat -> Type :=
| Leaf (a : A) : brtree A 0
| Node (n : nat) (l : list (brtree A n)) : brtree A (S n).

Elpi derive brtree.
Check brtree_is_brtree.
(* Check brtree_is_brtree_full. *)
(* Check brtree_is_brtree_trivial. *)
Check brtree_induction.

Print rtree.
Elpi derive rtree.
Check rtree_is_rtree.
Check rtree_is_rtree_full.
Check rtree_is_rtree_trivial.
Check rtree_induction.

Print roseTree.
Elpi derive roseTree.
Check roseTree_is_roseTree.
Check roseTree_is_roseTree_full.
Check roseTree_is_roseTree_trivial.
Check roseTree_induction.

Print roseTree2.
Elpi derive roseTree2.
Check roseTree2_is_roseTree2.
Check roseTree2_is_roseTree2_full.
Check roseTree2_is_roseTree2_trivial.
Check roseTree2_induction.

Print roseTree3.
Elpi derive roseTree3.
Check roseTree3_is_roseTree3.
Check roseTree3_is_roseTree3_full.
Check roseTree3_is_roseTree3_trivial.
Check roseTree3_induction.

Elpi derive eq.

Print roseTree4.
Elpi derive roseTree4.
Check roseTree4_is_roseTree4.
Check roseTree4_is_roseTree4_full.
(* Check roseTree4_is_roseTree4_trivial. *)
Check roseTree4_induction.

Print roseTree5.
(* Elpi derive roseTree5. *)
(* Check roseTree5_is_roseTree5. *)
(* Check roseTree5_is_roseTree5_full. *)
(* Check roseTree5_is_roseTree5_trivial. *)
(* Check roseTree5_induction. *)

(* Elpi derive le. *)

Inductive Idx : nat -> Type :=
| C_I : Idx 0.
Print Idx_ind.

Elpi derive Idx.
Check Idx_is_Idx.
(* Check Idx_is_Idx_full. *)
(* Check Idx_is_Idx_trivial. *)
Check Idx_induction.

Elpi derive bool.
Check bool_induction.

(* Print VectorDef.t.
Elpi derive VectorDef.t.
Check t_is_t.
(* Check t_is_t_full. *)
(* Check t_is_t_trivial. *)
Check t_induction. *)

Print roseTree6.
Elpi derive roseTree6.
Check roseTree6_is_roseTree6.
(* Check roseTree6_is_roseTree6_full. *)
(* Check roseTree6_is_roseTree6_trivial. *)
Check roseTree6_induction.

(* Print le. *)
(* Elpi derive le. *)

Print roseTreePI1.
Elpi derive roseTreePI1.
Check roseTreePI1_is_roseTreePI1.
Check roseTreePI1_is_roseTreePI1_full.
Check roseTreePI1_is_roseTreePI1_trivial.
Check roseTreePI1_induction.

Print roseTreePI2.
Elpi derive roseTreePI2.
Check roseTreePI2_is_roseTreePI2.
(* Check roseTreePI2_is_roseTreePI2_full. *)
(* Check roseTreePI2_is_roseTreePI2_trivial. *)
Check roseTreePI2_induction.

Print roseTreePI3.
Elpi derive roseTreePI3.
Check roseTreePI3_is_roseTreePI3.
(* Check roseTreePI3_is_roseTreePI3_full. *)
(* Check roseTreePI3_is_roseTreePI3_trivial. *)
Check roseTreePI3_induction.

Print roseTreePI4.
Elpi derive roseTreePI4.
Check roseTreePI4_is_roseTreePI4.
(* Check roseTreePI4_is_roseTreePI4_full. *)
(* Check roseTreePI4_is_roseTreePI4_trivial. *)
Check roseTreePI4_induction.

Print roseTreePI5.
Elpi derive roseTreePI5.
(* Check roseTreePI5_is_roseTreePI5. *)
(* Check roseTreePI5_is_roseTreePI5_full. *)
(* Check roseTreePI5_is_roseTreePI5_trivial. *)
Check roseTreePI5_induction.

Print roseTreePI6.
Elpi derive roseTreePI6.
(* Check roseTreePI6_is_roseTreePI6. *)
(* Check roseTreePI6_is_roseTreePI6_full. *)
(* Check roseTreePI6_is_roseTreePI6_trivial. *)
Check roseTreePI6_induction.

Print roseTreePI7.
Elpi derive roseTreePI7.
Check roseTreePI7_is_roseTreePI7.
(* Check roseTreePI7_is_roseTreePI7_full. *)
(* Check roseTreePI7_is_roseTreePI7_trivial. *)
Check roseTreePI7_induction.

Print roseTreePI8.
Elpi derive roseTreePI8.
Check roseTreePI8_is_roseTreePI8.
(* Check roseTreePI8_is_roseTreePI8_full. *)
(* Check roseTreePI8_is_roseTreePI8_trivial. *)
Check roseTreePI8_induction.

Print roseTreeNN1.
Elpi derive roseTreeNN1.
Check roseTreeNN1_is_roseTreeNN1.
Check roseTreeNN1_is_roseTreeNN1_full.
Check roseTreeNN1_is_roseTreeNN1_trivial.
Check roseTreeNN1_induction.

Print roseTreeNN2.
Elpi derive roseTreeNN2.
Check roseTreeNN2_is_roseTreeNN2.
Check roseTreeNN2_is_roseTreeNN2_full.
Check roseTreeNN2_is_roseTreeNN2_trivial.
Check roseTreeNN2_induction.

Elpi derive prod.
Print prod_is_prod.
Elpi derive VectorDef.t.
Print t_is_t.
Print t_induction.

Print roseTreeNN3.
Elpi derive roseTreeNN3.
Check roseTreeNN3_is_roseTreeNN3.
Check roseTreeNN3_is_roseTreeNN3_full.
Check roseTreeNN3_is_roseTreeNN3_trivial.
Check roseTreeNN3_induction.

Print roseTreeNN4.
Elpi derive roseTreeNN4.
Check roseTreeNN4_is_roseTreeNN4.
Check roseTreeNN4_is_roseTreeNN4_full.
Check roseTreeNN4_is_roseTreeNN4_trivial.
Check roseTreeNN4_induction.

Print roseTreeNN5.
Elpi derive roseTreeNN5.
Check roseTreeNN5_is_roseTreeNN5.
Check roseTreeNN5_is_roseTreeNN5_full.
Check roseTreeNN5_is_roseTreeNN5_trivial.
(* Check roseTreeNN5_induction. *)

Print roseTreeNN6.
Elpi derive roseTreeNN6.
Check roseTreeNN6_is_roseTreeNN6.
(* Check roseTreeNN6_is_roseTreeNN6_full. *)
(* Check roseTreeNN6_is_roseTreeNN6_trivial. *)
Check roseTreeNN6_induction.

Print roseTreeDN1.
Elpi derive roseTreeDN1.
Check roseTreeDN1_is_roseTreeDN1.
Check roseTreeDN1_is_roseTreeDN1_full.
Check roseTreeDN1_is_roseTreeDN1_trivial.
Check roseTreeDN1_induction.

Print roseTreeDN2.
Elpi derive roseTreeDN2.
Check roseTreeDN2_is_roseTreeDN2.
Check roseTreeDN2_is_roseTreeDN2_full.
Check roseTreeDN2_is_roseTreeDN2_trivial.
Check roseTreeDN2_induction.

Print roseTreeDN3.
Elpi derive roseTreeDN3.
Check roseTreeDN3_is_roseTreeDN3.
Check roseTreeDN3_is_roseTreeDN3_full.
Check roseTreeDN3_is_roseTreeDN3_trivial.
Check roseTreeDN3_induction.

Print roseTreeDN4.
(* takes a long time *)
Elpi derive roseTreeDN4.
Check roseTreeDN4_is_roseTreeDN4.
Check roseTreeDN4_is_roseTreeDN4_full.
Check roseTreeDN4_is_roseTreeDN4_trivial.
Check roseTreeDN4_induction.

Print roseTreeDN5.
Elpi derive roseTreeDN5.
Check roseTreeDN5_is_roseTreeDN5.
Check roseTreeDN5_is_roseTreeDN5_full.
Check roseTreeDN5_is_roseTreeDN5_trivial.
Check roseTreeDN5_induction.

Print roseTreeDN6.
(* takes a long time *)
Elpi derive roseTreeDN6.
Check roseTreeDN6_is_roseTreeDN6.
Check roseTreeDN6_is_roseTreeDN6_full.
Check roseTreeDN6_is_roseTreeDN6_trivial.
Check roseTreeDN6_induction.

Print containerInd.
Print containerInd2.
Print containerInd3.

Elpi derive containerInd.
Elpi derive containerInd2.
Elpi derive containerInd3.

Print roseTreeO1.
Elpi derive roseTreeO1.
(* Check roseTreeO1_is_roseTreeO1. *)
(* Check roseTreeO1_is_roseTreeO1_full. *)
(* Check roseTreeO1_is_roseTreeO1_trivial. *)
Check roseTreeO1_induction.

Print roseTreeO2.
Elpi derive roseTreeO2.
Check roseTreeO2_is_roseTreeO2.
Check roseTreeO2_is_roseTreeO2_full.
Check roseTreeO2_is_roseTreeO2_trivial.
Check roseTreeO2_induction.

Print roseTreeO3.
Elpi derive roseTreeO3.
Check roseTreeO3_is_roseTreeO3.
Check roseTreeO3_is_roseTreeO3_full.
Check roseTreeO3_is_roseTreeO3_trivial.
Check roseTreeO3_induction.

Print roseTreeO4.
Elpi derive roseTreeO4.
Check roseTreeO4_is_roseTreeO4.
(* Check roseTreeO4_is_roseTreeO4_full. *)
(* Check roseTreeO4_is_roseTreeO4_trivial. *)
Check roseTreeO4_induction.

Print roseTreeO5.
Elpi derive roseTreeO5.
Check roseTreeO5_is_roseTreeO5.
(* Check roseTreeO5_is_roseTreeO5_full. *)
(* Check roseTreeO5_is_roseTreeO5_trivial. *)
(* Check roseTreeO5_induction. *)

Print roseTreeO6.
Elpi derive roseTreeO6.
Check roseTreeO6_is_roseTreeO6.
(* Check roseTreeO6_is_roseTreeO6_full. *)
(* Check roseTreeO6_is_roseTreeO6_trivial. *)
(* Check roseTreeO6_induction. *)

Print roseTreeO7.
Elpi derive roseTreeO7.
(* Check roseTreeO7_is_roseTreeO7. *)
(* Check roseTreeO7_is_roseTreeO7_full. *)
(* Check roseTreeO7_is_roseTreeO7_trivial. *)
Check roseTreeO7_induction.

Print roseTreeO8.
Elpi derive roseTreeO8.
Check roseTreeO8_is_roseTreeO8.
(* Check roseTreeO8_is_roseTreeO8_full. *)
(* Check roseTreeO8_is_roseTreeO8_trivial. *)
(* Check roseTreeO8_induction. *)

Print roseTreeO9.
Elpi derive roseTreeO9.
Check roseTreeO9_is_roseTreeO9.
(* Check roseTreeO9_is_roseTreeO9_full. *)
(* Check roseTreeO9_is_roseTreeO9_trivial. *)
(* Check roseTreeO9_induction. *)

Print roseTreeO10.
Elpi derive roseTreeO10.
Check roseTreeO10_is_roseTreeO10.
(* Check roseTreeO10_is_roseTreeO10_full. *)
(* Check roseTreeO10_is_roseTreeO10_trivial. *)
Check roseTreeO10_induction.

(* Print Acc. *)
(* Elpi derive Acc. *)
(* Check Acc_induction. *)

Inductive outerGuard := Cog (h:nat -> outerGuard).
Inductive outNestGuard := Cong (h:nat -> list outNestGuard).
Inductive nestGuard := Cng (h:list (nat -> nestGuard)).

Elpi derive outerGuard.
Check outerGuard_induction.
Elpi derive outNestGuard.
Check outNestGuard_induction.
Elpi derive nestGuard.
(* Check nestGuard_induction. *)

Print roseTreeO11.
Elpi derive roseTreeO11.
(* Check roseTreeO11_is_roseTreeO11. *)
(* Check roseTreeO11_is_roseTreeO11_full. *)
(* Check roseTreeO11_is_roseTreeO11_trivial. *)
(* Check roseTreeO11_induction. *)

Inductive deep :=
| H (h:list(list(list(list deep)))).

(* Print Acc.
Elpi derive Acc.
Check Acc_induction. *)

(* Time Elpi derive deep. (* 372.5secs *)
Time Check deep_induction. *)


Set Warnings "-notation-overridden,-parsing".
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype fintype.
From mathcomp Require Import tuple seq fintype bigop ssralg finalg.
From mathcomp Require Import ssrfun choice zmodp fingroup.
From SsrMultinomials Require Import mpoly.
From SsrEllipticCurves Require Import polyall polydec ssrring ecgroup ec.
From Tweetnacl.High Require Import mc.

Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Section MCEC.
  Variable K : ecuFieldType.
  Variable M : mcuType K.

  Lemma ecuType_of_mcuType_discriminant_ok :
    let: a' := (3%:R - (M#a)^+2) / (3%:R * (M#b)^+2) in
    let: b' := (2%:R * (M#a)^+3 - 9%:R * (M#a)) / (27%:R * (M#b)^+3) in
    4%:R * a' ^+ 3 + 27%:R * b' ^+ 2 != 0.
  Proof.
    move: (ecu_chi3 K) (mcu_b_neq0 M) (mcu_asq_neq4 M) => ? ? ?.
    have ->: 4%:R * ((3%:R - (M#a)^+2) / (3%:R * (M#b)^+2))^+3
      + 27%:R * ((2%:R * (M#a) ^+ 3 - 9%:R * M#a) / (27%:R * (M#b)^+3))^+2
      = -((M#a)^+2 - 4%:R) / (M#b)^+6.
      by ssfield; rewrite ?mulf_neq0 ?(@natrX _ 3 3) ?expf_neq0 //.
    by rewrite mulf_neq0 ?oppr_eq0 ?subr_eq0 ?invr_neq0 ?expf_neq0 //.
  Qed.

  Definition ecuType_of_mcuType :=
    let: a' := (3%:R - M#a^+2) / (3%:R * M#b^+2) in
    let: b' := (2%:R * M#a^+3 - 9%:R * M#a) / (27%:R * M#b^+3) in
    (@Build_ecuType K a' b' ecuType_of_mcuType_discriminant_ok).

  Local Notation E := (ecuType_of_mcuType).

  Definition ec_of_mc_point p :=
    match p with
    | ∞ => ∞
    | (|x, y|) => (|x / (M#b) + (M#a) / (3%:R * (M#b)), y / (M#b)|)
    end.

  Lemma ec_of_mc_point_ok p : oncurve M p -> ec.oncurve E (ec_of_mc_point p).
  Proof.
    case: p => //= x y /eqP oc_p.
    have bcube_27_neq0: 27%:R * M#b^+3 != 0.
      apply: mulf_neq0.
      + by rewrite (@natrX _ 3 3) expf_neq0 //; exact: ecu_chi3.
      + by apply: expf_neq0; exact: mcu_b_neq0.
    rewrite addf_div ?mulf_neq0 ?ecu_chi3 ?mcu_b_neq0 // [M#b * _]mulrCA.
    rewrite [x * _]mulrCA mulrA -mulrDl {1 3}mulrCA invfM mulrA.
    rewrite mulfK ?mcu_b_neq0 // [_^+3]expr_div_n [(_*M#b)^+3]exprMn -natrX.
    rewrite mulf_div [_*(3%:R*_)]mulrACA -exprSr -natrM.
    rewrite -[X in _ + X /_ + _](@mulfK _ 3%:R) ?ecu_chi3 // -[_/3%:R/_]mulrA.
    rewrite -invfM [3%:R*(_*_^+3)]mulrA -natrM expnE /= !mulnE /= -!mulrDl.
    apply/eqP/(@mulIf _ (27%:R * M#b^+3)); first by exact: bcube_27_neq0.
    rewrite mulfVK ?bcube_27_neq0 //.
    rewrite mulrCA expr_div_n mulrAC -mulrA -expfB // expr1 [y^+2*_]mulrC oc_p.
    by rewrite !mulr_natr; ssring.
  Qed.

  Definition ec_of_mc p := EC (ec_of_mc_point_ok [oc of p]).

  Definition mc_of_ec_point p :=
    match p with
    | ∞ => ∞
    | (|x, y|) => (|M#b * (x - M#a / (3%:R * M#b)), M#b * y|)
    end.

  Lemma mc_of_ec_point_ok p : ec.oncurve E p -> oncurve M (mc_of_ec_point p).
  Proof.
    case: p => //= x y /eqP H.
    pose neq0 := (mulf_neq0, expf_neq0, @natrX _ 3 3, ecu_chi3, mcu_b_neq0).
    by rewrite exprMn H; apply/eqP; ssfield; rewrite !neq0.
  Qed.

  Definition mc_of_ec p := MC (mc_of_ec_point_ok (oncurve_ec p)).

  Lemma ec_of_mc_pointK : cancel ec_of_mc_point mc_of_ec_point.
  Proof.
    move=> [|x y] //.
    by congr (|_, _|); ssfield; rewrite ?mulf_neq0 ?ecu_chi3 ?mcu_b_neq0.
  Qed.

  Lemma mc_of_ec_pointK : cancel mc_of_ec_point ec_of_mc_point.
  Proof.
    move=> [|x y] //.
    by congr (|_, _|); ssfield; rewrite ?mulf_neq0 ?ecu_chi3 ?mcu_b_neq0.
  Qed.

  Lemma ec_of_mcK : cancel ec_of_mc mc_of_ec.
  Proof.
    move=> x; apply/eqP; rewrite eqE /=; apply/eqP.
    by exact: ec_of_mc_pointK.
  Qed.

  Lemma mc_of_ecK : cancel mc_of_ec ec_of_mc.
  Proof.
    move=> x; apply/eqP; rewrite eqE /=; apply/eqP.
    by exact: mc_of_ec_pointK.
  Qed.

  Lemma ec_of_mc_bij : bijective ec_of_mc.
  Proof. by exists mc_of_ec; [exact: ec_of_mcK|exact: mc_of_ecK]. Qed.

  Local Notation "x \+ y" := (@MCGroup.addmc _ M x y).

  Lemma ec_of_mc_pointD : forall p q, oncurve M p -> oncurve M q ->
    ec_of_mc_point (MCGroup.add M p q) = ECGroup.add E (ec_of_mc_point p) (ec_of_mc_point q).
  Proof.
    move=> [|x1 y1] [|x2 y2] oncve_p oncve_q //.
    + rewrite MCGroup.add0o // ECGroup.add0o //.
      by apply: ec_of_mc_point_ok.
    + rewrite ECGroup.addoC MCGroup.addoC // MCGroup.add0o // ECGroup.add0o //.
      by apply: ec_of_mc_point_ok.
    + rewrite /MCGroup.add /ECGroup.add.
      rewrite !ec_of_mc_point_ok //=.
      rewrite (inj_eq (addIr _)) !(inj_eq (divIf _)) ?mcu_b_neq0 //.
      rewrite mulf_eq0 invr_eq0 (negbTE (mcu_b_neq0 M)) orbF.
      pose neq0 := (mulf_neq0, expf_neq0, ecu_chi2, ecu_chi3, mcu_b_neq0).
      case: ifP => [x1_eq_x2|/negbT x1_neq_x2].
      * case: ifP => // /andP[y1_eq_y2 y1_neq0].
        by congr (|_, _|); ssfield; rewrite ?neq0 //.
      * have H1 : x2 - x1 != 0 by rewrite subr_eq0 eq_sym.
        have H2 : x2 * 3%:R + M#a - (x1 * 3%:R + M#a) != 0.
          rewrite subr_eq0 (inj_eq (addIr _)) (inj_eq (mulIf _)) ?ecu_chi3 //.
          by rewrite eq_sym.
        by congr (|_, _|); ssfield; rewrite ?neq0 //.
  Qed.

  Lemma ec_of_mc_pointD' : forall p q, oncurve M p -> oncurve M q ->
    ec_of_mc_point (MCGroup.add M p q) = ECGroup.add E (ec_of_mc_point p) (ec_of_mc_point q).
  Proof.
    move => p q Hp Hq.
    by apply ec_of_mc_pointD.
  Qed.

  Lemma ec_of_mc_pointN : forall p,
    ec_of_mc_point (MCGroup.neg p) = ECGroup.neg (ec_of_mc_point p).
  Proof. by move=> [|x y] //=; rewrite mulNr. Qed.
End MCEC.

Section MCAssocFin.
  Variable K : finECUFieldType.
  Variable M : mcuType K.

  Local Notation "x \+ y" := (@MCGroup.add _ _ x y).

  Lemma addmA_fin: associative (@MCGroup.addmc K M).
  Proof.
    move=> p q r /=.
    pose oncve_p := [oc of p].
    pose oncve_q := [oc of q].
    pose oncve_r := [oc of r].
    apply/eqP; rewrite !eqE /=; apply/eqP.
    rewrite -[p \+ _](ec_of_mc_pointK M) !ec_of_mc_pointD' //;
      last exact: MCGroup.addO'.
    move: (addeA_fin (ec_of_mc p) (ec_of_mc q) (ec_of_mc r)).
    move/eqP; rewrite !eqE /= => /eqP ->.
    rewrite -!ec_of_mc_pointD' // ?ec_of_mc_pointK //;
      last exact: MCGroup.addO'.
  Qed.

  Definition finmc_zmodMixin :=
    (ZmodMixin
       addmA_fin (MCGroup.addmC (M := M))
       (MCGroup.add0m (M := M)) (MCGroup.addNm (M := M))).

  Canonical Structure finmc_zmodType :=
    Eval hnf in (ZmodType (mc M) finmc_zmodMixin).

  Lemma ec_of_mc_additive : additive (@ec_of_mc _ M).
  Proof.
    move=> p q.
    pose oncve_p := [oc of p].
    pose oncve_q := [oc of q].
    apply/eqP; rewrite !eqE /=; apply/eqP.
    by rewrite ec_of_mc_pointD' -?MCGroup.oncurveN // ec_of_mc_pointN.
  Qed.
End MCAssocFin.


Require Import Crypto.Algebra.Field.
Require Import Crypto.Util.GlobalSettings.
Require Import Crypto.Util.Sum Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Spec.WeierstrassCurve.

Module M.
  Section MontgomeryCurve.
    Import BinNat.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}
            {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos (BinNat.N.two))}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "- x" := (Fopp x).
    Local Notation "x ^ 2" := (x*x) (at level 30).
    Local Notation "x ^ 3" := (x*x^2) (at level 30).
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Notation "'∞'" := unit : type_scope.
    Local Notation "'∞'" := (inr tt) : core_scope.
    Local Notation "( x , y )" := (inl (pair x y)).
    Local Open Scope core_scope.

    Context {a b: F} {b_nonzero:b <> 0}.

    Program Definition opp (P:@M.point F Feq Fadd Fmul a b) : @M.point F Feq Fadd Fmul a b :=
      match P return F*F+∞ with
      | (x, y) => (x, -y)
      | ∞ => ∞
      end.
    Next Obligation. Proof. destruct_head @M.point; cbv; break_match; trivial; fsatz. Qed.

    Local Notation add := (M.add(b_nonzero:=b_nonzero)).
    Local Notation point := (@M.point F Feq Fadd Fmul a b).

    Section MontgomeryWeierstrass.
      Local Notation "2" := (1+1).
      Local Notation "3" := (1+2).
      Local Notation "4" := (1+1+1+1).
      Local Notation "9" := (3*3).
      Local Notation "27" := (4*4 + 4+4 +1+1+1).

      Context {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28}.

      Context {aw bw} {Haw:aw=(3-a^2)/(3*b^2)} {Hbw:bw=(2*a^3-9*a)/(27*b^3)}.
      Local Notation Wpoint := (@W.point F Feq Fadd Fmul aw bw).
      Local Notation Wadd := (@W.add F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv field Feq_dec char_ge_3 aw bw).
      Program Definition to_Weierstrass (P:@point) : Wpoint :=
        match M.coordinates P return F*F+∞ with
        | (x, y) => ((x + a/3)/b, y/b)
        | _ => ∞
        end.
      Next Obligation. Proof. destruct_head' @point; cbv; break_match; trivial; fsatz. Qed.

      Program Definition of_Weierstrass (P:Wpoint) : point :=
        match W.coordinates P return F*F+∞ with
        | (x,y) => (b*x-a/3, b*y)
        | _ => ∞
        end.
      Next Obligation. Proof. destruct_head' @Wpoint; cbv; break_match; trivial; fsatz. Qed.
    End MontgomeryWeierstrass.
  End MontgomeryCurve.
End M.


From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.

From vcfloat Require Import IEEE754_extra.
Import Coq.Lists.List ListNotations.

Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Set Bullet Behavior "Strict Subproofs".

Section WITHNANS.
Context {NANS: Nans}.

Definition sum {A: Type} (sum_op : A -> A -> A) (a b : A) : A := sum_op a b.

Inductive sum_rel {A : Type} (default: A) (sum_op : A -> A -> A) : list A -> A -> Prop :=
| sum_rel_nil  : sum_rel default sum_op [] default
| sum_rel_cons : forall l a s,
    sum_rel default sum_op l s ->
    sum_rel default sum_op (a::l) (sum sum_op a s).

Definition sum_rel_F := @sum_rel (ftype Tsingle) (-0)%F32 (@BPLUS _ Tsingle).
Definition sum_rel_R := @sum_rel R 0%R Rplus.

Lemma sum_rel_R_abs :
forall l s1 s2,
sum_rel_R l s1 -> sum_rel_R (map Rabs l) s2 -> s1 <= s2.
Proof.
induction l.
-
intros.
inversion H.
inversion H0.
nra.
-
intros.
inversion H; subst; clear H.
inversion H0; subst; clear H0.
unfold sum.
eapply Rplus_le_compat.
apply Rle_abs.
fold sum_rel_R in H4.
fold sum_rel_R in H3.
apply IHl;
auto.
Qed.

Lemma sum_rel_R_Rabs_eq :
forall l s,
sum_rel_R (map Rabs l) s -> Rabs s = s.
Proof.
induction  l.
-
intros.
inversion H.
rewrite Rabs_R0.
nra.
-
intros.
inversion H; subst; clear H.
unfold sum.
replace (Rabs(Rabs a + s0)) with
  (Rabs a  + s0); try nra.
symmetry.
rewrite Rabs_pos_eq; try nra.
apply Rplus_le_le_0_compat.
apply Rabs_pos.
eapply Rle_trans with (Rabs s0).
apply Rabs_pos.
eapply Req_le.
apply IHl.
fold sum_rel_R in H3.
auto.
Qed.

Lemma sum_rel_R_Rabs :
forall l s1 s2,
sum_rel_R l s1 -> sum_rel_R (map Rabs l) s2 -> Rabs s1 <= Rabs s2.
Proof.
induction l.
-
intros.
inversion H.
inversion H0.
nra.
-
intros.
inversion H; subst; clear H.
inversion H0; subst; clear H0.
fold sum_rel_R in H4.
fold sum_rel_R in H3.
unfold sum.
eapply Rle_trans.
apply Rabs_triang.
replace (Rabs(Rabs a + s0)) with
  (Rabs a  + s0).
eapply Rplus_le_compat; try nra.
eapply Rle_trans with (Rabs s0).
fold sum_rel_R in H4.
fold sum_rel_R in H3.
apply IHl; auto.
apply Req_le.
eapply sum_rel_R_Rabs_eq; apply H3.
symmetry.
rewrite Rabs_pos_eq; try nra.
apply Rplus_le_le_0_compat.
apply Rabs_pos.
eapply Rle_trans with (Rabs s0).
apply Rabs_pos.
apply Req_le.
eapply sum_rel_R_Rabs_eq; apply H3.
Qed.

Lemma plus_zero a:
is_finite _ _ a = true ->
(a + -0)%F32 = a.
Proof.
destruct a; simpl; auto;
intros; try discriminate; auto;
destruct s;
cbv; auto.
Qed.

Lemma sum_rel_F_single :
forall (a : ftype Tsingle) (fs : ftype Tsingle)
  (HFIN: is_finite _ _ a = true),
  sum_rel_F [a] fs -> fs = a.
Proof.
intros.
inversion H; auto.
inversion H3. subst.
unfold sum.
apply plus_zero; auto.
Qed.

Lemma sum_rel_R_single :
forall (a : R) (fs : R), sum_rel_R [a] fs -> fs = a.
Proof.
intros.
inversion H; auto.
inversion H3. subst.
unfold sum; nra.
Qed.

Definition _a := 1%positive. (* current element *)
Definition _b := 2%positive. (* accumulator *)

Definition vmap_list ty (a b : ftype ty) :=
   [(_a, existT ftype _ a); (_b, existT ftype _ b)].

Definition vmap {ty} (a b : ftype ty) : valmap :=
 ltac:(let z := compute_PTree (valmap_of_list (vmap_list ty a b)) in exact z).

Definition bmap_list : list varinfo :=
  [ trivbound_varinfo Tsingle _a;
    trivbound_varinfo Tsingle _b ].

Definition bmap : boundsmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list bmap_list) in exact z).

Definition sum_expr {ty} (a b : ftype ty) := ltac :( let e' :=
  HO_reify_float_expr constr:([_a; _b]) (@BPLUS _ ty) in exact e').

Lemma real_lt_1 :
forall a b c,
a <= b -> b < c -> a < c.
Proof. intros; apply Rle_lt_trans with b; auto. Qed.

Lemma prove_rndoff' :
  forall (a b : ftype Tsingle) ,
  let e := / IZR (2 ^ 150) in
  let d := / IZR (2 ^ 24) in
      let ov := powerRZ 2 (femax Tsingle) in
  Rabs (FT2R a + FT2R b) <= (ov - 2 * e) / (1 + d) ->
  prove_roundoff_bound bmap (vmap a b) (@sum_expr Tsingle a b)
     (Rabs ( FT2R a + FT2R b) * d + e).
Proof.
intros ? ? ? ?  ? bnd.
prove_roundoff_bound.
-
prove_rndval.
clear BOUND BOUND0.
assert (Rabs (1 + u0) <= 1 + d) as Hu2.
{ subst e; eapply Rle_trans;  [apply Rabs_triang |]; eapply Rplus_le_compat;
  [ rewrite Rabs_R1; apply Rle_refl |  ].
subst d. unfold error_bound in H0.
rewrite (IZR_Zpower Zaux.radix2) by lia.
change (bpow _ ?n) with (2 * bpow Zaux.radix2 (Z.pred n)).
rewrite Rinv_mult. assumption.
}
assert (Rabs u <= e) as Hu1.
{ subst e.
rewrite (IZR_Zpower Zaux.radix2) by lia.
change (bpow _ ?n) with (2 * bpow Zaux.radix2 (Z.pred n)).
rewrite Rinv_mult. assumption.
}
apply Rlt_Rminus.
rewrite Rmult_1_l.
eapply Rle_lt_trans.
eapply Rle_trans.
apply Rabs_triang.
eapply Rle_trans.
eapply Rplus_le_compat.
rewrite Rabs_mult.
eapply Rmult_le_compat; try apply Rabs_pos.
apply bnd.
apply Hu2.
apply Hu1.
eapply Rle_refl.
replace ((ov - 2 * e) / (1 + d) * (1 + d))
  with (ov - 2 * e).
replace ov with 0x1p128%xR.
apply Rminus_lt.
field_simplify.
subst e.
interval.
subst ov; simpl; nra.
field.
subst d.
interval.
-
prove_roundoff_bound2.
clear BOUND BOUND0.
match goal with |- context[Rabs ?a <= _] =>
field_simplify a
end.
assert (He0: Rabs e1 <= e).
{ eapply Rle_trans. apply E. subst e; simpl; nra. }
rename e2 into d0.
assert (Hd: Rabs d0 <= d).
{ eapply Rle_trans. apply E0. subst d; simpl; nra. }
replace (a * d0 + b * d0 + e1) with ((a + b) * d0 + e1) by nra.
eapply Rle_trans; [
apply Rabs_triang | eapply Rle_trans; [apply Rplus_le_compat; [rewrite Rabs_mult; eapply Rle_trans;
  [apply Rmult_le_compat;
      [ apply Rabs_pos | apply Rabs_pos |   apply Rle_refl | apply Hd ] |
  apply Rle_refl ]  | apply He0 ] | ]  ].
nra.
Qed.

Lemma reflect_reify_sumF :
  forall a b,
  fval (env_ (vmap a b)) (@sum_expr Tsingle a b) = sum (@BPLUS _ Tsingle)  a b .
Proof. reflexivity. Qed.

Lemma reflect_reify_sumR :
  forall a b,
  rval (env_ (vmap a b)) (@sum_expr Tsingle a b) = FT2R a + FT2R b .
Proof. reflexivity. Qed.

Lemma prove_rndoff:
  forall (a b : ftype Tsingle),
  boundsmap_denote bmap (vmap a b) ->
  let e  := / IZR (2 ^ 150) in
  let d := / IZR (2 ^ 24) in
      let ov := powerRZ 2 (femax Tsingle) in
  Rabs (FT2R a + FT2R b) <= (ov - 2 * e) / (1 + d) ->
      Rabs ( FT2R a + FT2R b - FT2R (BPLUS a b)) <=
     (Rabs ( FT2R a + FT2R b) * d + e).
Proof.
intros  ? ?   BMD  ? ? H1 H2.
pose proof prove_rndoff' a b H2.
pose proof reflect_reify_sumF a b as HF.
pose proof reflect_reify_sumR a b as HR.
unfold prove_roundoff_bound, roundoff_error_bound in H.
specialize (H BMD).
destruct H as ( _ & H).
rewrite HF in H.
rewrite HR in H.
fold d e in H.
unfold sum in H.
rewrite Rabs_minus_sym.
auto.
Qed.

Lemma rewrite_Rabs_triang a b (a' b': ftype Tsingle):
Rabs((a + b) - FT2R (BPLUS a' b')) <=
  Rabs((a + b) - (FT2R a' + FT2R b')) +
  Rabs((FT2R a' + FT2R b') - FT2R (BPLUS a' b')).
Proof.
eapply Rle_trans; [ | apply Rabs_triang].
eapply Req_le.
f_equal.
nra.
Qed.

Lemma le_div a b c:
  0 < c -> a <= b -> a / c <= b / c .
Proof.
intros.
apply Generic_proof.Rdiv_le_mult_pos; try nra.
field_simplify; nra.
Qed.

Lemma le_div3 c1 c2:
   0 < c1 -> c2 <= c1 -> c2/c1 <= 1.
Proof.
intros.
apply Rdiv_le_left; try nra.
Qed.

Lemma le_div2 a b c1 c2:
  0 <= a ->
  0 < c1 -> 0 < c2 -> c2 <= c1 -> a <= b -> a / c1 <= b / c2 .
Proof.
intros A. intros.
apply Generic_proof.Rdiv_le_mult_pos; try nra.
apply le_div3 in H1; auto.
field_simplify; try nra.
Qed.

Lemma length_not_empty {A} l :
l <> [] ->
(1 <= @length A l)%nat.
Proof.
intros.
destruct l; simpl;
 try simpl (length (a :: l)); try lia.
destruct H; auto.
Qed.

Lemma length_not_empty' {A} l :
l <> [] ->
1 <= INR (@length A l).
Proof.
intros.
replace 1 with (INR 1) by (simpl; auto).
eapply le_INR.
apply length_not_empty; auto.
Qed.

Lemma length_not_empty_nat {A} l :
l <> [] ->
(1 <= (@length A l))%nat.
Proof.
intros.
apply INR_le.
apply length_not_empty';auto.
Qed.

Lemma length_not_empty_lt {A} l :
l <> [] ->
0 < INR (@length A l).
Proof.
intros.
destruct l.
destruct H; auto.
simpl (length (a:: l)).
rewrite <- Nat.add_1_r.
rewrite plus_INR.
apply Rcomplements.Rlt_minus_l.
field_simplify.
simpl.
eapply Rlt_le_trans with 0;  try nra.
apply pos_INR.
Qed.

Lemma length_not_empty_nat' {A} l :
l <> [] ->
(0 <= (@length A l))%nat.
Proof.
intros.
apply INR_le.
apply Rlt_le.
apply length_not_empty_lt;auto.
Qed.

Definition error_rel (n : nat) (r : R) : R :=
  let e  := / IZR (2 ^ 150) in
  let d := / IZR (2 ^ 24) in
  if (1 <=? Z.of_nat n) then
    ((1 + d)^(n-1) - 1) * (Rabs r + e/d)
  else 0%R.

Ltac write_tsingle:=
set (ea:= bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle));
simpl in ea; subst ea;
set (ea:= bpow Zaux.radix2 (- fprec Tsingle + 1));
simpl in ea; subst ea.

Lemma prove_rndoff_n :
  forall (l : list (ftype Tsingle)) fs rs rs_abs,
  sum_rel_F l fs -> sum_rel_R (map FT2R l) rs -> sum_rel_R (map Rabs (map FT2R l)) rs_abs ->
  let e  := / IZR (2 ^ 150) in
  let d  := / IZR (2 ^ 24) in
  let ov := powerRZ 2 (femax Tsingle) in
  let n := length l in
  let A := (1 + d)^(n-1) - 1 in
  (forall a0, In a0 l ->
  is_finite (fprec Tsingle) 128 a0 = true /\
  Rabs (FT2R a0) <= (ov - 2 * e - A * e/d * (1 + d)) / ((1 + (A + 1) * INR n) * (1 + d))) ->
  is_finite (fprec Tsingle) (femax Tsingle) fs = true /\
  Rabs (rs - FT2R fs) <= error_rel (length l)  rs_abs.
Proof.
induction l.
-
intros.
inversion H; subst; clear H;
inversion H0; subst; clear H0; simpl.
cbv [error_rel]; simpl.
rewrite Rminus_0_r.
rewrite Rabs_R0.
nra.
-
intros.
assert (Hl: l = [] \/ l <> []).
destruct l; auto.
right.
eapply hd_error_some_nil; simpl; auto.
destruct Hl.
(* list (a0 :: a :: l) *)
(* case empty l *)
+
subst; simpl.
assert (HFIN: is_finite (fprec Tsingle) 128 a = true).
{
apply H2; simpl; auto.
}
rewrite (sum_rel_F_single a fs HFIN H).
rewrite (sum_rel_R_single (FT2R a) rs H0).
cbv [error_rel]; simpl;
split; auto.
field_simplify_Rabs.
rewrite Rabs_R0.
field_simplify; nra.
+
(* start common *)
assert (Hifn : 1 <=? Z.of_nat n = true).
{
apply Z.leb_le.
replace 1%Z with (Z.of_nat 1) by lia.
apply inj_le.
subst n.
simpl (length (a::l)).
rewrite <- Nat.add_1_r.
lia.
}
assert (Hif1 : 1 <=? Z.of_nat (length l + 1) = true).
{
apply Z.leb_le.
rewrite Nat2Z.inj_add.
simpl.
apply Z.le_sub_le_add_r.
ring_simplify.
replace 0%Z with (Z.of_nat 0)%Z by lia.
apply inj_le.
apply length_not_empty_nat'; auto.
}
assert (Hif2: 1 <=? Z.of_nat (length l) = true).
{
apply Z.leb_le.
replace 1%Z with (Z.of_nat 1) by lia.
apply inj_le.
apply length_not_empty_nat; auto.
}
assert (Hlenl: (1 <= length l)%nat).
{
apply length_not_empty_nat; auto.
}
assert (Hnlt: 0 < INR n).
{ subst n.
simpl (length (a::l)).
rewrite <- Nat.add_1_r.
rewrite plus_INR.
apply Rcomplements.INRp1_pos.
}
assert (Hd : 0 < d).
{
subst d; interval.
}
assert (Hd2: 0 < 1 + d).
{
subst d; interval.
}
assert (HA2: 0 < A).
{
subst A.
apply Rlt_Rminus.
subst n.
simpl (length(a::l)).
rewrite <- Nat.add_1_r.
eapply Rlt_le_trans with ((1+d)^1).
  try subst d; try interval.
apply Rle_pow.
  try subst d; try interval.
rewrite Nat.add_sub; auto.
}
assert (HAgt: 0 < (1 + (A + 1) * INR n) * (1 + d)).
{
apply Rmult_lt_0_compat; auto.
apply Rplus_lt_0_compat; try nra.
}
set (A':=(1 + d) ^ (length l - 1) - 1).
assert (Aposp: 0 <= A').
{
subst A'.
apply Rle_0_minus.
subst n.
apply pow_R1_Rle.
subst d; interval.
}
assert (HAgtp: 0 < (1 + (A' + 1) * INR (length l)) * (1 + d)).
{
apply Rmult_lt_0_compat; auto.
apply Rplus_lt_0_compat; try nra.
apply Rmult_lt_0_compat; auto.
apply Rplus_le_lt_0_compat; try nra.
apply length_not_empty_lt; auto.
}
assert (Hov: 0 <= ov - 2 * e - A * e / d * (1 + d)).
{
eapply Stdlib.Rdiv_pos_compat_rev with ((1 + (A + 1) * INR n)* (1+d)); auto.
eapply Rle_trans with (Rabs (FT2R a));
  try apply Rabs_pos.
apply H2.
simpl; auto.
}
assert (Hln: INR (length l) <= INR n).
{
subst n.
simpl (length(a::l)).
rewrite <- Nat.add_1_r.
apply le_INR.
lia.
}
assert (HAd: 0 <= (1 + d) ^ (length l - 1)).
{
apply pow_le; nra.
}
assert (Hle: (1 + d) ^ (length l - 1) <= (1 + d) ^ (n - 1)).
{
apply Rle_pow; try nra.
subst n.
simpl (length(a::l)).
rewrite <- Nat.add_1_r.
lia.
}
assert (Hle2: (1 + d) ^ (length l - 1) <= (1 + d) ^ (length l + 1 - 1)).
{
apply Rle_pow; try nra.
subst n.
simpl (length(a::l)).
rewrite <- Nat.add_1_r.
lia.
}
assert (Aeq: ((1 + d) ^ (length l + 1 - 1) - 1) = A).
{
subst A.
f_equal.
f_equal.
subst n.
simpl (length(a::l)).
rewrite <- Nat.add_1_r.
lia.
}
assert (HAd2: d <= A).
{ subst A. apply Rcomplements.Rle_minus_r.
subst n.
simpl (length(a::l)).
rewrite <- Nat.add_1_r.
eapply Rle_trans with ((1+d)^1).
nra.
apply Rle_pow; try nra.
lia.
}
assert (
Her:  forall s, error_rel (length l) s <= error_rel (length l + 1) s).
{
intros.
unfold error_rel.
rewrite Hif2.
rewrite Hif1.
write_tsingle.
fold e d.
apply Rmult_le_compat_r; auto.
apply Rplus_le_le_0_compat.
apply Rabs_pos.
subst e d; interval.
apply Rplus_le_compat_r; auto.
}

(* end common *)

inversion H1; subst; clear H1.
inversion H0; subst; clear H0.
inversion H; subst; clear H.
fold sum_rel_F in H5.
fold sum_rel_R in H6.
fold sum_rel_R in H7.

assert (IHLp:
forall a0 : ftype Tsingle,
In a0 l ->
is_finite (fprec Tsingle) 128 a0 = true /\
Rabs (FT2R a0) <=
(ov - 2 * e - ((1 + d) ^ (length l - 1) - 1) * e / d * (1 + d)) /
((1 + ((1 + d) ^ (length l - 1) - 1 + 1) * INR (length l)) * (1 + d))).
{
intros.
split.
-
apply H2.
simpl; auto.
-
eapply Rle_trans.
apply H2.
simpl; auto.
apply le_div2; auto.
+
apply Rmult_le_compat_r; try nra.
+
apply Rplus_le_compat_l.
apply Ropp_le_contravar.
apply Rmult_le_compat_r; try nra.
apply Rmult_le_compat_r; try nra.
subst d; try interval.
subst A.
apply Rmult_le_compat_r; try nra.
subst e; interval.
}

assert (Hs1: Rabs (FT2R s1) <= error_rel (length l + 1 ) s + Rabs (s0)).
{
apply Rcomplements.Rle_minus_l.
eapply Rle_trans.
apply Rabs_triang_inv.
eapply Rle_trans.
rewrite Rabs_minus_sym; auto.
apply IHl.
apply H5.
apply H6.
apply H7.
write_tsingle.
fold e d ov.
auto.
apply Her.
}

set (b:=
    (ov - 2 * e - A * e / d * (1 + d)) / ((1 + (A + 1) * INR n) * (1 + d)) *
    INR n).
assert (Rabs s <= b /\ Rabs s0 <= b).
{
assert (
forall  l s b,
(forall a0, In a0 l -> Rabs a0 <= b) ->
sum_rel_R l s -> Rabs s <=
  b * INR (length l)).
{
induction l0.
simpl.
intros.
inversion H0; subst; clear H0.
rewrite Rabs_R0; nra.
intros.
inversion H0; subst; clear H0.
fold sum_rel_R in H9.
eapply Rle_trans.
unfold sum in *.
eapply Rabs_triang.
eapply Rle_trans.
apply Rplus_le_compat.
apply H.
simpl; auto.
unfold sum in *.
apply IHl0.
intros.
apply H.
simpl in H0; simpl; auto.
auto.
replace (INR (length (a0 :: l0))) with
(1 + INR (length l0)).
nra.
simpl (length (a0::l0)).
rewrite S_INR.
nra.
}
assert (
forall a0 : R,
     In a0 (map FT2R l) ->
     Rabs a0 <=
  (ov - 2 * e - A * e/d * (1 + d)) / ((1 + (A + 1) * INR n)* (1 + d))).
{
intros.
apply in_map_iff in H0.
destruct H0 as (A1 & B & C).
subst.
eapply Rle_trans.
apply H2.
simpl; auto.
nra.
}

assert (
forall a0 : R,
     In a0 (map Rabs (map FT2R l)) ->
     Rabs a0 <=
  (ov - 2 * e - A * e/d * (1 + d)) / ((1 + (A + 1) * INR n)* (1 + d))).
{
intros.
apply in_map_iff in H1.
destruct H1 as (A1 & B & C).
subst.
eapply Rle_trans.
rewrite Rabs_Rabsolu.
apply H0.
simpl; auto.
nra.
}

split.
-
(* Rabs s <= b *)
eapply Rle_trans.
eapply (H (map Rabs (map FT2R l)) s).
intros.
apply H1; auto.
auto.
apply Rmult_le_compat; auto.
apply Stdlib.Rdiv_pos_compat; auto.
rewrite map_length.
apply pos_INR.
apply Req_le; nra.
replace (length (map FT2R l)) with (length l); auto.
rewrite map_length; auto.
rewrite map_length; auto.
rewrite map_length; auto.
-
(* Rabs s0 <= b *)
eapply Rle_trans.
eapply (H (map FT2R l) s0).
intros.
apply H0; auto.
auto.
apply Rmult_le_compat; auto.
apply Stdlib.Rdiv_pos_compat; auto.
rewrite map_length.
apply pos_INR.
apply Req_le; nra.
replace (length (map FT2R l)) with (length l); auto.
rewrite map_length; auto.
}

assert (HBMD: boundsmap_denote bmap (vmap a s1)).
{
assert (is_finite (fprec Tsingle) (femax Tsingle) s1 = true). {
  eapply IHl.
  apply H5.
  apply H6.
  apply H7.
  write_tsingle.
  fold e d ov.
  auto.
}
apply boundsmap_denote_i.
repeat constructor;
(eexists; split; [reflexivity | split; [reflexivity | split;  [  | ]]]); auto.
-
apply trivbound_correct.
-
apply H2.
simpl; auto.
-
apply trivbound_correct.
-
repeat constructor.
}

assert (Hs2: Rabs (FT2R s1) <= error_rel (length l ) s + Rabs s).
{
assert (Rabs (s0 - FT2R s1) <= error_rel (length l ) s).
apply IHl; auto.
rewrite Rabs_minus_sym in H0.
eapply Rle_trans with (error_rel (length l) s + Rabs s0).
apply Rcomplements.Rle_minus_l.
eapply Rle_trans.
apply Rabs_triang_inv; auto.
auto.
apply Rplus_le_compat_l.
eapply sum_rel_R_Rabs.
apply H6.
apply H7.
}

assert (Hrndp:
Rabs (FT2R a + FT2R s1) <=
(ov - 2 * e) / (1 + d)).
{
eapply Rle_trans.
apply Rabs_triang.
eapply Rle_trans.
apply Rplus_le_compat.
apply H2.
simpl; auto.
eapply Rle_trans.
apply Hs1.
apply Rplus_le_compat.
cbv [error_rel].
rewrite Hif1.
write_tsingle.
fold e d ov A n.
rewrite Aeq.
assert (A * (Rabs s + e / d) <=
  A * ( b + e / d)).
apply Rmult_le_compat_l; try nra.
apply H0.
apply H.

subst b.
set (h:=(ov - 2 * e - A * e / d * (1 + d)) / ((1 + (A + 1) * INR n) * (1 + d))).
rewrite <- Rplus_assoc.
replace (
h + A * (h * INR n + e / d) + h * INR n)
with
(h * (1  + (A + 1)* INR n) + A * e/d) by nra.
apply Generic_proof.Rdiv_le_mult_pos; try nra.
rewrite Rmult_plus_distr_r.
assert (h * (1 + (A + 1) * INR n) * (1 + d) =
(ov - 2 * e - A * e / d * (1 + d))).
subst h.
field.
repeat split; try nra.
rewrite H0.
apply Req_le.
field; nra.
}

match goal with |- (?A /\ ?B) =>
assert (HFIN : A)
end.
{
destruct (prove_rndoff' a s1 ); auto.

}
split; auto.

eapply Rle_trans.
apply rewrite_Rabs_triang.
repeat match goal with |- context[Rabs ?a] =>
field_simplify a
end.

eapply Rle_trans.
apply Rplus_le_compat.
{
apply IHl; auto.
apply H7.
}
{
eapply prove_rndoff; auto.
}

write_tsingle.
fold e d.
eapply Rle_trans.
apply Rplus_le_compat_l.
apply Rplus_le_compat_r.
apply Rmult_le_compat_r; try nra.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat_l.
apply Hs2.

cbv [error_rel].
unfold sum.
fold n;
rewrite Hif2.
rewrite Hifn.
write_tsingle.
fold e d ov A A'.

replace (
A' * (Rabs s + e / d) +
((Rabs (FT2R a) + (A' * (Rabs s + e / d) + Rabs s)) * d + e))
with
(A' * (1 + d) * (Rabs s + e / d) + Rabs (FT2R a) * d + Rabs s * d + e) by nra.

assert (A' * (1 + d) = A - d).
{
subst A' A.
rewrite Rmult_minus_distr_r.
assert ((1 + d) ^ (length l - 1) * (1 + d) = (1 + d) ^ (n - 1)).
replace ((1 + d) ^ (length l - 1) * (1 + d)) with
  ((1 + d) ^ (length l - 1 + 1)).
f_equal.
subst n.
simpl (length (a::l)).
rewrite Nat.add_1_r; lia.
rewrite pow_add; nra.
rewrite H0.
nra.
}

rewrite H0; clear H0.
replace ((A - d) * (Rabs s + e / d)) with
(A *(Rabs s + e / d) - d * (Rabs s + e / d)) by nra.
assert (Hs: Rabs s = s).
{ eapply sum_rel_R_Rabs_eq.
apply H7.
}
ring_simplify.
replace (
A * Rabs s + A * (e / d) - e / d * d + d * Rabs (FT2R a) + e)
with
(A * Rabs s + A * (e / d) + d * Rabs (FT2R a)).
replace (Rabs (Rabs (FT2R a) + s)) with (Rabs (FT2R a) + s).

eapply Rle_trans.
apply Rplus_le_compat_l.
assert (d * Rabs (FT2R a) <= A * Rabs (FT2R a)).
apply Rmult_le_compat_r; auto.
apply Rabs_pos.
apply H0.

rewrite Hs.
apply Req_le.
field_simplify; try nra.
symmetry.
rewrite Rabs_pos_eq; auto.
apply Rplus_le_le_0_compat.
apply Rabs_pos.
eapply Rle_trans with (Rabs s).
apply Rabs_pos.
apply Req_le; auto.
rewrite Hs.
field_simplify; nra.
Qed.

End WITHNANS.


(**
  Monoidal categories

  Based on an implementation by Anthony Bordg.

  Behaviour w.r.t. to swapped tensor product added by Ralph Matthes in 2019
  Isos replaced by z_isos in 2021
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.ProductCategory.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

Notation "'id' X" := (identity X) (at level 30).

Notation "C ⊠ D" := (category_binproduct C D) (at level 38).
Notation "( c , d )" := (make_catbinprod c d).
Notation "( f #, g )" := (catbinprodmor f g).

Section Monoidal_Precat.

Context {C : category} (tensor : C ⊠ C ⟶ C) (I : C).

Notation "X ⊗ Y" := (tensor (X, Y)).
Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31).

Lemma tensor_id {X Y : C} : id X #⊗ id Y = id (X ⊗ Y).
Proof.
  apply (functor_id tensor).
Qed.

Lemma tensor_comp {X Y Z X' Y' Z' : C} (f : X --> Y) (g : Y --> Z) (f' : X' --> Y') (g' : Y' --> Z') :
  (f · g) #⊗ (f' · g') = f #⊗ f' · g #⊗ g'.
Proof.
  rewrite binprod_comp.
  apply (functor_comp tensor).
Qed.

Definition is_z_iso_tensor_z_iso {X Y X' Y' : C} {f : X --> Y} {g : X' --> Y'}
           (f_is_z_iso : is_z_isomorphism f) (g_is_z_iso : is_z_isomorphism g) : is_z_isomorphism (f #⊗ g).
Proof.
  exact (functor_on_is_z_isomorphism _ (is_z_iso_binprod_z_iso f_is_z_iso g_is_z_iso)).
Defined.

(* I ⊗ - *)
Definition I_pretensor : C ⟶ C := functor_fix_fst_arg _ _ _ tensor I.

Lemma I_pretensor_ok: functor_on_objects I_pretensor = λ c, I ⊗ c.
Proof.
  apply idpath.
Qed.

(* λ *)
Definition left_unitor : UU :=
  nat_z_iso I_pretensor (functor_identity C).

Definition left_unitor_funclass (λ' : left_unitor):
  ∏ x : ob C, I_pretensor x -->  x
  := pr1 (nat_z_iso_to_trans λ').
Coercion left_unitor_funclass : left_unitor >-> Funclass.

Definition left_unitor_to_nat_trans (λ' : left_unitor): nat_trans I_pretensor (functor_identity C)
  := nat_z_iso_to_trans λ'.
Coercion left_unitor_to_nat_trans: left_unitor >-> nat_trans.

(* - ⊗ I *)
Definition I_posttensor : C ⟶ C := functor_fix_snd_arg _ _ _ tensor I.

Lemma I_posttensor_ok: functor_on_objects I_posttensor = λ c, c ⊗ I.
Proof.
  apply idpath.
Qed.

(* ρ *)
Definition right_unitor : UU :=
  nat_z_iso I_posttensor (functor_identity C).

Definition right_unitor_funclass (ρ' : right_unitor):
  ∏ x : ob C, I_posttensor x -->  x
  := pr1 (nat_z_iso_to_trans ρ').
Coercion right_unitor_funclass : right_unitor >-> Funclass.

Definition right_unitor_to_nat_trans (ρ' : right_unitor): nat_trans I_posttensor (functor_identity C)
  := nat_z_iso_to_trans ρ'.
Coercion right_unitor_to_nat_trans: right_unitor >-> nat_trans.

(* (- ⊗ =) ⊗ ≡ *)
Definition assoc_left : (C ⊠ C) ⊠ C ⟶ C :=
  functor_composite (pair_functor tensor (functor_identity _)) tensor.

Lemma assoc_left_ok: functor_on_objects assoc_left =
  λ c, (ob1 (ob1 c) ⊗ ob2 (ob1 c)) ⊗ ob2 c.
Proof.
  apply idpath.
Qed.

(* - ⊗ (= ⊗ ≡) *)
Definition assoc_right : (C ⊠ C) ⊠ C ⟶ C :=
  functor_composite
    (precategory_binproduct_unassoc _ _ _)
    (functor_composite (pair_functor (functor_identity _) tensor) tensor).

Lemma assoc_right_ok: functor_on_objects assoc_right =
  λ c, ob1 (ob1 c) ⊗ (ob2 (ob1 c) ⊗ ob2 c).
Proof.
  apply idpath.
Qed.

(* α *)
Definition associator : UU :=
  nat_z_iso assoc_left assoc_right.
(* This definition goes in the opposite direction of that by Mac Lane (CWM 2nd ed., p.162)
   but conforms to the def. on Wikipedia. *)

Definition associator_funclass (α' : associator):
  ∏ x : ob ((C ⊠ C) ⊠ C), assoc_left x -->  assoc_right x
  := pr1 (nat_z_iso_to_trans α').
Coercion associator_funclass : associator >-> Funclass.

Definition associator_to_nat_trans (α' : associator): nat_trans assoc_left assoc_right
  := nat_z_iso_to_trans α'.
Coercion associator_to_nat_trans: associator >-> nat_trans.

Definition triangle_eq (λ' : left_unitor) (ρ' : right_unitor) (α' : associator) : UU :=
  ∏ (a b : C), pr1 ρ' a #⊗ id b = pr1 α' ((a, I), b) · id a #⊗ pr1 λ' b.

Definition pentagon_eq (α' : associator) : UU :=
  ∏ (a b c d : C), pr1 α' ((a ⊗ b, c), d) · pr1 α' ((a, b), c ⊗ d) =
   pr1 α' ((a, b), c) #⊗ id d · pr1 α' ((a, b ⊗ c), d) · id a #⊗ pr1 α' ((b, c), d).

Definition is_strict (eq_λ : I_pretensor = functor_identity C) (λ' : left_unitor)
           (eq_ρ : I_posttensor = functor_identity C) (ρ' : right_unitor)
           (eq_α : assoc_left = assoc_right) (α' : associator) : UU :=
  (is_nat_z_iso_id eq_λ λ') × (is_nat_z_iso_id eq_ρ ρ') × (is_nat_z_iso_id eq_α α').

End Monoidal_Precat.

Definition monoidal_cat : UU :=
  ∑ C : category, ∑ tensor : C ⊠ C ⟶ C, ∑ I : C,
  ∑ λ' : left_unitor tensor I,
  ∑ ρ' : right_unitor tensor I,
  ∑ α' : associator tensor,
         (triangle_eq tensor I λ' ρ' α') × (pentagon_eq tensor α').

(*
Definition monoidal_precat_struct : UU :=
  ∑ C : precategory, ∑ tensor : C ⊠ C ⟶ C, ∑ I : C,
  ∑ λ' : left_unitor tensor I,
  ∑ ρ' : right_unitor tensor I,
  ∑ α' : associator tensor, unit.

Definition make_monoidal_precat_struct (C: precategory)(tensor: C ⊠ C ⟶ C)(I: C)
  (λ': left_unitor tensor I)(ρ': right_unitor tensor I)(α': associator tensor): monoidal_precat_struct :=
  (C,, (tensor,, (I,, (λ',, (ρ',, (α',, tt)))))).
*)

Definition make_monoidal_cat (C: category)(tensor: C ⊠ C ⟶ C)(I: C)
  (λ': left_unitor tensor I)(ρ': right_unitor tensor I)(α': associator tensor)
  (eq1: triangle_eq tensor I λ' ρ' α')(eq2: pentagon_eq tensor α'): monoidal_cat :=
  (C,, (tensor,, (I,, (λ',, (ρ',, (α',, (eq1,, eq2))))))).

Definition monoidal_cat_cat (M : monoidal_cat) : category := pr1 M.
Coercion monoidal_cat_cat : monoidal_cat >-> category.

Section Monoidal_Cat_Accessors.

  Context (M : monoidal_cat).

  (** it is important that no new coercions are used in the given types in the following projections *)

Definition monoidal_cat_tensor : pr1 M ⊠ pr1 M ⟶ pr1 M := pr1 (pr2 M).

Definition monoidal_cat_unit : pr1 M := pr1 (pr2 (pr2 M)).

Definition monoidal_cat_left_unitor : left_unitor (pr1 (pr2 M)) (pr1 (pr2 (pr2 M))) := pr1 (pr2 (pr2 (pr2 M))).

Definition monoidal_cat_right_unitor : right_unitor (pr1 (pr2 M)) (pr1 (pr2 (pr2 M))) := pr1 (pr2 (pr2 (pr2 (pr2 M)))).

Definition monoidal_cat_associator : associator (pr1 (pr2 M)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 M))))).

Definition monoidal_cat_triangle_eq : triangle_eq (pr1 (pr2 M)) (pr1 (pr2 (pr2 M))) (pr1 (pr2 (pr2 (pr2 M)))) (pr1 (pr2 (pr2 (pr2 (pr2 M))))) (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))).

Definition monoidal_cat_pentagon_eq : pentagon_eq (pr1 (pr2 M)) (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))) := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))).

End Monoidal_Cat_Accessors.

Definition strict_monoidal_cat : UU :=
  ∑ M : monoidal_cat,
  ∏ (eq_λ : I_pretensor (monoidal_cat_tensor M) (monoidal_cat_unit M) =
  functor_identity (pr1 M)),
  ∏ (eq_ρ : I_posttensor (monoidal_cat_tensor M) (monoidal_cat_unit M) =
  functor_identity (pr1 M)),
  ∏ (eq_α : assoc_left (monoidal_cat_tensor M) =
  assoc_right (monoidal_cat_tensor M)),
  is_strict (monoidal_cat_tensor M) (monoidal_cat_unit M) eq_λ (monoidal_cat_left_unitor M) eq_ρ (monoidal_cat_right_unitor M) eq_α (monoidal_cat_associator M).

Section swapped_tensor.

Context (M : monoidal_cat).

Definition swapping_of_tensor: M ⊠ M ⟶ M := functor_composite binswap_pair_functor (monoidal_cat_tensor M).

Definition associator_swapping_of_tensor: associator swapping_of_tensor.
Proof.
  set (α := monoidal_cat_associator M).
  set (α' := nat_z_iso_to_trans_inv α).
  red.
  set (trafo := (pre_whisker reverse_three_args α'): (assoc_left swapping_of_tensor) ⟹ (assoc_right swapping_of_tensor)).
  assert (tisziso: is_nat_z_iso trafo).
  { red. intro c. set (aux := pr2 (nat_z_iso_inv α)).
    apply (pre_whisker_on_nat_z_iso reverse_three_args α' aux).
  }
  exact (trafo,, tisziso).
Defined.

Lemma triangle_eq_swapping_of_tensor: triangle_eq swapping_of_tensor (monoidal_cat_unit M)
  (monoidal_cat_right_unitor M) (monoidal_cat_left_unitor M) associator_swapping_of_tensor.
Proof.
  red. intros a b. cbn.
  set (H := monoidal_cat_triangle_eq M).
  unfold triangle_eq in H.
  etrans.
  2: { apply cancel_precomposition.
       apply pathsinv0.
       apply H. }
  clear H.
  rewrite assoc.
  etrans.
  { apply pathsinv0.
    apply id_left. }
  apply cancel_postcomposition.
  apply pathsinv0.
  set (f := nat_z_iso_pointwise_z_iso (monoidal_cat_associator M)((b, monoidal_cat_unit M), a)).
  apply (z_iso_after_z_iso_inv f).
Qed.

Lemma pentagon_eq_swapping_of_tensor: pentagon_eq swapping_of_tensor associator_swapping_of_tensor.
Proof.
  red. intros a b c d. cbn.
  set (H := monoidal_cat_pentagon_eq M).
  unfold pentagon_eq in H.
  set (f := nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((d, c), monoidal_cat_tensor M (b, a))).
  apply (z_iso_inv_on_right _ _ _ f).
  apply pathsinv0.
  set (f' := nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((monoidal_cat_tensor M (d, c), b), a)).
  apply (inv_z_iso_unique' _ _ _ f').
  unfold precomp_with.
  rewrite assoc.
  etrans.
  { apply cancel_postcomposition.
    apply H. }
  clear H.
  repeat rewrite assoc.
  etrans.
  { do 2 apply cancel_postcomposition.
    rewrite <- assoc.
    apply cancel_precomposition.
    apply pathsinv0.
    apply (functor_comp (functor_fix_fst_arg _ _ _ (monoidal_cat_tensor M) d)).
  }
  etrans.
  { do 2 apply cancel_postcomposition.
    apply cancel_precomposition.
    apply maponpaths.
    apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((c, b), a))). }
  rewrite functor_id.
  rewrite id_right.
  etrans.
  { apply cancel_postcomposition.
    rewrite <- assoc.
    apply cancel_precomposition.
    apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((d, monoidal_cat_tensor M (c, b)), a))). }
  rewrite id_right.
  etrans.
  apply pathsinv0.
  apply (functor_comp (functor_fix_snd_arg _ _ _ (monoidal_cat_tensor M) a)).
  etrans.
  { apply maponpaths.
    apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((d, c), b))). }
  cbn.
  unfold functor_fix_snd_arg_mor.
  use functor_id.
Qed.

Definition swapping_of_monoidal_cat: monoidal_cat.
Proof.
  use (make_monoidal_cat M swapping_of_tensor).
  - exact (monoidal_cat_unit M).
  - apply monoidal_cat_right_unitor.
  - apply monoidal_cat_left_unitor.
  - exact associator_swapping_of_tensor.
  - exact triangle_eq_swapping_of_tensor.
  - exact pentagon_eq_swapping_of_tensor.
Defined.

End swapped_tensor.

Section coherence_lemmas.

Context {Mon_V : monoidal_cat}.

Let I        : Mon_V                  := monoidal_cat_unit Mon_V.
Let tensor   : Mon_V ⊠ Mon_V ⟶ Mon_V := monoidal_cat_tensor Mon_V.
Let α        : associator tensor      := monoidal_cat_associator Mon_V.
Let l_unitor : left_unitor tensor I   := monoidal_cat_left_unitor Mon_V.
Let r_unitor : right_unitor tensor I  := monoidal_cat_right_unitor Mon_V.

Local Notation "X ⊗ Y" := (tensor (X, Y)).
Local Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31).

Lemma tensor_comp_left {X Y Z W : Mon_V} (f : X --> Y) (g : Y --> Z) : ((f · g) #⊗ id W) = (f #⊗ id W) · (g #⊗ id W).
Proof.
  rewrite <- (functor_comp tensor).
  change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w).
  rewrite id_left.
  apply idpath.
Defined.

Lemma tensor_comp_right {X Y Z W : Mon_V} (f : X --> Y) (g : Y --> Z) : (id W #⊗ (f · g)) = (id W #⊗ f) · (id W #⊗ g).
Proof.
  rewrite <- (functor_comp tensor).
  change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w).
  rewrite id_left.
  apply idpath.
Defined.

Lemma I_posttensor_faithful {X Y : Mon_V} {f g : X --> Y} : (f #⊗ id I) = (g #⊗ id I) -> f = g.
Proof.
  intro H.
  apply (pre_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 r_unitor _))).
  use (pathscomp0 (! (nat_trans_ax r_unitor _ _ f))).
  use (pathscomp0 _ (nat_trans_ax r_unitor _ _ g)).
  apply cancel_postcomposition.
  assumption.
Defined.

Lemma I_pretensor_faithful {X Y : Mon_V} {f g : X --> Y} : (id I #⊗ f) = (id I #⊗ g) -> f = g.
Proof.
  intro H.
  apply (pre_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 l_unitor _))).
  use (pathscomp0 (! (nat_trans_ax l_unitor _ _ f))).
  use (pathscomp0 _ (nat_trans_ax l_unitor _ _ g)).
  apply cancel_postcomposition.
  assumption.
Defined.

(*
  The following three lemmas are from [Kelly, 1964].
  https://doi.org/10.1016/0021-8693(64)90018-3
  monoidal_cat_triangle_eq <-> diagram (6) in [Kelly, 1964]
  monoidal_cat_pentagon_eq <-> diagram (1)
  right_unitor_of_tensor <-> diagram (7)
  left_unitor_right_unitor_of_unit <-> diagram (4)
  left_unitor_of_tensor <-> diagram (5)
*)
Lemma right_unitor_of_tensor (X Y : Mon_V) : r_unitor (X ⊗ Y) = α ((X, Y), I) · (id X #⊗ r_unitor Y).
Proof.
  apply I_posttensor_faithful.
  rewrite tensor_comp_left.
  apply (post_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 α (_, _)))).
  rewrite assoc'.
  apply (transportb (λ h, _ = _ · h) (nat_trans_ax α _ _ ((_#, _)#, _))).
  simpl.
  rewrite assoc.
  apply (transportb (λ h, _ = _ · #tensor (id _ #, h)) (monoidal_cat_triangle_eq Mon_V _ _)).
  apply (transportf (λ k, _ = _ · #tensor (k #, _)) (id_left (id X))).
  change (?x · ?z #, ?y · ?w) with ((x #, y) · (z #, w)).
  rewrite (functor_comp tensor).
  apply (transportb (λ h, h · _ = _) (monoidal_cat_triangle_eq Mon_V _ _)).
  apply (transportf (λ h, _ · #tensor (h #, _) · _ = _) (functor_id tensor (X, Y))).
  rewrite assoc'.
  apply (transportb (λ h, _ · h = _) (nat_trans_ax α _ _ ((_#, _)#, _))).
  rewrite !assoc.
  apply cancel_postcomposition.
  apply monoidal_cat_pentagon_eq.
Defined.

Lemma left_unitor_right_unitor_of_unit : l_unitor I = r_unitor I.
Proof.
  apply I_pretensor_faithful.
  apply (pre_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 α ((_, _), _)))).
  apply (pathscomp0 (! (monoidal_cat_triangle_eq Mon_V I I))).
  use (pathscomp0 _ (right_unitor_of_tensor I I)).
  apply (post_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 r_unitor _))).
  apply (nat_trans_ax r_unitor).
Defined.

Lemma left_unitor_of_tensor (X Y : Mon_V) : α ((I, X), Y) · l_unitor (X ⊗ Y) = l_unitor X #⊗ id Y.
Proof.
  apply I_pretensor_faithful.
  rewrite tensor_comp_right.
  apply (pre_comp_with_z_iso_is_inj (pr2 α ((I, (I ⊗ X)), Y))).
  use (pathscomp0 _ (nat_trans_ax α _ _ ((_ #, _) #, _))).
  simpl.
  apply (pre_comp_with_z_iso_is_inj (functor_on_is_z_isomorphism (functor_fix_snd_arg _ _ _ tensor Y) (pr2 α ((I, I), X)))).
  simpl.
  unfold functor_fix_snd_arg_mor.
  change (make_dirprod ?x ?y) with (x #, y).
  rewrite !assoc.
  apply (transportf (λ h, _ = h · _) (functor_comp tensor _ _)).
  change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w).
  apply (transportf (λ h, h · _ = _) (monoidal_cat_pentagon_eq Mon_V I I X Y)).
  rewrite assoc'.
  apply (transportf (λ h, _ · h = _) (monoidal_cat_triangle_eq Mon_V _ _)).
  simpl.
  apply (transportf (λ h, _ · #tensor (_ #, h) = _) (functor_id tensor (X, Y))).
  apply (pathscomp0 (! (nat_trans_ax α _ _ ((_ #, _) #, _)))).
  simpl.
  apply cancel_postcomposition.
  apply pathsinv0.
  apply maponpaths.
  apply dirprod_paths; simpl; [|apply id_left].
  apply pathsinv0.
  apply monoidal_cat_triangle_eq.
Defined.

(* Corollaries for the inverses of left and right unitors. *)

Lemma tensor_z_isomorphism_left : ∏ (x y z : Mon_V) (f : x --> y) (f_z_iso : is_z_isomorphism f), # tensor (is_z_isomorphism_mor f_z_iso #, id z) = is_z_isomorphism_mor (functor_on_is_z_isomorphism (functor_fix_snd_arg _ _ _ tensor z) f_z_iso).
Proof.
  intros.
  reflexivity.
Qed.

Lemma tensor_z_isomorphism_right : ∏ (x y z : Mon_V) (f : x --> y) (f_z_iso : is_z_isomorphism f), # tensor (id z #, is_z_isomorphism_mor f_z_iso) = is_z_isomorphism_mor (functor_on_is_z_isomorphism (functor_fix_fst_arg _ _ _ tensor z) f_z_iso).
Proof.
  intros.
  reflexivity.
Qed.

Lemma monoidal_cat_triangle_eq_inv (X Y : Mon_V) : (nat_z_iso_to_trans_inv r_unitor X #⊗ id Y) · α ((X, I), Y) = (id X #⊗ nat_z_iso_to_trans_inv l_unitor Y).
Proof.
  cbn.
  rewrite (tensor_z_isomorphism_right _ _ _ _ _ : #tensor _ = _).
  rewrite (tensor_z_isomorphism_left _ _ _ _ _ : #tensor _ = _).
  change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)).
  apply z_iso_inv_on_right, z_iso_inv_on_left.
  apply monoidal_cat_triangle_eq.
Qed.

Corollary left_unitor_inv_right_unitor_inv_of_unit : nat_z_iso_to_trans_inv l_unitor I = nat_z_iso_to_trans_inv r_unitor _.
Proof.
  apply (post_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 l_unitor _))).
  apply (pathscomp0 (is_inverse_in_precat2 (is_z_isomorphism_is_inverse_in_precat (pr2 l_unitor _)))).
  apply (transportb (λ f, id _ = is_z_isomorphism_mor _ · f) left_unitor_right_unitor_of_unit).
  apply pathsinv0.
  apply (is_inverse_in_precat2 (is_z_isomorphism_is_inverse_in_precat (pr2 r_unitor _))).
Qed.

Corollary left_unitor_inv_of_tensor (X Y : Mon_V) : (nat_z_iso_to_trans_inv l_unitor _ #⊗ id _) · α ((_, _), _) = nat_z_iso_to_trans_inv l_unitor (X ⊗ Y).
Proof.
  simpl.
  rewrite tensor_z_isomorphism_left.
  change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)).
  apply z_iso_inv_on_right, z_iso_inv_on_left.
  apply pathsinv0.
  apply left_unitor_of_tensor.
Qed.

Corollary right_unitor_inv_of_tensor (X Y : Mon_V) : (id _ #⊗ nat_z_iso_to_trans_inv r_unitor _) = nat_z_iso_to_trans_inv r_unitor (X ⊗ Y)  · α ((_, _), _).
Proof.
  simpl.
  rewrite tensor_z_isomorphism_right.
  change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)).
  apply pathsinv0.
  apply z_iso_inv_on_right, z_iso_inv_on_left.
  apply right_unitor_of_tensor.
Qed.

End coherence_lemmas.