Set Implicit Arguments.

Require Import Syntax.
Require Import SyntaxExpr.
Require Import GeneralTactics.
Require Import Notations3.
Require Import SemanticsExpr.
Require Import GoodOptimizer.

Require Import StringSet.
Module Import SS := StringSet.
Require Import StringSetFacts.
Module SSF := StringSetFacts.
Require Import StringSetTactics.

Require Import StringMap.
Import StringMap.
Require Import StringMapFacts.

Definition const_dec : forall e, {w | e = Const w} + {~ exists w, e = Const w}.
  intros; destruct e; solve [ right; intuition; openhyp; intuition | left; eauto ].
Qed.

Definition const_zero_dec : forall e, {e = Const $0} + {e <> Const $0}.
  intros; destruct e; solve [right; intuition | destruct (weq w $0); intuition ].
Qed.

Ltac f_equal' :=
  match goal with
    | |- (if ?E1 then _ else _) = (if ?E2 then _ else _) => replace E2 with E1; try reflexivity
  end.

Ltac openhyp' :=
  repeat match goal with
           | H : context [const_dec ?E] |- _ => destruct (const_dec E)
           | |- context [const_dec ?E] => destruct (const_dec E)
           | H : context [const_zero_dec ?E] |- _ => destruct (const_zero_dec E)
           | |- context [const_zero_dec ?E] => destruct (const_zero_dec E)
           | H : context [option_dec ?E] |- _ => destruct (option_dec E)
           | |- context [option_dec ?E] => destruct (option_dec E)
           | H : context [ { _ | _ } ] |- _ => destruct H
         end.

Ltac descend :=
  repeat match goal with
           | [ |- exists x, _ ] => eexists
         end.

Ltac unfold_all :=
  repeat match goal with
           | H := _ |- _ => unfold H in *; clear H
         end.

Definition SET := SS.t.
Definition Map := t W.
Definition empty_set := SS.empty.
Definition empty_map := empty W.
Definition Submap elt m1 m2 := forall k v, @find elt k m1 = Some v -> find k m2 = Some v.
Definition subtract elt m s := @filter elt (fun k _ => negb (SS.mem k s)) m.

Section TopSection.

  Notation "m %%- k" := (remove k m) (at level 60).
  Infix "%<=" := Subset (at level 60).
  Infix "%%<=" := Submap (at level 60).
  Infix "+" := union.
  Infix "-" := subtract.
  Notation "! x" := (singleton x) (at level 100).
  Notation "[]" := (@empty _).
  Open Scope stmt_scope.
  Infix "<-" := Syntax.Assign.

  Fixpoint const_folding_expr (e : Expr) (env : Map) : Expr :=
    match e with
      | Var var =>
        match option_dec (find var env) with
          | inleft (exist w _) => Const w
          | _ => e
        end
      | Const w => e
      | SyntaxExpr.Binop op a b =>
        let a' := const_folding_expr a env in
        let b' := const_folding_expr b env in
        match const_dec a', const_dec b' with
          | inleft (exist wa _),  inleft (exist wb _) => Const (evalBinop op wa wb)
          | _, _ => SyntaxExpr.Binop op a' b'
        end
      | TestE op a b =>
        let a' := const_folding_expr a env in
        let b' := const_folding_expr b env in
        match const_dec a', const_dec b' with
          | inleft (exist wa _),  inleft (exist wb _) => Const (if evalTest op wa wb then $1 else $0)
          | _, _ => TestE op a' b'
        end
    end.

  Fixpoint const_folding (s : Stmt) (map : Map) : Stmt * Map * SET :=
    match s with
      | skip => (skip, map, empty_set)
      | a ;; b =>
        let result_a := const_folding a map in
        let map' := snd (fst result_a) in
        let result_b := const_folding b map' in
        let a' := fst (fst result_a) in
        let b' := fst (fst result_b) in
        let map'' := snd (fst result_b) in
        let written_a := snd result_a in
        let written_b := snd result_b in
        (a' ;; b', map'', written_a + written_b)
      | Syntax.If c t f =>
        let c' := const_folding_expr c map in
        match const_dec c' with
          | inleft (exist w _) =>
            if wneb w $0 then
              const_folding t map
            else
              const_folding f map
          | inright _ =>
            let result_t := const_folding t map in
            let result_f := const_folding f map in
            let t' := fst (fst result_t) in
            let f' := fst (fst result_f) in
            let written_t := snd result_t in
            let written_f := snd result_f in
            (* written vars in branches will no longer have known values *)
            let map' := map - written_t - written_f in
            (Syntax.If c' t' f', map', written_t + written_f)
        end
      | Syntax.While c b =>
        if const_zero_dec (const_folding_expr c map) then
          (skip, map, empty_set)
        else
          let c' := const_folding_expr c [] in
          let result_b := const_folding b [] in
          let b' := fst (fst result_b) in
          let written_b := snd result_b in
          (* written vars in loop body will no longer have known values *)
          let map' := map - written_b in
          (Syntax.While c' b', map', written_b)
      | x <- e =>
        let e' := const_folding_expr e map in
        match const_dec e' with
          | inleft (exist w _) =>
            let map' := add x w map  in
            (x <- w, map', !x)
          | inright _ =>
            let map' := map %%- x in
            (x <- e', map', !x)
        end
      | Syntax.Label x l =>
        let map := map %%- x in
        (s, map, !x)
      | Syntax.Call x f args =>
        let f' := const_folding_expr f map in
        let args' := List.map (fun e => const_folding_expr e map) args in
        match x with
          | Some s =>
            let map := map %%- s in
            (Syntax.Call x f' args', map, !s)
          | None =>
            (Syntax.Call x f' args', map, empty_set)
        end
    end.

  Definition constant_folding s := fst (fst (const_folding s empty_map)).

  Definition optimizer := constant_folding.

  Definition opt : Optimizer := fun s _ => optimizer s.

  Lemma union_same_subset : forall s, s + s %<= s.
    intros; subset_solver.
  Qed.

  Require Import GeneralTactics2.
  Require Import Bool.
  Require Import Morphisms.

  Lemma subtract_none : forall elt (m : t elt) s x, SS.In x s -> find x (m - s) = None.
    unfold subtract; intros.
    eapply not_find_in_iff.
    nintro.
    eapply In_MapsTo in H0; openhyp.
    eapply filter_iff in H0; openhyp.
    eapply negb_true_iff in H1.
    eapply not_mem_iff in H1; intuition.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
  Qed.

  Lemma empty_submap : forall elt (m : t elt), [] %%<= m.
    unfold Submap; intros.
    eapply find_2 in H; eapply empty_mapsto_iff in H; intuition.
  Qed.

  Lemma subtract_submap : forall elt (m : t elt) s, m - s %%<= m.
    unfold subtract, Submap.
    intros.
    eapply find_2 in H.
    eapply filter_iff in H.
    openhyp.
    eapply find_1; eauto.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
  Qed.

  Lemma subtract_mapsto_iff : forall elt m s k v, @MapsTo elt k v (m - s) <-> (MapsTo k v m /\ ~ SS.In k s).
    unfold subtract.
    split; intros.
    eapply filter_iff in H.
    openhyp.
    split; eauto.
    eapply negb_true_iff in H0.
    eapply not_mem_iff; eauto.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
    openhyp.
    eapply filter_iff.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
    split; eauto.
    eapply negb_true_iff.
    eapply not_mem_iff; eauto.
  Qed.

  Section HintsSection.

    Hint Resolve empty_iff.
    Hint Unfold Subset.
    Hint Unfold Submap.
    Hint Resolve subtract_none.
    Hint Resolve singleton_iff.
    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Immediate subset_refl.
    Hint Resolve union_same_subset.
    Hint Resolve empty_submap.
    Hint Resolve subtract_submap.
    Hint Resolve union_iff union_1 union_2 union_3.

    Definition agree_with (v : vals) (m : Map) :=
      forall x w,
        find x m = Some w ->
        Locals.sel v x = w.

    Lemma agree_with_remove : forall local m x e, agree_with local m -> agree_with (upd local x e) (m %%- x).
      unfold agree_with; intros; destruct (string_dec x x0).
      subst.
      eapply find_2 in H0; eapply remove_mapsto_iff in H0; intuition.
      eapply find_2 in H0; eapply remove_mapsto_iff in H0; openhyp.
      rewrite sel_upd_ne.
      eapply H; eauto.
      eapply find_1; eauto.
      eauto.
    Qed.
    Hint Resolve agree_with_remove.

    Lemma agree_with_add : forall local m x w, agree_with local m -> agree_with (upd local x w) (add x w m).
      unfold agree_with; intros; destruct (string_dec x x0).
      subst.
      rewrite sel_upd_eq in *.
      eapply find_2 in H0; eapply add_mapsto_iff in H0; openhyp; intuition.
      eauto.
      rewrite sel_upd_ne in *.
      eapply H; eauto.
      eapply find_1.
      eapply find_2 in H0; eapply add_mapsto_iff in H0; openhyp; intuition.
      eauto.
    Qed.
    Hint Resolve agree_with_add.

    Lemma everything_agree_with_empty_map : forall v, agree_with v empty_map.
      unfold agree_with.
      intros.
      eapply find_2 in H; eapply empty_mapsto_iff in H.
      intuition.
    Qed.
    Hint Resolve everything_agree_with_empty_map.

    Definition agree_except (a b : vals) (s : SET) :=
      forall x,
        Locals.sel a x <> Locals.sel b x -> SS.In x s.

    Lemma agree_except_upd : forall local x w, agree_except local (upd local x w) (!x).
      unfold agree_except.
      intros.
      destruct (string_dec x x0).
      subst.
      eapply singleton_iff; eauto.
      rewrite sel_upd_ne in H.
      intuition.
      eauto.
    Qed.
    Hint Resolve agree_except_upd.

    Lemma agree_except_same : forall local s, agree_except local local s.
      intuition.
    Qed.
    Hint Resolve agree_except_same.

    Lemma agree_except_incl : forall v1 v2 s s', agree_except v1 v2 s -> s %<= s' -> agree_except v1 v2 s'.
      unfold agree_except; eauto.
    Qed.
    Hint Resolve agree_except_incl.

    Lemma agree_except_trans : forall m1 m2 m3 s1 s2, agree_except m1 m2 s1 -> agree_except m2 m3 s2 -> agree_except m1 m3 (s1 + s2).
      unfold agree_except.
      intros.
      destruct (weq (Locals.sel m1 x) (Locals.sel m2 x)).
      destruct (weq (Locals.sel m2 x) (Locals.sel m3 x)).
      intuition.
      eauto.
      eauto.
    Qed.
    Hint Resolve agree_except_trans.

    Lemma agree_with_agree_except_subtract : forall v1 v2 m s, agree_with v1 m -> agree_except v1 v2 s -> agree_with v2 (m - s).
      unfold agree_with, agree_except.
      intros.
      destruct (weq (Locals.sel v1 x) (Locals.sel v2 x)).
      rewrite <- e.
      eapply H.
      eapply find_2 in H1.
      eapply subtract_mapsto_iff in H1.
      openhyp.
      eapply find_1; eauto.
      eapply H0 in n.
      eapply subtract_none with (m := m) in n.
      erewrite H1 in n.
      intuition.
    Qed.
    Hint Resolve agree_with_agree_except_subtract.

  End HintsSection.

  Hint Resolve union_subset_1.
  Hint Resolve union_subset_2.
  Hint Immediate subset_refl.
  Hint Resolve union_same_subset.
  Hint Resolve empty_submap.
  Hint Resolve subtract_submap.

  Hint Resolve agree_with_remove.
  Hint Resolve agree_with_add.
  Hint Resolve everything_agree_with_empty_map.
  Hint Resolve agree_except_upd.
  Hint Resolve agree_except_same.
  Hint Resolve agree_except_trans.
  Hint Resolve agree_with_agree_except_subtract.
  Hint Resolve agree_except_incl.

  Remove Hints WordKey.W_as_OT.eq_trans.
  Remove Hints WordKey.W_as_OT_new.eq_trans.

  Lemma const_folding_expr_correct :
    forall e m local,
      agree_with local m ->
      eval local (const_folding_expr e m) = eval local e.
  Proof.
    induction e; simpl; intuition; openhyp'; simpl in *; eauto.

    symmetry; eauto.

    f_equal.
    erewrite <- (IHe1 m); eauto.
    erewrite e0; eauto.
    erewrite <- (IHe2 m); eauto.
    erewrite e; eauto.

    f_equal; eauto.

    f_equal; eauto.

    f_equal'; f_equal.
    erewrite <- (IHe1 m); eauto.
    erewrite e0; eauto.
    erewrite <- (IHe2 m); eauto.
    erewrite e; eauto.

    f_equal'; f_equal; eauto.

    f_equal'; f_equal; eauto.
  Qed.

  Lemma const_folding_expr_correct' :
    forall e e' m local,
      e' = const_folding_expr e m ->
      agree_with local m ->
      eval local e' = eval local e.
  Proof.
    intros; subst; eapply const_folding_expr_correct; eauto.
  Qed.

  Lemma const_folding_expr_submap_const : forall e m w, const_folding_expr e m = Const w -> forall m', m %%<= m' -> const_folding_expr e m' = Const w.
    induction e; simpl; intuition; openhyp'; simpl in *; try discriminate.

    eapply H0 in e0.
    rewrite e0 in e.
    injection e; intros; subst.
    eauto.

    eapply H0 in e0.
    rewrite e0 in e.
    discriminate.

    eapply IHe1 in e4; eauto.
    eapply IHe2 in e3; eauto.
    rewrite e0 in e4; injection e4; intros; subst.
    rewrite e in e3; injection e3; intros; subst.
    eauto.

    contradict n.
    descend.
    eauto.

    contradict n.
    descend.
    eauto.

    eapply IHe1 in e4; eauto.
    eapply IHe2 in e3; eauto.
    rewrite e0 in e4; injection e4; intros; subst.
    rewrite e in e3; injection e3; intros; subst.
    eauto.

    contradict n.
    descend.
    eauto.

    contradict n.
    descend.
    eauto.

  Qed.
  Hint Resolve const_folding_expr_submap_const.

  Lemma not_const_zero_submap : forall e m m', const_folding_expr e m <> Const $0 -> m' %%<= m -> const_folding_expr e m' <> Const $0.
    intuition eauto.
  Qed.
  Hint Resolve not_const_zero_submap.

  Lemma not_const_zero_empty_map : forall e m, const_folding_expr e m <> Const $0 -> const_folding_expr e empty_map <> Const $0.
    intros.
    eapply not_const_zero_submap; eauto.
    eapply empty_submap.
  Qed.
  Hint Resolve not_const_zero_empty_map.

  Lemma break_pair : forall A B (p : A * B), p = (fst p, snd p).
    intros; destruct p; eauto.
  Qed.

End TopSection.

Ltac rewrite_expr := repeat erewrite const_folding_expr_correct in * by eauto.

Lemma const_folding_expr_correct_list :
  forall es m local,
    agree_with local m ->
    List.map (fun e => eval local (const_folding_expr e m)) es = List.map (eval local) es.
Proof.
  induction es; simpl; intuition; rewrite_expr; f_equal; eauto.
Qed.

Ltac rewrite_expr_list := repeat erewrite map_map in *; repeat erewrite const_folding_expr_correct_list in * by eauto.

Require Import ADT.

Module Make (Import E : ADT).

  Module Import GoodOptimizerMake := GoodOptimizer.Make E.
  Require Import Semantics.
  Import SemanticsMake.

  Section TopSection.

    Notation "m %%- k" := (remove k m) (at level 60).
    Infix "%<=" := Subset (at level 60).
    Infix "%%<=" := Submap (at level 60).
    Infix "+" := union.
    Infix "-" := subtract.
    Notation "! x" := (singleton x) (at level 100).
    Notation "[]" := empty_map.
    Open Scope stmt_scope.
    Infix "<-" := Syntax.Assign.

    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Immediate subset_refl.
    Hint Resolve union_same_subset.
    Hint Resolve empty_submap.
    Hint Resolve subtract_submap.

    Hint Resolve agree_with_remove.
    Hint Resolve agree_with_add.
    Hint Resolve everything_agree_with_empty_map.
    Hint Resolve agree_except_upd.
    Hint Resolve agree_except_same.
    Hint Resolve agree_except_trans.
    Hint Resolve agree_with_agree_except_subtract.
    Hint Resolve agree_except_incl.

    Hint Unfold RunsTo.
    Hint Constructors Semantics.RunsTo.
    Hint Unfold Safe.
    Hint Constructors Semantics.Safe.

    Lemma while_case :
      forall fs t v v',
        RunsTo fs t v v' ->
        forall s c b m,
          let result := const_folding s m in
          let s' := fst (fst result) in
          let m' := snd (fst result) in
          let written := snd result in
          s = Syntax.While c b ->
          t = s' ->
          agree_with (fst v) m ->
          (let s := b in
           (* the induction hypothesis from Lemma const_folding_is_backward_simulation' *)

           forall (vs : vals) (heap : Heap) (vs' : vals)
                  (heap' : Heap) (m : Map),
             let result := const_folding s m in
             let s' := fst (fst result) in
             let m' := snd (fst result) in
             let written := snd result in
             RunsTo fs s' (vs, heap) (vs', heap') ->
             agree_with vs m ->
             RunsTo fs s (vs, heap) (vs', heap') /\
             agree_with vs' m' /\
             agree_except vs vs' written

          ) ->
          RunsTo fs s v v' /\
          agree_with (fst v') m' /\
          agree_except (fst v) (fst v') written.
    Proof.
      induction 1; simpl; intros; unfold_all; subst.

      (* skip *)
      simpl in *; openhyp'; simpl in *; intuition.
      econstructor 6.
      erewrite <- const_folding_expr_correct'.
      2 : symmetry; eauto.
      simpl; eauto.
      simpl; eauto.
      econstructor.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* while *)
      simpl in *; openhyp'; simpl in *; try discriminate.
      injection H3; intros; subst.
      destruct v; simpl in *.
      destruct v'; simpl in *.
      eapply H5 in H0; eauto; openhyp.
      destruct v''; simpl in *.
      edestruct IHRunsTo2; try reflexivity.
      3 : eauto.
      replace (While (const_folding_expr c _) (fst (fst (const_folding b _)))) with (fst (fst (const_folding (While c b ) (m - snd (const_folding b []))))).
      Focus 2.
      simpl in *; openhyp'; [contradict e; eauto | simpl; eauto ].
      eapply not_const_zero_submap; eauto.
      eauto.
      eauto.
      openhyp.
      simpl in *; openhyp'; [ contradict e; eauto | ]; simpl in *.
      eapply not_const_zero_submap; eauto.
      rewrite_expr.
      intuition eauto.

      (* while *)
      simpl in *; openhyp'; simpl in *; try discriminate.
      injection H1; intros; subst.
      rewrite_expr.
      intuition eauto.

      (* call *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* call *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* label *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* assign *)
      simpl in *; openhyp'; simpl in *; intuition.

    Qed.

    Lemma const_folding_is_backward_simulation :
      forall fs s vs heap vs' heap' m,
        let result := const_folding s m in
        let s' := fst (fst result) in
        let m' := snd (fst result) in
        let written := snd result in
        RunsTo fs s' (vs, heap) (vs', heap') ->
        agree_with vs m ->
        RunsTo fs s (vs, heap) (vs', heap') /\
        agree_with vs' m' /\
        agree_except vs vs' written.
    Proof.
      induction s;
      match goal with
        | |- context [Syntax.While] => solve [intros; split; intros; eapply while_case in H; eauto; openhyp; eauto]
        | |- _ => idtac
      end; simpl; intros.

      (* skip *)
      inversion H; unfold_all; subst; rewrite_expr; eauto.

      (* seq *)
      inversion H; unfold_all; subst.
      destruct v'; simpl in *.
      eapply IHs1 in H3; eauto; openhyp.
      eapply IHs2 in H6; eauto; openhyp.
      eauto 6.

      (* if *)
      openhyp'.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eapply IHs1 in H; eauto; openhyp.
      replace x with (eval vs x) in e1 by eauto.
      rewrite <- e0 in e1.
      rewrite_expr.
      eauto.
      eapply IHs2 in H; eauto; openhyp.
      replace x with (eval vs x) in e1 by eauto.
      rewrite <- e0 in e1.
      rewrite_expr.
      eauto.

      simpl in *.
      inversion H; unfold_all; subst.
      rewrite_expr.
      eapply IHs1 in H7; eauto; openhyp.
      intuition eauto.
      rewrite_expr.
      eapply IHs2 in H7; eauto; openhyp.
      split; [econstructor 4 | ]; eauto.

      Focus 3.
      (* assign *)
      openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      replace x with (eval vs x) by eauto.
      rewrite <- e0.
      rewrite_expr.
      econstructor; eauto.
      eauto.

      split.
      rewrite_expr.
      econstructor; eauto.
      eauto.

      (* call *)
      destruct o; openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallInternal; intros.
      simpl in *.
      specialize (H1 _ fs (Some s)).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallForeign; intros.
      simpl in *.
      specialize (H1 _ fs (Some s)).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallInternal; intros.
      simpl in *.
      specialize (H1 _ fs None).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallForeign; intros.
      simpl in *.
      specialize (H1 _ fs None).
      simpl in *.
      eapply H1; eauto.
      eauto.

      (* label *)
      openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      rewrite_expr.
      econstructor; eauto.
      eauto.
    Qed.

    Lemma PreserveRunsTo_opt : PreserveRunsTo opt.
      unfold PreserveRunsTo, opt, optimizer, constant_folding; intros.
      destruct v.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H; openhyp; eauto.
    Qed.

    Lemma const_folding_is_safety_preservation :
      forall fs s vs heap m,
        let result := const_folding s m in
        let s' := fst (fst result) in
        Safe fs s (vs, heap) ->
        agree_with vs m ->
        Safe fs s' (vs, heap).
    Proof.
      induction s.

      Focus 4.
      intros.
      unfold_all.
      eapply
        (Safe_coind
           (fun s' v =>
              (exists c b m,
                 let s := While c b in
                 Safe fs s v /\
                 agree_with (fst v) m /\
                 (let s := b in
                  forall (vs : vals) (heap : Heap) (m : Map),
                    Safe fs s (vs, heap) ->
                    agree_with vs m -> Safe fs (fst (fst (const_folding s m))) (vs, heap)
                 ) /\
                 s' = fst (fst (const_folding s m))) \/
              Safe fs s' v
        )); [ .. | left; descend; intuition eauto ]; clear; simpl; intros; openhyp.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      inversion_clear H.
      intuition eauto.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      inversion H; subst.
      openhyp.
      intuition eauto.
      right; intuition eauto.

      (* while *)
      simpl in *; openhyp'; simpl in *; intuition.
      injection H2; intros; subst.
      rewrite_expr.
      inversion H; unfold_all; subst.
      destruct v; simpl in *.
      left.
      repeat split.
      eauto.
      right.
      eauto.

      intros.
      left.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H3; eauto; openhyp.
      descend; intuition.
      simpl in *; openhyp'; [ contradict e; eauto | ]; simpl in *.
      eapply not_const_zero_empty_map; eauto.
      eauto.

      right.
      eauto.

      inversion H; unfold_all; subst.
      intuition eauto.
      right.
      intuition eauto.

      simpl in *; openhyp'; simpl in *; intuition.

      inversion H; unfold_all; subst.
      left.
      descend.
      intuition eauto.
      right.
      descend.
      intuition eauto.

      simpl in *; openhyp'; simpl in *; intuition.
      inversion_clear H; eauto.

      (* skip *)
      eauto.

      (* seq *)
      simpl; intros; inversion H; unfold_all; subst.
      econstructor.
      simpl in *.
      eapply IHs1; eauto.
      intros.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H1.
      openhyp.
      eapply IHs2; eauto.
      eauto.

      (* if *)
      simpl; intros; openhyp'.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      inversion H; subst.
      unfold_all.
      openhyp.
      eauto.
      erewrite <- const_folding_expr_correct' in H1.
      2 : symmetry; eauto.
      simpl in *.
      intuition.
      eauto.
      inversion H; subst.
      unfold_all.
      openhyp.
      erewrite <- const_folding_expr_correct' in H1.
      2 : symmetry; eauto.
      simpl in *.
      intuition.
      eauto.
      eauto.

      simpl in *.
      inversion H; subst.
      unfold_all.
      openhyp.
      econstructor.
      left.
      rewrite_expr.
      intuition eauto.
      eapply IHs1; eauto.
      econstructor.
      right.
      rewrite_expr.
      intuition eauto.
      eapply IHs2; eauto.

      (* call *)
      destruct o; simpl; intros; inversion H; unfold_all; subst.

      econstructor; rewrite_expr; rewrite_expr_list; eauto.
      rewrite map_length; eauto.

      eapply SafeCallForeign; rewrite_expr; eauto; rewrite_expr_list; eauto.

      econstructor; rewrite_expr; rewrite_expr_list; eauto.
      rewrite map_length; eauto.

      eapply SafeCallForeign; rewrite_expr; eauto; rewrite_expr_list; eauto.

      (* assign *)
      simpl; intros; simpl in *; openhyp'; simpl in *; eauto.

      (* label *)
      simpl; intros; simpl in *; openhyp'; simpl in *; eauto.

    Qed.

    Lemma PreserveSafe_opt : PreserveSafe opt.
      unfold PreserveSafe, opt, optimizer, constant_folding; intros.
      destruct v.
      eapply const_folding_is_safety_preservation in H; openhyp; eauto.
    Qed.

    Require Import FreeVarsExpr.

    Lemma const_folding_expr_footprint : forall e m, SS.Subset (free_vars (const_folding_expr e m)) (free_vars e).
    Proof.
      induction e; simpl; intros; openhyp'; simpl in *; subset_solver; eauto using subset_trans.
    Qed.
    Hint Resolve const_folding_expr_footprint.

    Lemma const_folding_expr_footprint_list : forall es m, SS.Subset (Union.union_list (List.map free_vars (List.map (fun e => const_folding_expr e m) es))) (Union.union_list (List.map free_vars es)).
    Proof.
      unfold Union.union_list.
      induction es; simpl; intuition eauto.
      subset_solver; eauto using subset_trans.
    Qed.

    Hint Resolve const_folding_expr_footprint_list.

    Require Import FreeVars.

    Lemma const_folding_footprint : forall s m, SS.Subset (free_vars (fst (fst (const_folding s m)))) (free_vars s).
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; subset_solver.
      eauto using subset_trans.
      eauto using subset_trans.
      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      destruct o; simpl in *.
      subset_solver; eauto using subset_trans.
      subset_solver; eauto using subset_trans.
      eauto using subset_trans.
    Qed.

    Lemma optimizer_footprint : forall s, SS.Subset (free_vars (optimizer s)) (free_vars s).
      unfold optimizer, constant_folding; intros; eapply const_folding_footprint.
    Qed.

    Open Scope nat.

    Require Import Le.
    Require Import Arith.Max.
    Require Import MaxFacts.

    Hint Resolve both_le Le.le_n_S.

    Require Import DepthExpr.

    Lemma const_folding_expr_depth : forall e m, depth (const_folding_expr e m) <= depth e.
    Proof.
      induction e; simpl; intuition; openhyp'; simpl in *; eauto.
    Qed.
    Hint Resolve const_folding_expr_depth.

    Lemma const_folding_expr_depth_list : forall es m, le (Max.max_list 0 (List.map depth (List.map (fun e => const_folding_expr e m) es))) (Max.max_list 0 (List.map depth es)).
    Proof.
      unfold Max.max_list.
      induction es; simpl; intuition eauto.
    Qed.

    Hint Resolve const_folding_expr_depth_list.

    Require Import Depth.

    Hint Extern 0 (le _ _) => progress (simpl; max_solver).

    Lemma const_folding_depth : forall s m, depth (fst (fst (const_folding s m))) <= depth s.
    Proof.
      induction s; simpl; intuition; openhyp'; simpl in *; eauto.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eauto using le_trans.
      eauto using le_trans.
      destruct o; simpl in *.
      max_solver; eauto using le_trans.
      max_solver; eauto using le_trans.
    Qed.

    Lemma optimizer_depth : forall s, depth (optimizer s) <= depth s.
      unfold optimizer, constant_folding; intros; eapply const_folding_depth.
    Qed.

    Import NPeano.Nat.
    Require Import GetLocalVars.
    Require Import GetLocalVarsFacts.

    Lemma PreserveGoodSize_opt : PreserveGoodSize opt.
      unfold PreserveGoodSize, opt; intros.
      eapply goodSize_weaken; eauto.
      eapply add_le_mono.
      2 : eapply optimizer_depth.
      eapply get_local_vars_cardinal.
      eapply optimizer_footprint; eauto.
    Qed.

    Require Import CompileStmtSpec.
    Require Import SetoidListFacts.
    Require Import GeneralTactics2.

    Require Import WellFormed.

    Hint Constructors args_not_too_long.

    Lemma const_folding_wellformed : forall s m, wellformed s -> wellformed (fst (fst (const_folding s m))).
      unfold wellformed.
      induction s; simpl; intuition; openhyp'; inversion_clear H; simpl in *; eauto.
      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *; eauto.
      destruct o; simpl in *; eauto; econstructor; eauto; rewrite map_length; eauto.
    Qed.

    Lemma PreserveSynReq_opt : PreserveSynReq opt.
      unfold PreserveSynReq, opt; intros.
      unfold syn_req in *.
      unfold in_scope in *.
      openhyp.
      repeat split; eauto.
      eapply get_local_vars_subset; eauto.
      eapply const_folding_wellformed; eauto.
    Qed.

    Lemma good_optimizer : GoodOptimizer opt.
      unfold GoodOptimizer.
      split.
      eapply PreserveRunsTo_opt.
      split.
      eapply PreserveSafe_opt.
      split.
      eapply PreserveGoodSize_opt.
      eapply PreserveSynReq_opt.
    Qed.

  End TopSection.

End Make.


(***************************************************************************
* Safety for STLC with Exceptions - Proofs                                 *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN
  STLC_Exn_Definitions
  STLC_Exn_Infrastructure.

(* ********************************************************************** *)
(** * Proofs *)

(** Typing is preserved by weakening. *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq H: (E & G). gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_app.
  apply* typing_raise.
  apply* typing_catch.
Qed.

(** Typing is preserved by substitution. *)

Lemma typing_subst : forall F E t T z u U,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. gen_eq G: (E & z ~ U & F). gen F.
  induction Typt; introv Equ; subst; simpl subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs as y.
   rewrite* subst_open_var. apply_ih_bind* H0.
  apply* typing_app.
  apply* typing_raise.
  apply* typing_catch.
Qed.

(** Fails always returns a term of type exception. *)

Lemma fails_to_exception : forall E t T e,
  fails t e ->
  E |= t ~: T ->
  E |= e ~: typ_exn.
Proof.
  introv Fail Typ. induction Typ; inversions* Fail.
Qed.

(** Preservation (typing is preserved by reduction). *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red; inversions Red.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
   apply_empty* typing_subst.
  apply* typing_app.
  apply* typing_app.
  apply* typing_raise.
  apply* typing_catch.
  assumption.
  apply* typing_app. apply* fails_to_exception.
Qed.

(** Progress (a well-typed term is either a value or it can
  take a step of reduction). *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (empty : env). lets Typ': Typ.
  induction Typ; intros; subst.
  false* binds_empty_inv.
  branch* 1.
  right. destruct~ IHTyp1 as [Val1 | [[e Fail] | [t1' Red1]]].
    destruct~ IHTyp2 as [Val2 | [[e Fail2] | [t2' Red2]]].
      right. inversions Typ1; inversions Val1. exists* (t0 ^^ t2).
      left. exists* e.
      right. exists* (trm_app t1 t2').
    left. exists* e.
    right. exists* (trm_app t1' t2).
  right. destruct~ IHTyp as [Val1 | [[e Fail] | [t1' Red1]]].
    left. exists* t1.
    left. exists* e.
    right. exists* (trm_raise t1').
  branch 3. destruct~ IHTyp2 as [Val2 | [[e Fail] | [t2' Red2]]].
    exists* t2.
    exists* (trm_app t1 e).
    exists* (trm_catch t1 t2').
Qed.


(** R-CoqLib: general-purpose Coq libraries and tactics.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file, which is part of R-CoqLib, is free software. You can
 redistribute it and/or modify it under the terms of the GNU General
 Public License as published by the Free Software Foundation, either
 version 3 of the License (GNU GPL v3), or (at your option) any later
 version.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole R-CoqLib library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

More properties about real numbers.
*)

Require Export Reals Psatz.
Require Export Lia.
From Coquelicot Require Import Coquelicot.
Open Scope R_scope.

Lemma increasing_weaken f x y:
  (x < y -> f x < f y) ->
  x <= y -> f x <= f y.
Proof.
  intros.
  destruct (Req_dec x y); subst; lra.
Qed.

Lemma Rle_Rpower_strong:
  forall e n m : R, 1 < e -> n <= m -> Rpower e n <= Rpower e m.
Proof.
  unfold Rpower. intros.
  apply (increasing_weaken (fun t => exp (t * ln e))); auto.
  intros.
  apply exp_increasing.
  apply Rmult_lt_compat_r; auto.
  rewrite <- ln_1.
  apply ln_increasing; auto; lra.
Qed.

Lemma Rle_powerRZ_2:
  forall a b : R,
  forall n: nat,
  0 <= a ->
  a <= b -> powerRZ a (Z.of_nat n) <= powerRZ b (Z.of_nat n).
Proof.
  intros.
  induction n.
  + simpl. nra.
  + replace (Z.of_nat (S n)) with ( (Z.of_nat n + 1%Z)%Z) by lia.
    destruct H.
    - rewrite ?powerRZ_add; try nra.
      eapply Rmult_le_compat; try simpl; try nra.
      apply powerRZ_le; auto.
    - subst; destruct H0; subst; try simpl; try nra.
      assert ((0 < n + 1)%nat) by lia.
      pose proof pow_i (n+1) H0.
      replace (powerRZ 0 (Z.of_nat n + 1)) with
       (0^( n + 1)).
      pose proof pow_i (n+1) H0. rewrite H1. apply powerRZ_le; nra.
      rewrite ?pow_powerRZ; apply f_equal; lia.
Qed.

Lemma power_RZ_inv: forall x y, x <> 0 -> Rinv (powerRZ x y) = powerRZ x (-y).
Proof.
intros.
destruct y; simpl; auto.
apply Rinv_1.
apply Rinv_inv.
Qed.

Lemma lesseq_less_or_eq:
 forall x y : R,  x <= y -> x < y \/ x = y.
Proof. intros. lra. Qed.

Lemma Int_part_unique x z:
  IZR z <= x ->
  IZR z - x > -1 ->
  z = Int_part x.
Proof.
  intros.
  destruct (base_Int_part x).
  assert (K: -1 < IZR z - IZR (Int_part x) < 1) by lra.
  replace (-1) with (IZR (-1)) in K by reflexivity.
  replace (1) with (IZR (1)) in K by reflexivity.
  rewrite <- minus_IZR in K.
  destruct K as [KL KR].
  apply lt_IZR in KL.
  apply lt_IZR in KR.
  lia.
Qed.

Lemma IZR_Int_part x y:
  IZR x <= y ->
  (x <= Int_part y)%Z.
Proof.
  intros.
  destruct (base_Int_part y).
  assert (K: -1 < IZR (Int_part y) - IZR x) by lra.
  rewrite <- minus_IZR in K.
  replace (-1) with (IZR (-1)) in K by reflexivity.
  apply lt_IZR in K.
  lia.
Qed.

Lemma powerRZ_Rpower a b:
  0 < a ->
  powerRZ a b = Rpower a (IZR b).
Proof.
  intros.
  destruct b; simpl.
  {
    rewrite Rpower_O; auto.
  }
  {
   unfold IZR. rewrite <- INR_IPR.
    rewrite Rpower_pow; auto.
  }
  rewrite IZR_NEG. unfold IZR.  rewrite <- INR_IPR.
  rewrite Rpower_Ropp.
  rewrite Rpower_pow; auto.
Qed.

Lemma frac_part_sterbenz w:
  1 <= w ->
  IZR (Int_part w) / 2 <= w <= 2 * IZR (Int_part w).
Proof.
  intro K.
  generalize K.
  intro L.
  replace 1 with (IZR 1) in L by reflexivity.
  apply IZR_Int_part in L.
  apply IZR_le in L.
  simpl in L.
  destruct (base_Int_part w).
  lra.
Qed.

Lemma Rdiv_le_left d a b:
  0 < d ->
  a <= b * d ->
  a / d <= b.
Proof.
  intros.
  apply (Rmult_le_compat_r ( / d)) in H0.
  * rewrite Rmult_assoc in H0.
    rewrite <- Rinv_r_sym in H0; [ | lra].
    rewrite Rmult_1_r in H0.
    assumption.
  * cut (0 < / d); [ lra | ].
    apply Rinv_0_lt_compat.
    assumption.
Qed.

Lemma Rdiv_le_right_elim d a b:
  0 < d ->
  a <= b / d ->
  a * d <= b.
Proof.
  intros.
  apply Rdiv_le_left in H0.
  {
    unfold Rdiv in H0.
    rewrite Rinv_inv in H0; lra.
  }
  apply Rinv_0_lt_compat.
  assumption.
Qed.

Lemma Rdiv_lt_right d a b:
  0 < d ->
  a * d < b -> a < b / d.
Proof.
  intros.
  apply (Rmult_lt_compat_r ( / d)) in H0.
  * rewrite Rmult_assoc in H0.
    rewrite <- Rinv_r_sym in H0; [ | lra].
    rewrite Rmult_1_r in H0.
    assumption.
  * apply Rinv_0_lt_compat.
    assumption.
Qed.

Lemma Rdiv_lt_left d a b:
  0 < d ->
  a < b * d ->
  a / d < b.
Proof.
  intros.
  apply (Rmult_lt_compat_r ( / d)) in H0.
  * rewrite Rmult_assoc in H0.
    rewrite <- Rinv_r_sym in H0; [ | lra].
    rewrite Rmult_1_r in H0.
    assumption.
  * apply Rinv_0_lt_compat.
    assumption.
Qed.

Lemma Rdiv_lt_left_elim d a b:
  0 < d ->
  a / d < b -> a < b * d.
Proof.
  intros.
  apply Rdiv_lt_right in H0.
  {
    unfold Rdiv in H0.
    rewrite Rinv_inv in H0; lra.
  }
  apply Rinv_0_lt_compat.
  assumption.
Qed.

Lemma Rminus_diag x:
  x - x = 0.
Proof.
  ring.
Qed.

Lemma Rminus_le x y:
x - y <= 0 -> x<=y.
Proof.
  nra.
Qed.

Lemma Rminus_plus_le_minus x y z:
x + y <= z -> x <= z - y.
Proof.
intros.
nra.
Qed.

Lemma Rabs_le_minus x y z:
Rabs (x-y) <= z ->
Rabs x <= z + Rabs y.
Proof.
intros.
pose proof Rle_trans (Rabs x - Rabs y) (Rabs (x - y)) z
  (Rabs_triang_inv x y) H.
nra.
Qed.

Lemma Rabs_triang1 a b u v:
  Rabs a <= u ->
  Rabs b <= v ->
  Rabs (a + b) <= u + v.
Proof.
  intros.
  eapply Rle_trans.
  {
    apply Rabs_triang.
  }
  lra.
Qed.

Lemma Rabs_triang2 a b c u v:
  Rabs (a - b) <= u ->
  Rabs (b - c) <= v ->
  Rabs (a - c) <= u + v.
Proof.
  intros.
  replace (a - c) with (a - b + (b - c)) by ring.
  apply Rabs_triang1; auto.
Qed.

Lemma neg_powerRZ (x:R) (n:Z) :
  x <> R0 ->
  1 / (powerRZ x%R n%Z) = (powerRZ x%R (-n)%Z) .
Proof.
intros; pose proof power_RZ_inv x n H; symmetry; rewrite <- H0; nra.
Qed.

Lemma mul_hlf_powerRZ (n:Z) :
 / 2 * / powerRZ 2 n = powerRZ 2 (-n-1).
Proof.
assert (2 <> R0) by nra.
replace (/ 2) with (1/2) by nra.
replace (1 / 2 * / powerRZ 2 n) with
(1 / 2 * powerRZ 2 (- n)).
match goal with |- ?s = powerRZ ?a ?b' =>
replace b' with (-1 + - n)%Z by ring
end.
pose proof powerRZ_add 2 (-1) (-n) H. rewrite H0.
replace (1 / 2) with (powerRZ 2 (-1)). reflexivity.
simpl; nra.
replace (powerRZ 2 (- n)) with
(1 / powerRZ 2 n).
nra.
(apply neg_powerRZ); nra.
Qed.

Require Import ZArith.
Require Import Coq.Lists.List.

Ltac R_to_pos p :=
  match p with
  | 1%R => constr:(1%positive)
  | 2%R => constr:(2%positive)
  | 3%R => constr:(3%positive)
  | 1 + 2 * ?q =>
    let r := R_to_pos q in
    constr:(xI r)
  | 2 * ?q =>
    let r := R_to_pos q in
    constr:(xO r)
  end.

Ltac R_to_Z p :=
  match p with
  | - ?q =>
    let r := R_to_pos q in
    constr:(Z.neg r)
  | 0%R => constr:(0%Z)
  | ?q =>
    let r := R_to_pos q in
    constr:(Z.pos r)
  end.

(* Limits of derivatives and variations. *)

Theorem derivable_nonpos_decr :
  forall (f f':R -> R) (a b:R),
    a < b ->
    (forall c:R, a < c < b -> derivable_pt_lim f c (f' c)) ->
    (forall c:R, a < c < b -> f' c <= 0) ->
    forall x1 x2,
      a < x1 ->
      x1 <= x2 ->
      x2 < b ->
      f x2 <= f x1.
Proof.
  intros.
  destruct (Req_dec x1 x2).
  {
    apply Req_le.
    congruence.
  }
  assert (K: x1 < x2) by lra.
  destruct (MVT_cor2 f f' _ _ K) as (c & ? & ?).
  {
    intros.
    apply H0.
    lra.
  }
  cut (f' c * (x2 - x1) <= 0); [ lra | ].
  rewrite <- Ropp_0.
  rewrite <- (Ropp_involutive (f' c)).
  rewrite Ropp_mult_distr_l_reverse.
  apply Ropp_le_contravar.
  apply Rmult_le_pos.
  {
   assert (f' c  <= 0) by (apply H1; lra).
   lra.
  }
  lra.
Qed.

Theorem derivable_nonneg_incr :
  forall (f f':R -> R) (a b:R),
    a < b ->
    (forall c:R, a < c < b -> derivable_pt_lim f c (f' c)) ->
    (forall c:R, a < c < b -> 0 <= f' c) ->
    forall x1 x2,
      a < x1 ->
      x1 <= x2 ->
      x2 < b ->
      f x1 <= f x2.
Proof.
  intros.
  cut (opp_fct f x2 <= opp_fct f x1).
  {
    unfold opp_fct.
    lra.
  }
  eapply derivable_nonpos_decr with (a := a) (b := b) (f' := opp_fct f'); eauto.
  {
    intros.
    apply derivable_pt_lim_opp.
    auto.
  }
  unfold opp_fct.
  intros.
  replace 0 with (- 0) by ring.
  apply Ropp_le_contravar.
  auto.
Qed.

Theorem derivable_nonneg_incr' :
  forall (f f':R -> R) (a b:R),
    (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
    (forall c:R, a <= c <= b -> 0 <= f' c) ->
      a <= b ->
      f a <= f b.
Proof.
  intros.
  destruct (Req_dec a b).
  {
    subst. lra.
  }
  assert (K: a < b) by lra.
  destruct (MVT_cor2 f f' _ _ K H) as (c & ? & ?).
  cut (0 <= f' c * (b - a)); [ lra | ].
  apply Rmult_le_pos.
  {
    apply H0.
    lra.
  }
  lra.
Qed.

Theorem derivable_nonpos_decr' :
  forall (f f':R -> R) (a b:R),
    (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
    (forall c:R, a <= c <= b -> f' c <= 0) ->
      a <= b ->
      f b <= f a.
Proof.
  intros.
  cut (opp_fct f a <= opp_fct f b).
  {
    unfold opp_fct.
    lra.
  }
  apply derivable_nonneg_incr' with (opp_fct f').
  {
    intros.
    apply derivable_pt_lim_opp.
    auto.
  }
  {
    intros.
    generalize (H0 _ H2).
    unfold opp_fct.
    lra.
  }
  assumption.
Qed.

(* Absolute error for sine/cosine *)

Lemma sin_ub x: 0 <= x -> sin x <= x.
Proof.
  intros.
  pose (f t := sin t - t).
  cut (f x <= f 0).
  {
    unfold f.
    rewrite sin_0.
    lra.
  }
  apply derivable_nonpos_decr' with (f' := fun t => cos t - 1); auto; intros.
  {
    apply derivable_pt_lim_minus.
    {
      apply derivable_pt_lim_sin.
    }
    apply derivable_pt_lim_id.
  }
  generalize (COS_bound c).
  lra.
Qed.

Corollary sin_ub_abs_pos x:
  0 <= x ->
  Rabs x <= PI / 2 ->
  Rabs (sin x) <= Rabs x.
Proof.
  intro.
  rewrite (Rabs_right x) by lra.
  intro.
  rewrite Rabs_right.
  {
    apply sin_ub; auto.
  }
  apply Rle_ge.
  rewrite <- sin_0.
  generalize PI2_3_2; intro.
  apply sin_incr_1; try lra.
Qed.

Corollary sin_ub_abs x:
  Rabs x <= PI / 2 ->
  Rabs (sin x) <= Rabs x.
Proof.
  intros.
  destruct (Rle_dec 0 x).
  {
    apply sin_ub_abs_pos; auto.
  }
  rewrite <- Rabs_Ropp.
  rewrite <- sin_neg.
  revert H.
  rewrite <- (Rabs_Ropp x).
  apply sin_ub_abs_pos.
  lra.
Qed.

Lemma sin_absolute_error_term x d:
  sin (x + d) - sin x = 2 * cos (x + d / 2) * sin (d / 2).
Proof.
  replace (x + d) with (x + d / 2 + d / 2) by field.
  replace x with (x + d / 2 - d / 2) at 2 by field.
  rewrite sin_plus.
  rewrite sin_minus.
  ring.
Qed.

Lemma sin_absolute_error_bound' x d:
  Rabs d <= PI ->
  Rabs (sin (x + d) - sin x) <= Rabs d.
Proof.
  intros.
  rewrite sin_absolute_error_term.
  rewrite Rabs_mult.
  rewrite Rabs_mult.
  rewrite Rabs_right by lra.
  replace (Rabs d) with (2 * 1 * Rabs (d / 2))
    by (unfold Rdiv; rewrite Rabs_mult;
        rewrite (Rabs_right ( / 2)) by lra;
        field).
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  {
    lra.
  }
  apply Rmult_le_compat; auto using Rabs_pos.
  {
    apply Rabs_le.
    apply COS_bound.
  }
  apply sin_ub_abs.
  unfold Rdiv. rewrite Rabs_mult.
  rewrite (Rabs_right (/ 2)) by lra.
  lra.
Qed.

Lemma sin_absolute_error_bound x d:
  Rabs (sin (x + d) - sin x) <= Rmin (Rabs d) 2.
Proof.
  unfold Rmin.
  destruct (Rle_dec (Rabs d) 2).
  {
    apply sin_absolute_error_bound'.
    generalize (PI2_3_2). lra.
  }
  eapply Rle_trans.
  {
    apply Rabs_triang.
  }
  rewrite Rabs_Ropp.
  apply Rplus_le_compat;
    apply Rabs_le;
    apply SIN_bound.
Qed.

Lemma cos_absolute_error_bound x d:
  Rabs (cos (x + d) - cos x) <= Rmin (Rabs d) 2.
Proof.
  repeat rewrite cos_sin.
  rewrite <- Rplus_assoc.
  apply sin_absolute_error_bound.
Qed.

Lemma sin_abs_error a b d:
  Rabs (a - b) <= d ->
  Rabs (sin a - sin b) <= d.
Proof.
  intros.
  replace a with (b + (a - b)) by ring.
  eapply Rle_trans.
  {
    eapply sin_absolute_error_bound.
  }
  eapply Rle_trans.
  {
    apply Rmin_l.
  }
  assumption.
Qed.

Lemma cos_abs_error a b d:
  Rabs (a - b) <= d ->
  Rabs (cos a - cos b) <= d.
Proof.
  intros.
  replace a with (b + (a - b)) by ring.
  eapply Rle_trans.
  {
    eapply cos_absolute_error_bound.
  }
  eapply Rle_trans.
  {
    apply Rmin_l.
  }
  assumption.
Qed.

Lemma sin_abs x:
  Rabs x <= PI ->
  sin (Rabs x) = Rabs (sin x).
Proof.
  intros H.
  destruct (Rle_dec 0 x).
  {
    rewrite Rabs_right in * |- * by lra.
    rewrite Rabs_right; auto.
    generalize (sin_ge_0 x).
    lra.
  }
  destruct (Req_dec x (-PI)).
  {
    subst.
    rewrite sin_neg.
    repeat rewrite Rabs_Ropp.
    rewrite Rabs_right by lra.
    rewrite sin_PI.
    rewrite Rabs_R0.
    reflexivity.
  }
  rewrite Rabs_left in * |- * by lra.
  rewrite sin_neg.
  rewrite Rabs_left; auto.
  apply sin_lt_0_var; lra.
Qed.

Lemma cos_abs_eq u:
  cos (Rabs u) = cos u.
Proof.
  destruct (Rle_dec 0 u).
  {
    rewrite Rabs_right by lra.
    reflexivity.
  }
  rewrite Rabs_left by lra.
  apply cos_neg.
Qed.

Lemma abs_sign (b: bool):
  Rabs (if b then -1 else 1) = 1.
Proof.
  destruct b.
  {
    rewrite IZR_NEG.
    rewrite Rabs_Ropp.
    apply Rabs_R1.
  }
  apply Rabs_R1.
Qed.

(* Square root *)
Lemma sqrt_pos_strict x:
  0 < x ->
  0 < sqrt x.
Proof.
  intros.
  assert (sqrt x <> 0).
  {
    intro ABSURD.
    apply sqrt_eq_0 in ABSURD; lra.
  }
  generalize (sqrt_pos x).
  lra.
Qed.

Lemma cos_sin_plus_bound a:
  Rabs (cos a + sin a) <= sqrt 2.
Proof.
  rewrite <- cos_shift.
  rewrite form1.
  match goal with
  |- Rabs (2 * cos ?u * cos ?v) <= _ =>
      replace v with (PI / 4) by field;
      rewrite cos_PI4
  end.
  assert (0 < sqrt 2) as HSQRT.
  {
    apply sqrt_pos_strict.
    lra.
  }
  rewrite Rabs_mult.
  eapply Rle_trans.
  {
    apply Rmult_le_compat; auto using Rabs_pos.
    {
      rewrite Rabs_mult.
      apply Rmult_le_compat; auto using Rabs_pos.
      {
        rewrite Rabs_right by lra.
        apply Rle_refl.
      }
      apply Rabs_le.
      apply COS_bound.
    }
    rewrite Rabs_right.
    {
      apply Rle_refl.
    }
    apply Rinv_0_lt_compat in HSQRT.
    lra.
  }
  eapply (eq_rect_r (fun t => t <= _)).
  {
    apply Rle_refl.
  }
  rewrite <- (sqrt_sqrt 2) at 1 by lra.
  unfold IPR.
  field.
  lra.
Qed.

Lemma cos_sin_minus_bound a:
  Rabs (cos a - sin a) <= sqrt 2.
Proof.
  rewrite <- cos_neg.
  unfold Rminus.
  rewrite <- sin_neg.
  apply cos_sin_plus_bound.
Qed.

Lemma abs_cos_sin_plus_1 a:
  0 <= a <= PI / 2 ->
  Rabs (cos a) + Rabs (sin a) = cos a + sin a.
Proof.
  intros.
  generalize (cos_ge_0 a ltac:( lra ) ltac:( lra ) ).
  generalize (sin_ge_0 a ltac:( lra ) ltac:( lra ) ).
  intros.
  repeat rewrite Rabs_right by lra.
  reflexivity.
Qed.

Lemma abs_cos_sin_plus_aux_2 a:
  0 <= a <= PI ->
  exists b,
    Rabs (cos a) + Rabs (sin a) = cos b + sin b.
Proof.
  intros.
  destruct (Rle_dec a (PI / 2)).
  {
    exists a.
    apply abs_cos_sin_plus_1.
    lra.
  }
  exists (PI - a).
  replace a with ((- (PI - a)) + PI) at 1 by ring.
  rewrite neg_cos.
  rewrite cos_neg.
  rewrite Rabs_Ropp.
  replace a with (PI - (PI - a)) at 2 by ring.
  rewrite sin_PI_x.
  apply abs_cos_sin_plus_1.
  lra.
Qed.

Lemma abs_cos_sin_plus_aux_3 a:
  - PI <= a <= PI ->
  exists b,
    Rabs (cos a) + Rabs (sin a) = cos b + sin b.
Proof.
  intros.
  destruct (Rle_dec 0 a).
  {
    apply abs_cos_sin_plus_aux_2.
    lra.
  }
  replace a with (- (- a)) by ring.
  rewrite cos_neg.
  rewrite sin_neg.
  rewrite Rabs_Ropp.
  apply abs_cos_sin_plus_aux_2.
  lra.
Qed.

Lemma cos_period_1 x k:
  (0 <= k)%Z ->
  cos (x + 2 * IZR k * PI) = cos x.
Proof.
  intro LE.
  apply IZN in LE.
  destruct LE.
  subst.
  rewrite <- INR_IZR_INZ.
  apply cos_period.
Qed.

Lemma cos_period' k x:
  cos (x + 2 * IZR k * PI) = cos x.
Proof.
  destruct (Z_le_dec 0 k) as [ LE | ].
  {
    apply cos_period_1.
    lia.
  }
  match goal with
  |- cos ?a = _ =>
     rewrite <- (Ropp_involutive a);
     rewrite cos_neg;
     replace (- a) with ((- x) + 2 * (- IZR k) * PI) by ring
  end.
  rewrite <- opp_IZR.
  rewrite cos_period_1 by lia.
  apply cos_neg.
Qed.

Lemma sin_period' k x:
  sin (x + 2 * IZR k * PI) = sin x.
Proof.
  repeat rewrite <- cos_shift.
  match goal with
  |- cos ?a = _ =>
    replace a with (PI / 2 - x + 2 * (- IZR k) * PI) by ring
  end.
  rewrite <- opp_IZR.
  apply cos_period'.
Qed.

Lemma frac_part_ex x:
{ i |
  IZR (Int_part x) = x - i /\ 0 <= i < 1
}.
Proof.
  exists (x - IZR (Int_part x)).
  split.
  {
    ring.
  }
  generalize (base_Int_part x).
  lra.
Qed.

Lemma sin_period_minus x z:
  sin (x - IZR z * (2 * PI)) = sin x.
Proof.
  unfold Rminus.
  rewrite <- Ropp_mult_distr_l_reverse.
  rewrite <- opp_IZR.
  generalize (- z)%Z.
  clear z.
  intro z.
  replace (IZR z * (2 * PI)) with (2 * IZR z * PI) by ring.
  destruct z; simpl.
  {
    f_equal.
    ring.
  }
  {
    unfold IZR. rewrite <- !INR_IPR.
    apply sin_period.
  }
    unfold IZR. rewrite <- !INR_IPR.
  generalize (Pos.to_nat p).
  clear p. simpl.
  intro n.
  rewrite <- (sin_period _ n).
  f_equal.
  ring.
Qed.

Lemma cos_period_minus x z:
  cos (x - IZR z * (2 * PI)) = cos x.
Proof.
  repeat rewrite <- sin_shift.
  replace (PI / 2 - (x - IZR z * (2 * PI))) with (PI / 2 - x - IZR (- z) * (2 * PI)).
  {
    apply sin_period_minus.
  }
  rewrite opp_IZR.
  ring.
Qed.

Lemma cos_PI_x x:
  cos (PI - x) = - cos x.
Proof.
  replace (PI - x) with ((-x) + PI) by ring.
  rewrite neg_cos.
  rewrite cos_neg.
  reflexivity.
Qed.

Lemma abs_cos_sin_plus a:
  exists b,
    Rabs (cos a) + Rabs (sin a) = cos b + sin b.
Proof.
  remember (a / (2 * PI) + / 2) as u.
  remember (- Int_part u)%Z as k.
  rewrite <- (cos_period' k).
  rewrite <- (sin_period' k).
  apply abs_cos_sin_plus_aux_3.
  subst k.
  rewrite opp_IZR.
  destruct (base_Int_part u).
  remember (IZR (Int_part u)) as k.
  clear Heqk.
  subst.
  assert (k - / 2 <= a / (2 * PI)) as LE by lra.
  assert (a / (2 * PI) < k + 1 - / 2) as LT by lra.
  generalize (PI_RGT_0).
  intros.
  apply Rdiv_le_right_elim in LE; [ | lra ] .
  match type of LE with ?v <= _ =>
  replace v with (- (2 * - k * PI) - PI) in LE by field
  end.
  apply Rdiv_lt_left_elim in LT; [ | lra ] .
  match type of LT with _ < ?v =>
  replace v with (- (2 * - k * PI) + PI) in LT by field
  end.
  lra.
Qed.

Corollary abs_cos_sin_plus_le a:
  Rabs (cos a) + Rabs (sin a) <= sqrt 2.
Proof.
  match goal with
  |- ?u <= _ => rewrite <- (Rabs_right u)
  end.
  {
    destruct (abs_cos_sin_plus a) as (? & K).
    rewrite K.
    apply cos_sin_plus_bound.
  }
  generalize (Rabs_pos (cos a)).
  generalize (Rabs_pos (sin a)).
  lra.
Qed.

Lemma sqrt_abs_error x d:
  0 <= x ->
  0 <= x + d ->
  sqrt (x + d) - sqrt x = d / (sqrt (x + d) + sqrt x).
Proof.
  intros.
  destruct (Req_dec d 0).
  {
    subst.
    unfold Rdiv.
    rewrite Rplus_0_r.
    ring.
  }
  assert (0 < x \/ 0 < x + d) as OR by lra.
  assert (0 + 0 < sqrt (x + d) + sqrt x).
  {
    destruct OR.
    {
      apply Rplus_le_lt_compat.
      {
        apply sqrt_pos.
      }
      apply sqrt_pos_strict.
      assumption.
    }
    apply Rplus_lt_le_compat.
    {
      apply sqrt_pos_strict.
      assumption.
    }
    apply sqrt_pos.
  }
  replace d with (x + d - x) at 2 by ring.
  rewrite <- (sqrt_sqrt (x + d)) at 2 by assumption.
  rewrite <- (sqrt_sqrt x) at 5 by assumption.
  field.
  lra.
Qed.

Lemma sqrt_abs_error' x y:
  0 <= x ->
  0 <= y ->
  Rabs (sqrt y - sqrt x) = Rabs (y - x) / (sqrt y + sqrt x).
Proof.
  intros.
  replace y with (x + (y - x)) at 1 by ring.
  rewrite sqrt_abs_error by lra.
  unfold Rdiv.
  rewrite Rabs_mult.
  replace (x + (y - x)) with y by ring.
  destruct (Req_dec y x).
  {
    subst.
    rewrite Rminus_diag.
    rewrite Rabs_R0.
    ring.
  }
  f_equal.
  assert (0 < x \/ 0 < y) as OR by lra.
  generalize match OR with
  | or_introl K => or_introl (sqrt_pos_strict _ K)
  | or_intror K => or_intror (sqrt_pos_strict _ K)
  end.
  intros.
  generalize (sqrt_pos x). generalize (sqrt_pos y). intros.
  rewrite Rabs_inv by lra.
  f_equal.
  rewrite Rabs_right by lra.
  reflexivity.
Qed.

Corollary sqrt_abs_error_bound x y d:
  Rabs (y - x) <= d ->
  0 < x (* one of the two must be positive, we arbitrarily choose x *) ->
  0 <= y ->
  Rabs (sqrt y - sqrt x) <= d / (sqrt y + sqrt x).
Proof.
  intros Hxy Hx Hy.
  generalize (sqrt_pos y). intro.
  generalize (sqrt_pos_strict _ Hx). intro.
  rewrite sqrt_abs_error' by lra.
  apply Rmult_le_compat_r.
  {
    apply Rlt_le.
    apply Rinv_0_lt_compat.
    lra.
  }
  assumption.
Qed.

Lemma sqrt_succ_le :
forall n: R,
0 <= n ->
sqrt(n) < sqrt(n+1).
Proof.
intros.
assert (0 <= n+1) by nra.
assert (n < n+1) by nra.
pose proof sqrt_lt_1 n (n+1) H H0 H1; apply H2.
Qed.

Lemma eq_le_le x y:
  x = y ->
  y <= x <= y.
Proof.
  lra.
Qed.

Lemma Rdiv_le_0_compat_Raux : forall r1 r2 : R, 0 <= r1 -> 0 < r2 -> 0 <= r1 / r2.
Proof. apply Rdiv_le_0_compat; auto. Qed.

Lemma  Rabs_div_Raux : forall a b : R, b <> 0 -> Rabs (a/b) = (Rabs a) / (Rabs b).
Proof. apply Rabs_div; auto. Qed.

Lemma Rabs_div_eq : forall a b , b <> 0 -> 0 <= b -> Rabs (a /b) = Rabs a / b.
Proof. intros. rewrite Rabs_div; try nra; replace (Rabs b) with b; try nra; symmetry; apply Rabs_pos_eq; auto. Qed.

Lemma Rminus_rel_error :
forall u1 u2 v1 v2, ((u1 - v1) ) - (u2 - v2) = (u1 - u2) - (v1 - v2).
Proof. intros. nra. Qed.

Lemma Rplus_rel_error:
forall u1 u2 v1 v2, (u1 + v1) - (u2 + v2) = (u1 - u2) + (v1 - v2).
Proof. intros. nra. Qed.

Lemma Rmult_rel_error:
forall a b c d, (a * b) - (c  * d) = (a - c)*d + (b - d)*c + (a-c) * (b-d).
Proof. intros.  nra. Qed.

Lemma Rdiv_rel_error : forall u v u' v', v' <>0 -> v <> 0 -> u <> 0 ->
u'/v' - u/v = ((u'-u)/u - (v'-v)/v ) * (1 / (1 + ((v'-v)/v))) * (u/v).
Proof. intros. field_simplify; repeat try split; try nra; auto. Qed.

Lemma Rdiv_rel_error_add : forall u v u' v', v' <>0 -> v <> 0 -> u <> 0 ->
Rabs (u'/v' - u/v) <=
(Rabs((u'-u) / u) + Rabs((v'-v) /v)) * Rabs (1 / (1 + ((v'-v)/v))) * Rabs (u/v).
Proof.
intros.
rewrite Rdiv_rel_error; auto.
rewrite Rabs_mult.
rewrite Rabs_mult.
eapply Rle_trans.
rewrite Rmult_assoc.
apply Rmult_le_compat. apply Rabs_pos.
rewrite <- Rabs_mult.
apply Rabs_pos.
match goal with |- Rabs (?a/u - ?b /v) <= _=>
replace (a/u - b /v) with (a/u + (v - v') /v) by nra
end.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat.
apply Rle_refl. apply Rle_refl.
apply Rle_refl.
rewrite Rmult_assoc.
replace ((v - v')/v) with (-((v' - v)/v)) by nra.
rewrite Rabs_Ropp.
apply Rle_refl.
Qed.

Lemma Rdiv_rel_error_add_reduced_r : forall u v u' v', v' <>0 -> v <> 0 -> u <> 0 ->
Rabs (u'/v' - u/v) <=
(Rabs((u'-u)/u)  + Rabs (v'-v) * Rabs(1/v)) * Rabs (1 / (1 + ((v'-v)/v))) * Rabs (u/v).
Proof.
intros.
rewrite Rdiv_rel_error; auto.
eapply Rle_trans.
rewrite Rmult_assoc.
rewrite Rabs_mult.
apply Rmult_le_compat. apply Rabs_pos. apply Rabs_pos.
match goal with |- Rabs (?a/u - ?b /v) <= _=>
replace (a/u - b /v) with (a/u + (v - v') /v) by nra
end.
match goal with |- Rabs (?a/u + ?b /v) <= _=>
replace (a/u + b /v) with (a/u + b * (1 /v))
end.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat.
apply Rle_refl.
rewrite Rabs_mult. rewrite Rabs_minus_sym. apply Rle_refl.
field_simplify. f_equal. split; auto. split; auto.
rewrite Rabs_mult; apply Rle_refl.
rewrite Rmult_assoc.
apply Rle_refl.
Qed.

Lemma Rdiv_rel_error_add_reduced_l : forall u v u' v', v' <>0 -> v <> 0 -> u <> 0 ->
Rabs (u'/v' - u/v) <=
(Rabs(u'-u) * Rabs(1/u)  + Rabs((v'-v)/v)) * Rabs (1 / (1 + ((v'-v)/v))) * Rabs (u/v).
Proof.
intros.
rewrite Rdiv_rel_error; auto.
eapply Rle_trans.
rewrite Rmult_assoc.
rewrite Rabs_mult.
apply Rmult_le_compat. apply Rabs_pos. apply Rabs_pos.
match goal with |- Rabs (?a/u - ?b /v) <= _=>
replace (a/u - b /v) with (a/u + (v - v') /v) by nra
end.
match goal with |- Rabs (?a/u + ?b /v) <= _=>
replace (a/u + b /v) with (a * (1/u) + b /v)
end.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat.
rewrite Rabs_mult. apply Rle_refl.
rewrite <- Rabs_Ropp. apply Rle_refl.
field_simplify. f_equal. split; auto. split; auto.
rewrite Rabs_mult; apply Rle_refl.
rewrite Rmult_assoc.
apply Req_le.
f_equal. f_equal. f_equal.
nra.
Qed.

Lemma Rdiv_rel_error_add_reduced : forall u v u' v', v' <>0 -> v <> 0 -> u <> 0 ->
Rabs (u'/v' - u/v) <=
(Rabs(u'-u) * Rabs (1/u) + Rabs (v'-v) * Rabs(1/v)) * Rabs (1 / (1 + ((v'-v)/v))) * Rabs (u/v).
Proof.
intros.
rewrite Rdiv_rel_error; auto.
eapply Rle_trans.
rewrite Rmult_assoc.
rewrite Rabs_mult.
apply Rmult_le_compat. apply Rabs_pos. apply Rabs_pos.
match goal with |- Rabs (?a/u - ?b /v) <= _=>
replace (a/u - b /v) with (a/u + (v - v') /v) by nra
end.
match goal with |- Rabs (?a/u + ?b /v) <= _=>
replace (a/u + b /v) with (a * (1/u) + b * (1 /v))
end.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat.
rewrite Rabs_mult; apply Rle_refl.
rewrite Rabs_mult. rewrite Rabs_minus_sym. apply Rle_refl.
field_simplify. f_equal. split; auto. split; auto.
rewrite Rabs_mult; apply Rle_refl.
rewrite Rmult_assoc.
apply Rle_refl.
Qed.

Lemma Rdiv_rel_error_no_u_div' : forall u v u' v', v' <>0 -> v <> 0 ->
u'/v' - u/v = ((u'-u) - (v'-v) * 1/v * u)  * (1 / (1 + ((v'-v)/v))) * (1/v).
Proof. intros. field_simplify; repeat try split; try nra; auto. Qed.

Lemma Rdiv_rel_error_no_u_div2 : forall u v u' v', v' <>0 -> v <> 0 ->
u'/v' - u/v = ((u'-u) - (v'-v)/v  * u)  * (1 / (1 + ((v'-v)/v))) * (1/v).
Proof. intros. field_simplify; repeat try split; try nra; auto. Qed.

Lemma Rdiv_rel_error_no_u_div_reduced :
forall u v u' v', v' <>0 -> v <> 0 ->
Rabs (u'/v' - u/v) <= (Rabs (u'-u)  +  Rabs ((v'-v)) * Rabs (1/v) * Rabs u)  * Rabs (1 / (1 + ((v'-v)/v))) * Rabs (1/v).
Proof.
intros.
rewrite Rdiv_rel_error_no_u_div'; auto.
eapply Rle_trans.
rewrite Rmult_assoc.
rewrite Rabs_mult.
apply Rmult_le_compat. apply Rabs_pos. apply Rabs_pos.
match goal with |- Rabs (?a - (v' - v) *1/v * u) <= _=>
replace (a - (v' - v) * 1/v * u) with (a + (v - v') * (1/v) * u) by nra
end.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat.
apply Rle_refl.
rewrite Rabs_mult.
apply Rmult_le_compat;
try apply Rabs_pos.
rewrite Rabs_mult.
apply Rmult_le_compat;
try apply Rabs_pos.
rewrite <- Rabs_Ropp;  apply Rle_refl.
apply Rle_refl.
apply Rle_refl.
rewrite Rabs_mult.
apply Rmult_le_compat;
try apply Rabs_pos.
apply Rle_refl.
apply Rle_refl.
repeat rewrite Rmult_assoc.
apply Req_le.
f_equal. f_equal. f_equal.
f_equal.
nra.
Qed.

Lemma Rdiv_rel_error_no_u_div_reduced2 :
forall u v u' v', v' <>0 -> v <> 0 ->
Rabs (u'/v' - u/v) <= (Rabs (u'-u)  +  Rabs ((v'-v)/v)* Rabs u)  * Rabs (1 / (1 + ((v'-v)/v))) * Rabs (1/v).
Proof.
intros.
rewrite Rdiv_rel_error_no_u_div2; auto.
eapply Rle_trans.
rewrite Rmult_assoc.
rewrite Rabs_mult.
apply Rmult_le_compat. apply Rabs_pos. apply Rabs_pos.
match goal with |- Rabs (?a - (v' - v)/v * u) <= _=>
replace (a - (v' - v)/v * u) with (a + (v - v')/v * u) by nra
end.
eapply Rle_trans.
apply Rabs_triang.
apply Rplus_le_compat.
apply Rle_refl.
rewrite Rabs_mult.
apply Rmult_le_compat;
try apply Rabs_pos.
rewrite <- Rabs_Ropp;  apply Rle_refl.
apply Rle_refl.
apply Rle_refl.

repeat rewrite Rmult_assoc.
apply Req_le.
f_equal. f_equal. f_equal.
f_equal.
nra.
rewrite Rabs_mult.
nra.
Qed.

Lemma Rplus_opp : forall a b,
a + - b = a - b. Proof. intros. nra. Qed.

Lemma Rabs_Ropp2 :
forall A D U,  Rabs(-A * D - - U) = Rabs(A * D - U).
Proof.
intros.
rewrite <- Rabs_Ropp.
rewrite Ropp_minus_distr.
f_equal. nra. Qed.


MacBook-Air:bin billw$ ./coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Theorem disj : forall P Q : Prop, P \/ Q -> Q \/ P.
1 subgoal

  ============================
   forall P Q : Prop, P \/ Q -> Q \/ P

disj < Proof.
1 subgoal

  ============================
   forall P Q : Prop, P \/ Q -> Q \/ P

disj < intros P Q H.
1 subgoal

  P : Prop
  Q : Prop
  H : P \/ Q
  ============================
   Q \/ P

disj < inversion H as [HP | HQ].
2 subgoals

  P : Prop
  Q : Prop
  H : P \/ Q
  HP : P
  ============================
   Q \/ P

subgoal 2 is:
 Q \/ P

disj < Case "left". right. apply HP.
Toplevel input, characters 5-11:
> Case "left".
>      ^^^^^^
Error: No interpretation for string "left".

2 subgoals

  P : Prop
  Q : Prop
  H : P \/ Q
  HP : P
  ============================
   P

subgoal 2 is:
 Q \/ P

1 subgoal

  P : Prop
  Q : Prop
  H : P \/ Q
  HQ : Q
  ============================
   Q \/ P

disj < Case "right". left. apply HQ.
Toplevel input, characters 5-12:
> Case "right".
>      ^^^^^^^
Error: No interpretation for string "right".

1 subgoal

  P : Prop
  Q : Prop
  H : P \/ Q
  HQ : Q
  ============================
   Q

No more subgoals.

disj < Qed.
intros P Q H.
inversion H as [HP| HQ].
 right.
 apply HP.

 left.
 apply HQ.

disj is defined

Coq <


(** 空型に関するモジュールです。 *)

Require Googology_In_Coq.Base.
Require Googology_In_Coq.Path.

(** ライブラリを要求します。 *)

Import Googology_In_Coq.Base.
Import Googology_In_Coq.Path.

(** ライブラリを開きます。 *)

Inductive Void@{ i | } : Type@{ i } :=.
(* from: originally defined by Hexirp *)

(** 空型です。 *)

Definition matching_Void@{ i j | } ( P : Type@{ j } ) ( x : Void@{ i } ) : P := match x with end.
(* from: originally defined by Hexirp *)

(** 空型の場合分けです。 *)

Definition identity_matching_Void@{ i j | } ( P : Type@{ j } ) ( display : P -> Void@{ i } ) ( x : Void@{ i } ) : Path Void@{ i } ( display ( matching_Void P x ) ) x := match x as x_ return Path Void@{ i } ( display ( matching_Void P x_ ) ) x_ with end.
(* from: originally defined by Hexirp *)

(** 空型の場合分けです。 *)

Definition dependent_matching_Void@{ i j | } ( P : Void@{ i } -> Type@{ j } ) ( x : Void ) : P x := match x as x_ return P x_ with end.
(* from: originally defined by Hexirp *)

(** 空型の依存場合分けです。 *)

Definition from_path_cons_Void@{ i | } ( x : Void@{ i } ) ( y : Void@{ i } ) : Path Void@{ i } x y := dependent_matching_Void ( fun x_ : Void@{ i } => forall y_ : Void@{ i }, Path Void@{ i } x_ y_ ) x y.
(* from: originally defined by Hexirp *)

(** 空型の構築子の道から空型の道を作る関数です。 *)

Definition absurd_Void@{ i j | } ( A : Type@{ j } ) : Void@{ i } -> A := matching_Void A.
(* from: originally defined by Hexirp *)

(** 空型から任意の型を取り出す関数です。 *)


Require Import Coq.Logic.Classical Rules DataTypes MsiState L1 Omega Coq.Relations.Relation_Operators Coq.Lists.Streams DataTypes.

Module mkL1Axioms : L1Axioms mkDataTypes.
  Import mkDataTypes.

  Theorem deqLeaf: forall {c i t}, deqR c i t -> leaf c.
  Proof.
    intros c i t deqr.
    unfold deqR in deqr.
    destruct (trans oneBeh t);
    (simpl in *; destruct (decTree c c0) as [eq|notEq]; [rewrite eq in *; firstorder| firstorder]);
    assert (c = c0) by auto; firstorder.
  Qed.

  Theorem deqDef: forall {c i t}, deqR c i t -> defined c.
  Proof.
    intros c i t deqr.
    unfold deqR in deqr.
    destruct (trans oneBeh t);
    (simpl in *; destruct (decTree c c0) as [eq|notEq]; [rewrite eq in *; firstorder| firstorder]);
    assert (c = c0) by auto; firstorder.
  Qed.

  Theorem uniqDeqProc: forall {c i1 t i2},
                       deqR c i1 t -> deqR c i2 t ->
                       i1 = i2.
  Proof.
    intros c i1 t i2 deq1 deq2.
    unfold deqR in *.
    destruct (trans oneBeh t).
    simpl in *; destruct deq1 as [_ use1]; destruct deq2 as [_ use2];
                                           rewrite use1 in use2; firstorder.
    simpl in *; destruct deq1 as [_ use1]; destruct deq2 as [_ use2];
                                           rewrite use1 in use2; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
  Qed.

  Theorem processDeq: forall {c i t}, deqR c i t ->
                                      let q := reqFn c i in
                                      match desc q with
                                        | Ld => sle Sh (state c (loc q) t)
                                        | St => state c (loc q) t = Mo
                                      end.
  Proof.
    intros c i t deqr.
    unfold state.
    unfold deqR in *.
    destruct (trans oneBeh t).

    destruct deqr as [eq u1].
    rewrite eq in *.
    rewrite u1 in *.
    rewrite e in *.
    assumption.

    destruct deqr as [eq u1].
    rewrite eq in *.
    rewrite u1 in *.
    rewrite e in *.
    assumption.

    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
  Qed.

  Theorem deqImpEnq: forall {c i t}, deqR c i t ->
                                     match desc (reqFn c i) with
                                       | Ld => enqLd c i (data c (loc (reqFn c i)) t) t
                                       | St => enqSt c i t
                                     end.
  Proof.
    intros c i t deqr.
    unfold state.
    unfold deqR in *; unfold enqLd; unfold enqSt; unfold data.
    destruct (trans oneBeh t).
    destruct deqr as [eq u].
    rewrite eq in *; rewrite u in *; rewrite e in *.
    intuition.
    destruct deqr as [eq u].
    rewrite eq in *; rewrite u in *; rewrite e in *.
    intuition.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
  Qed.

  Theorem enqLdImpDeq: forall {c i st t}, enqLd c i st t -> deqR c i t /\ desc (reqFn c i) = Ld /\
                                                          data c (loc (reqFn c i)) t = st.
  Proof.
    intros c i st t enql.
    unfold enqLd in *; unfold deqR; unfold data.
    destruct (trans oneBeh t).
    destruct enql as [eq [u1 u2]].
    rewrite eq in *; rewrite u1 in *; rewrite u2 in *.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem enqStImpDeq: forall {c i t}, enqSt c i t -> deqR c i t /\ desc (reqFn c i) = St.
  Proof.
    intros c i t enql.
    unfold enqSt in *; unfold deqR; unfold data.
    destruct (trans oneBeh t).
    intuition.
    destruct enql as [eq u1].
    rewrite eq in *; rewrite u1 in *.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem reqGe: forall {c t1 t2}, t1 <= t2 -> req (sys oneBeh t2) c >= req (sys oneBeh t1) c.
  Proof.
    intros c t1 t2 le.
    remember (t2 - t1) as td.
    assert (t2 = t1 + td) by omega.
    rewrite H in *; clear le Heqtd H.
    induction td.
    assert (t1 + 0 = t1) by omega.
    rewrite H.
    omega.
    assert (t1 + S td = S (t1 + td)) by omega.
    rewrite H; clear H.
    assert (req (sys oneBeh (S (t1 + td))) c >= req (sys oneBeh (t1 + td)) c).
    destruct (trans oneBeh (t1 + td)).

    simpl.
    destruct (decTree c c0); omega.
    simpl.
    destruct (decTree c c0); omega.
    simpl.
    omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
  Qed.

  Theorem reqGeConv: forall {c t1 t2}, req (sys oneBeh t1) c < req (sys oneBeh t2) c -> t1 < t2.
  Proof.
    intros c t1 t2 reqEq.
    assert (t1 >= t2 \/ t1 < t2) by omega.
    destruct H.
    pose proof (@reqGe c _ _ H) as contra; omega.
    assumption.
  Qed.

  Theorem reqGt: forall {c i t1 t2}, t1 < t2 -> deqR c i t1 ->
                                     req (sys oneBeh t2) c > i.
  Proof.
    intros c i t1 t2 cond deqr.
    assert (S t1 <= t2) by omega.
    assert (req (sys oneBeh (S t1)) c > i).
    unfold deqR in *.
    destruct (trans oneBeh t1).
    simpl.
    destruct deqr as [eq sth].
    rewrite eq in *.
    destruct (decTree c c).
    rewrite sth; omega.
    firstorder.
    simpl.
    destruct deqr as [eq sth].
    rewrite eq in *.
    destruct (decTree c c).
    rewrite sth; omega.
    firstorder.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    pose proof (@reqGe c _ _ H).
    omega.
  Qed.

  Theorem uniqDeqProc2: forall {c i t1 t2},
                        deqR c i t1 -> deqR c i t2 -> t1 = t2.
  Proof.
    intros c i t1 t2 deq1 deq2.
    unfold Time in *.
    assert (t1 = t2 \/ t1 < t2 \/ t2 < t1) by omega.
    destruct H as [e1 | [e2 | e3]].
    assumption.
    pose proof (reqGt e2 deq1).
    unfold deqR in deq2.
    destruct (trans oneBeh t2).
    destruct deq2 as [_ u2].
    omega.
    destruct deq2 as [_ u2].
    omega.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    pose proof (reqGt e3 deq2).
    unfold deqR in deq1.
    destruct (trans oneBeh t1).
    destruct deq1 as [_ u2].
    omega.
    destruct deq1 as [_ u2].
    omega.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem incReqImpDeq: forall {c t i},
                           req (sys oneBeh t) c > i ->
                           exists t', t' < t /\ deqR c i t'.
  Proof.
    intros c t i reqEq.
    induction t.
    pose proof (init oneBeh) as sth.
    rewrite sth in reqEq; clear sth.
    unfold initGlobalState in *; simpl in *.
    omega.
    assert (inc:req (sys oneBeh (S t)) c = req (sys oneBeh t) c \/
                req (sys oneBeh (S t)) c = S (req (sys oneBeh t) c)).
    destruct (trans oneBeh t).
    simpl in *.
    destruct (decTree c c0).
    right.
    intuition.
    left.
    intuition.
    simpl in *.
    destruct (decTree c c0).
    right.
    intuition.
    left.
    intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.

    destruct inc.
    rewrite H in reqEq.
    specialize (IHt reqEq).
    destruct IHt as [t' [t'_lt_t deq]].
    exists t'.
    assert (t' < S t) by omega; intuition.
    rewrite H in reqEq.
    assert (opts: req (sys oneBeh t) c > i \/ req (sys oneBeh t) c = i) by omega.
    destruct H.
    destruct opts.
    specialize (IHt H).
    destruct IHt as [t' [t'_lt_t deq]].
    exists t'.
    constructor.
    omega.
    assumption.
    rewrite <- H in *; clear H.
    exists t.
    constructor.
    omega.
    unfold deqR.
    destruct (trans oneBeh t).
    simpl in *.
    destruct (decTree c c0).
    constructor; auto.
    omega.
    simpl in *.
    destruct (decTree c c0).
    constructor; auto.
    omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
  Qed.

  Theorem deqImpDeqBefore: forall {c i1 i2 t},
                             deqR c i1 t -> i2 < i1 -> exists t', deqR c i2 t'.
  Proof.
    intros c i1 i2 t deq i2_lt_i1.
    unfold deqR in deq.
    destruct (trans oneBeh t).
    destruct deq as [eq sth].
    rewrite eq in *.
    rewrite <- sth in *.
    pose proof (incReqImpDeq i2_lt_i1) as [x [_ y]]; exists x; intuition.
    destruct deq as [eq sth].
    rewrite eq in *.
    rewrite <- sth in *.
    pose proof (incReqImpDeq i2_lt_i1) as [x [_ y]]; exists x; intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem deqOrder: forall {c i1 t1 i2 t2},
                      deqR c i1 t1 -> deqR c i2 t2 ->
                      i1 < i2 -> ~ t1 > t2.
  Proof.
    unfold not; intros c i1 t1 i2 t2 deq1 deq2 iLess t2Less.
    pose proof (reqGt t2Less deq2).
    unfold deqR in deq1.
    destruct (trans oneBeh t1).
    destruct deq1 as [_ u]; omega.
    destruct deq1 as [_ u]; omega.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

End mkL1Axioms.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Nat_Facts
        Ext_Cons.Prod_Cat.Operations.
From Categories Require Import Functor.Main.
From Categories Require Import Functor.Representable.Hom_Func
        Functor.Representable.Hom_Func_Prop.
From Categories Require Import NatTrans.Main.
From Categories Require Import Adjunction.Adjunction Adjunction.Duality.
From Categories Require Import Cat.Cat Cat.Exponential Cat.Exponential_Facts.
From Categories Require Import Yoneda.Yoneda.
From Categories Require Import Functor.Functor_Extender.

Local Open Scope functor_scope.

Section Hom_Adjunct_left_iso.
  Context {C D : Category}
          {F F' : C –≻ D}
          (N : (F' ≃ F)%natiso)
          {G : D –≻ C}
          (adj : F ⊣_hom G)
  .

  (** If F ≃ F' and (F ⊣_hom G) then (F' ⊣_hom G) *)
  Definition Hom_Adjunct_left_iso : F' ⊣_hom G :=
    (adj ∘ ((NatTrans_id_Iso (Hom_Func D))
              ∘_h (Prod_Functor_NatIso
                     (N^op) (NatTrans_id_Iso (Functor_id D))))
    )%isomorphism%natiso.

End Hom_Adjunct_left_iso.

Section Hom_Adjunct_right_iso.
  Context {C D : Category}
          {F : C –≻ D}
          {G G' : D –≻ C}
          (N : (G ≃ G')%natiso)
          (adj : F ⊣_hom G)
  .

  (** If G ≃ G' and (F ⊣_hom G) then (F ⊣_hom G') *)
  Definition Hom_Adjunct_right_iso : F ⊣_hom G' :=
    Hom_Adjunct_Duality
      (Hom_Adjunct_left_iso
         ((N^op)⁻¹)%isomorphism%natiso (Hom_Adjunct_Duality adj)).

End Hom_Adjunct_right_iso.

Section Adjunct_left_iso.
  Context {C D : Category}
          (F F' : C –≻ D)
          (N : (F' ≃ F)%natiso)
          (G : D –≻ C)
          (adj : F ⊣ G)
  .

  (** If F ≃ F' and (F ⊣ G) then (F' ⊣ G) *)
  Definition Adjunct_left_iso : F' ⊣ G :=
    Hom_Adj_to_Adj (Hom_Adjunct_left_iso N (Adj_to_Hom_Adj adj)).

End Adjunct_left_iso.

Section Adjunct_right_iso.
  Context {C D : Category}
          (F : C –≻ D)
          (G G' : D –≻ C)
          (N : (G ≃ G')%natiso)
          (adj : F ⊣ G)
  .

  (** If G ≃ G' and (F ⊣ G) then (F ⊣ G') *)
  Definition Adjunct_right_iso : F ⊣ G' :=
    Hom_Adj_to_Adj (Hom_Adjunct_right_iso N (Adj_to_Hom_Adj adj)).

End Adjunct_right_iso.

Section Hom_Adjunct_left_unique.
  Context {C D : Category}
          {F F' : C –≻ D}
          {G : D –≻ C}
          (adj : F ⊣_hom G)
          (adj' : F' ⊣_hom G)
  .

  (** If F ⊣_hom G and F' ⊣_hom G then F ≃ F' *)
  Definition Hom_Adjunct_left_unique : (F ≃ F')%natiso.
  Proof.
    apply (@Opposite_NatIso _ _ (F^op) (F'^op)).
    eapply (Embedding_mono (Yoneda_Emb (D^op))).
    eapply Isomorphism_Compose;
      [eapply Inverse_Isomorphism; apply Exp_Cat_morph_ex_compose_Iso |].
    eapply Isomorphism_Compose; [|apply Exp_Cat_morph_ex_compose_Iso].
    apply Exp_Cat_morph_ex_Iso.
    eapply Isomorphism_Compose.
    apply adj.
    eapply Inverse_Isomorphism.
    apply adj'.
  Defined.

End Hom_Adjunct_left_unique.

Section Hom_Adjunct_right_unique.
  Context {C D : Category}
          {F : C –≻ D}
          {G G' : D –≻ C}
          (adj : F ⊣_hom G)
          (adj' : F ⊣_hom G')
  .

  (** If F ⊣_hom G and F ⊣_hom G' then G ≃ G' *)
  Theorem Hom_Adjunct_right_unique : (G ≃ G')%natiso.
  Proof.
    apply Hom_Adjunct_Duality in adj.
    apply Hom_Adjunct_Duality in adj'.
    apply (@Opposite_NatIso _ _ (G^op) (G'^op)).
    apply (Hom_Adjunct_left_unique adj adj').
  Defined.

End Hom_Adjunct_right_unique.

Section Adjunct_left_unique.
  Context {C D : Category}
          {F F' : C –≻ D}
          {G : D –≻ C}
          (adj : F ⊣ G)
          (adj' : F' ⊣ G)
  .

  (** If F ⊣ G and F' ⊣ G then F ≃ F' *)
  Theorem Adjunct_left_unique : (F ≃ F' )%natiso.
  Proof.
    apply Adj_to_Hom_Adj in adj.
    apply Adj_to_Hom_Adj in adj'.
    eapply Hom_Adjunct_left_unique; eassumption.
  Defined.

End Adjunct_left_unique.

Section Adjunct_right_unique.
  Context {C D : Category}
          {F : C –≻ D}
          {G G' : D –≻ C}
          (adj : F ⊣ G)
          (adj' : F ⊣ G')
  .

  (** If F ⊣ G and F ⊣ G' then G ≃ G' *)
  Theorem Adjunct_right_unique : (G ≃ G')%natiso.
  Proof.
    apply Adj_to_Hom_Adj in adj.
    apply Adj_to_Hom_Adj in adj'.
    eapply Hom_Adjunct_right_unique; eassumption.
  Defined.

End Adjunct_right_unique.

(** If F ⊣_ucu G then
    Hom_{Func_Cat B D}(Fᵒᵖ ∘ –, –) ≃ Hom_{Func_Cat B C}(–, G ∘ —) *)
Section Hom_Adjunct_Lifted.
  Context {C D : Category}
          {F : C –≻ D}
          {G : D –≻ C}
          (adj : F ⊣_ucu G)
          (B : Category)
  .

  Local Notation NID := NatTrans_id (only parsing).
  Local Notation FCAT := Func_Cat (only parsing).

  Local Notation LEFT :=
    (
      (Hom_Func (Func_Cat B D))
        ∘ (Prod_Functor
             ((Right_Functor_Extender F B)^op)
             (Functor_id (Func_Cat B D))
          )
    )
      (only parsing).

  Local Notation RIGHT :=
    (
      (Hom_Func (Func_Cat B C))
        ∘ (Prod_Functor
             (Functor_id ((Func_Cat B C)^op)%category)
             (Right_Functor_Extender G B)
          )
    )
      (only parsing).

  Local Obligation Tactic := idtac.

  Program Definition Hom_Adjunct_Lifted_LR : (LEFT –≻ RIGHT)%nattrans :=
    {|
      Trans := fun c h =>
                 ((((NatTrans_id G) ∘_h h)
                     ∘ ((NatTrans_Functor_assoc (fst c) F G)
                          ∘ ((ucu_adj_unit adj) ∘_h (NatTrans_id (fst c)))))
                    ∘ (NatTrans_to_compose_id _))%nattrans
    |}.

  Next Obligation.
    intros [c1 c2] [c1' c2'] [h1 h2].
    extensionality w.
    apply NatTrans_eq_simplify.
    extensionality x.
    cbn in *.
    repeat rewrite F_id; simpl_ids.
    repeat rewrite F_compose.
    repeat rewrite assoc.
    cbn_rewrite (@Trans_com _ _ _ _ (ucu_adj_unit adj) _ _ (Trans h1 x)).
    trivial.
  Qed.

  Next Obligation.
    symmetry.
    apply Hom_Adjunct_Lifted_LR_obligation_1.
  Qed.

  Program Definition Hom_Adjunct_Lifted_RL : (RIGHT –≻ LEFT)%nattrans :=
    {|
      Trans := fun c h =>
                 ((NatTrans_from_compose_id _)
                    ∘ ((((ucu_adj_counit adj)
                           ∘_h (NatTrans_id (snd c)))
                          ∘ (NatTrans_Functor_assoc_sym (snd c) G F))
                         ∘ ((NatTrans_id F) ∘_h h)))%nattrans
    |}.

  Next Obligation.
    intros [c1 c2] [c1' c2'] [h1 h2].
    extensionality w.
    apply NatTrans_eq_simplify.
    extensionality x.
    cbn in *.
    repeat rewrite F_id; simpl_ids.
    repeat rewrite F_compose.
    repeat rewrite assoc_sym.
    cbn_rewrite (@Trans_com _ _ _ _ (ucu_adj_counit adj) _ _ (Trans h2 x)).
    trivial.
  Qed.

  Next Obligation.
    symmetry.
    apply Hom_Adjunct_Lifted_RL_obligation_1.
  Qed.

  Program Definition Hom_Adjunct_Lifted : (LEFT ≃ RIGHT)%natiso :=
    {|
      iso_morphism := Hom_Adjunct_Lifted_LR;
      inverse_morphism := Hom_Adjunct_Lifted_RL
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify;
    extensionality c; extensionality h.
    destruct c as [c1 c2].
    apply NatTrans_eq_simplify; extensionality y.
    cbn in *.
    repeat rewrite F_id.
    simpl_ids.
    rewrite F_compose.
    rewrite assoc_sym.
    cbn_rewrite (Trans_com (ucu_adj_counit adj) (Trans h y)).
    rewrite assoc.
    simpl_ids; trivial.
    set (W := f_equal (fun w => Trans w (c1 _o y)) (ucu_adj_left_id adj));
      cbn in W; simpl_ids in W; apply W.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify;
    extensionality c; extensionality h.
    destruct c as [c1 c2].
    apply NatTrans_eq_simplify; extensionality y.
    cbn in *.
    repeat rewrite F_id.
    simpl_ids.
    rewrite F_compose.
    rewrite assoc.
    cbn_rewrite <- (Trans_com (ucu_adj_unit adj) (Trans h y)).
    rewrite assoc_sym.
    simpl_ids; trivial.
    set (W := f_equal (fun w => Trans w (c2 _o y)) (ucu_adj_right_id adj));
      cbn in W;
      repeat rewrite F_compose in W; repeat rewrite F_id in W; simpl_ids in W;
      apply W.
  Qed.

End Hom_Adjunct_Lifted.