From stdpp Require Import gmap.
From iris.bi Require Export bi.
Set Default Proof Using "Type".
Import bi.

Module bi_reflection. Section bi_reflection.
  Context {PROP : bi}.

  Inductive expr :=
    | EEmp : expr
    | EVar : nat → expr
    | ESep : expr → expr → expr.
  Fixpoint eval (Σ : list PROP) (e : expr) : PROP :=
    match e with
    | EEmp => emp
    | EVar n => default emp (Σ !! n)
    | ESep e1 e2 => eval Σ e1 ∗ eval Σ e2
    end%I.
  Fixpoint flatten (e : expr) : list nat :=
    match e with
    | EEmp => []
    | EVar n => [n]
    | ESep e1 e2 => flatten e1 ++ flatten e2
    end.

  Notation eval_list Σ l := ([∗ list] n ∈ l, default emp (Σ !! n))%I.

  Lemma eval_flatten Σ e : eval Σ e ⊣⊢ eval_list Σ (flatten e).
  Proof.
    induction e as [| |e1 IH1 e2 IH2];
      rewrite /= ?right_id ?big_opL_app ?IH1 ?IH2 //.
  Qed.

  (* Can be related to the RHS being affine *)
  Lemma flatten_entails `{BiAffine PROP} Σ e1 e2 :
    flatten e2 ⊆+ flatten e1 → eval Σ e1 ⊢ eval Σ e2.
  Proof. intros. rewrite !eval_flatten. by apply big_sepL_submseteq. Qed.
  Lemma flatten_equiv Σ e1 e2 :
    flatten e2 ≡ₚ flatten e1 → eval Σ e1 ⊣⊢ eval Σ e2.
  Proof. intros He. by rewrite !eval_flatten He. Qed.

  Fixpoint prune (e : expr) : expr :=
    match e with
    | EEmp => EEmp
    | EVar n => EVar n
    | ESep e1 e2 =>
       match prune e1, prune e2 with
       | EEmp, e2' => e2'
       | e1', EEmp => e1'
       | e1', e2' => ESep e1' e2'
       end
    end.
  Lemma flatten_prune e : flatten (prune e) = flatten e.
  Proof.
    induction e as [| |e1 IH1 e2 IH2]; simplify_eq/=; auto.
    rewrite -IH1 -IH2. by repeat case_match; rewrite ?right_id_L.
  Qed.
  Lemma prune_correct Σ e : eval Σ (prune e) ⊣⊢ eval Σ e.
  Proof. by rewrite !eval_flatten flatten_prune. Qed.

  Fixpoint cancel_go (n : nat) (e : expr) : option expr :=
    match e with
    | EEmp => None
    | EVar n' => if decide (n = n') then Some EEmp else None
    | ESep e1 e2 =>
       match cancel_go n e1 with
       | Some e1' => Some (ESep e1' e2)
       | None => ESep e1 <$> cancel_go n e2
       end
    end.
  Definition cancel (ns : list nat) (e: expr) : option expr :=
    prune <$> fold_right (mbind ∘ cancel_go) (Some e) ns.
  Lemma flatten_cancel_go e e' n :
    cancel_go n e = Some e' → flatten e ≡ₚ n :: flatten e'.
  Proof.
    revert e'; induction e as [| |e1 IH1 e2 IH2]; intros;
      repeat (simplify_option_eq || case_match); auto.
    - by rewrite IH1 //.
    - by rewrite IH2 // Permutation_middle.
  Qed.
  Lemma flatten_cancel e e' ns :
    cancel ns e = Some e' → flatten e ≡ₚ ns ++ flatten e'.
  Proof.
    rewrite /cancel fmap_Some=> -[{e'}e' [He ->]]; rewrite flatten_prune.
    revert e' He; induction ns as [|n ns IH]=> e' He; simplify_option_eq; auto.
    rewrite Permutation_middle -flatten_cancel_go //; eauto.
  Qed.
  Lemma cancel_entails Σ e1 e2 e1' e2' ns :
    cancel ns e1 = Some e1' → cancel ns e2 = Some e2' →
    (eval Σ e1' ⊢ eval Σ e2') → eval Σ e1 ⊢ eval Σ e2.
  Proof.
    intros ??. rewrite !eval_flatten.
    rewrite (flatten_cancel e1 e1' ns) // (flatten_cancel e2 e2' ns) //; csimpl.
    rewrite !big_opL_app. apply sep_mono_r.
  Qed.

  Fixpoint to_expr (l : list nat) : expr :=
    match l with
    | [] => EEmp
    | [n] => EVar n
    | n :: l => ESep (EVar n) (to_expr l)
    end.
  Arguments to_expr !_ / : simpl nomatch.
  Lemma eval_to_expr Σ l : eval Σ (to_expr l) ⊣⊢ eval_list Σ l.
  Proof.
    induction l as [|n1 [|n2 l] IH]; csimpl; rewrite ?right_id //.
    by rewrite IH.
  Qed.

  Lemma split_l Σ e ns e' :
    cancel ns e = Some e' → eval Σ e ⊣⊢ (eval Σ (to_expr ns) ∗ eval Σ e').
  Proof.
    intros He%flatten_cancel.
    by rewrite eval_flatten He big_opL_app eval_to_expr eval_flatten.
  Qed.
  Lemma split_r Σ e ns e' :
    cancel ns e = Some e' → eval Σ e ⊣⊢ (eval Σ e' ∗ eval Σ (to_expr ns)).
  Proof. intros. rewrite /= comm. by apply split_l. Qed.

  Class Quote (Σ1 Σ2 : list PROP) (P : PROP) (e : expr) := {}.
  Global Instance quote_True Σ : Quote Σ Σ emp%I EEmp.
  Global Instance quote_var Σ1 Σ2 P i:
    rlist.QuoteLookup Σ1 Σ2 P i → Quote Σ1 Σ2 P (EVar i) | 1000.
  Global Instance quote_sep Σ1 Σ2 Σ3 P1 P2 e1 e2 :
    Quote Σ1 Σ2 P1 e1 → Quote Σ2 Σ3 P2 e2 → Quote Σ1 Σ3 (P1 ∗ P2)%I (ESep e1 e2).

  Class QuoteArgs (Σ : list PROP) (Ps : list PROP) (ns : list nat) := {}.
  Global Instance quote_args_nil Σ : QuoteArgs Σ nil nil.
  Global Instance quote_args_cons Σ Ps P ns n :
    rlist.QuoteLookup Σ Σ P n →
    QuoteArgs Σ Ps ns → QuoteArgs Σ (P :: Ps) (n :: ns).
  End bi_reflection.

  Ltac quote :=
    match goal with
    | |- ?P1 ⊢ ?P2 =>
      lazymatch type of (_ : Quote [] _ P1 _) with Quote _ ?Σ2 _ ?e1 =>
      lazymatch type of (_ : Quote Σ2 _ P2 _) with Quote _ ?Σ3 _ ?e2 =>
        change (eval Σ3 e1 ⊢ eval Σ3 e2) end end
    end.
  Ltac quote_l :=
    match goal with
    | |- ?P1 ⊢ ?P2 =>
      lazymatch type of (_ : Quote [] _ P1 _) with Quote _ ?Σ2 _ ?e1 =>
        change (eval Σ2 e1 ⊢ P2) end
    end.
End bi_reflection.

Tactic Notation "solve_sep_entails" :=
  bi_reflection.quote;
  first
    [apply bi_reflection.flatten_entails (* for affine BIs *)
    |apply equiv_entails, bi_reflection.flatten_equiv (* for other BIs *) ];
  apply (bool_decide_unpack _); vm_compute; exact Logic.I.

Tactic Notation "solve_sep_equiv" :=
  bi_reflection.quote; apply bi_reflection.flatten_equiv;
  apply (bool_decide_unpack _); vm_compute; exact Logic.I.

Ltac close_uPreds Ps tac :=
  let PROP := match goal with |- @bi_entails ?PROP _ _ => PROP end in
  let rec go Ps Qs :=
    lazymatch Ps with
    | [] => let Qs' := eval cbv [reverse rev_append] in (reverse Qs) in tac Qs'
    | ?P :: ?Ps => find_pat P ltac:(fun Q => go Ps (Q :: Qs))
    end in
  (* avoid evars in case Ps = @nil ?A *)
  try match Ps with [] => unify Ps (@nil PROP) end;
  go Ps (@nil PROP).

Tactic Notation "cancel" constr(Ps) :=
  bi_reflection.quote;
  let Σ := match goal with |- bi_reflection.eval ?Σ _ ⊢ _ => Σ end in
  let ns' := lazymatch type of (_ : bi_reflection.QuoteArgs Σ Ps _) with
             | bi_reflection.QuoteArgs _ _ ?ns' => ns'
             end in
  eapply bi_reflection.cancel_entails with (ns:=ns');
    [cbv; reflexivity|cbv; reflexivity|simpl].

Tactic Notation "ecancel" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Qs => cancel Qs).

(** [to_front [P1, P2, ..]] rewrites in the premise of ⊢ such that
    the assumptions P1, P2, ... appear at the front, in that order. *)
Tactic Notation "to_front" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Ps =>
    bi_reflection.quote_l;
    let Σ := match goal with |- bi_reflection.eval ?Σ _ ⊢ _ => Σ end in
    let ns' := lazymatch type of (_ : bi_reflection.QuoteArgs Σ Ps _) with
               | bi_reflection.QuoteArgs _ _ ?ns' => ns'
               end in
    eapply entails_equiv_l;
      first (apply bi_reflection.split_l with (ns:=ns'); cbv; reflexivity);
      simpl).

Tactic Notation "to_back" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Ps =>
    bi_reflection.quote_l;
    let Σ := match goal with |- bi_reflection.eval ?Σ _ ⊢ _ => Σ end in
    let ns' := lazymatch type of (_ : bi_reflection.QuoteArgs Σ Ps _) with
               | bi_reflection.QuoteArgs _ _ ?ns' => ns'
               end in
    eapply entails_equiv_l;
      first (apply bi_reflection.split_r with (ns:=ns'); cbv; reflexivity);
      simpl).

(** [sep_split] is used to introduce a (∗).
    Use [sep_split left: [P1, P2, ...]] to define which assertions will be
    taken to the left; the rest will be available on the right.
    [sep_split right: [P1, P2, ...]] works the other way around. *)
Tactic Notation "sep_split" "right:" open_constr(Ps) :=
  to_back Ps; apply sep_mono.
Tactic Notation "sep_split" "left:" open_constr(Ps) :=
  to_front Ps; apply sep_mono.


Require Import Bedrock.sep.Locals.
Require Import Bedrock.StringSet.
Import StringSet.

Set Implicit Arguments.

Definition agree_in a b := For_all (fun x => sel a x = sel b x).

Definition agree_except a b s := forall x, sel a x <> sel b x -> In x s.


From iVM Require Import Init Lens Mon Extras.Lens.

Unset Suggest Proof Using.

Section Initial.

  Context (S: Type).

  Class SMorphism m0 `{SM0: SMonad S m0} m1 `{SM1: SMonad S m1} (F: forall {A}, m0 A -> m1 A) :=
  {
    morph_ret A (a: A) : F (ret a) = ret a;
    morph_bind A (ma: m0 A) B (f: A -> m0 B) : F (ma >>= f) = (F ma) >>= (fun x => F (f x));
    morph_err A : F (err : m0 A) = err;
    morph_get : F get = get;
    morph_put s : F (put s) = put s;
  }.

  (** Initial SMonad *)

  Definition EST A : Type := S -> option (A * S).

  #[refine]
  Global Instance est_smonad : SMonad S EST :=
  {
    ret A a s := Some (a, s);
    bind A B ma f s :=
      match ma s with
      | None => None
      | Some (a, s') => f a s'
      end;
    err _ _ := None;
    get s := Some (s, s);
    put s _ := Some (tt, s);
  }.
  Proof.
    all: try reflexivity.
    all: intros;
      extensionality s;
      destruct (mx s) as [[a s']|];
      reflexivity || f_equal.
  Defined.

  Definition from_est {m} `{SMonad S m} {A} (ma: EST A) : m A :=
    let* s := get in
    match ma s with
    | None => err
    | Some (a, s') => put s';; ret a
    end.

  Lemma est_characterization A (ma: EST A) : from_est ma = ma.
  Proof.
    unfold from_est.
    simpl.
    extensionality s.
    destruct (ma s) as [[a s']|]; reflexivity.
  Qed.

  Lemma est_unique m `{SMonad S m} F `{SMorphism EST (SM0:=est_smonad) m F} A (ma: EST A) : F A ma = from_est ma.
  Proof.
    rewrite <- est_characterization at 1.
    unfold from_est at 1.
    rewrite morph_bind, morph_get. unfold from_est. f_equal.
    extensionality s.
    destruct (ma s) as [[a s']|].
    - rewrite morph_bind, morph_put. f_equal.
      extensionality u. destruct u.
      rewrite morph_ret. reflexivity.
    - rewrite morph_err. reflexivity.
  Qed.

  Global Instance est_morphism m `{SMonad S m}: SMorphism EST m (@from_est m _).
  Proof.
    split.
    - intros A a. unfold from_est. simpl.
      rewrite get_put', get_ret'. reflexivity.
    - intros A ma B f.
      unfold from_est.
      simpl.
      rewrite bind_assoc.
      f_equal.
      extensionality s.
      destruct (ma s) as [[a s']|].
      + smon_rewrite.
        destruct (f a s') as [[b s'']|];
          smon_rewrite.
      + smon_rewrite.
    - intros A.
      unfold from_est. simpl. smon_rewrite.
    - unfold from_est. simpl. smon_rewrite.
    - intros s. unfold from_est. simpl. smon_rewrite.
  Qed.

End Initial.

(** ** The trivial [SMonad] *)

Section trivial_section.

  Context (S: Type).

  Local Ltac crush :=
    repeat (match goal with
            | [|- unit] => exact tt
            | [|- forall (_:unit),_] => intros []
            | [|- ?x = ?y :> unit] => destruct x; destruct y
            end
            || intro
            || reflexivity
            || assumption).

  #[refine]
  Instance trivial_smonad : SMonad S (fun _ => unit) := { }.
  all: crush.
  Defined.

  (** Clearly, this is the terminal [SMonad]. Moreover, this means that
      there are non-trivial "termination properties" that hold in all
      [SMonads]. Thus, we shall express and prove such properties only for
      the initial [SMonad]. *)

End trivial_section.


Require Import ssreflect ssrfun ssrbool.
Require Import Generic.lemmas Generic.wlog.
Require Import PG32.pg32_inductive PG32.pg32_spreads_packings.

Require Import List.
Import ListNotations.

Lemma Point_dec : forall p q : Point, {p=q}+{p<>q}.
Proof.
intros p q; case p; case q; solve [left; reflexivity | right; discriminate].
Defined.

Lemma Line_dec : forall p q : Line, {p=q}+{p<>q}.
Proof.
intros p q; case p; case q; solve [left; reflexivity | right; discriminate].
Defined.

(*Definition inb := in_dec Point_dec.*)
Definition inbL := in_dec Line_dec.

Definition forall_Line (f:Line -> bool) : bool :=
  f L0 && f L1 && f L2 && f L3 && f L4 && f L5 && f L6 && f L7 && f L8 && f L9 &&
  f L10 && f L11 && f L12 && f L13 && f L14 && f L15 && f L16 && f L17 && f L18 && f L19 &&
  f L20 && f L21 && f L22 && f L23 && f L24 && f L25 && f L26 && f L27 && f L28 && f L29 &&
  f L30 && f L31 && f L32 && f L33 && f L34.

Lemma forall_forall_Line : forall P:Line->bool, (forall p:Line, P p) <-> forall_Line P.
Proof.
  intros P; split.
  intros H; unfold forall_Line; repeat apply foo; apply H.
  unfold forall_Line; intros Hf.
  induction p; revert Hf; repeat rewrite and_bool; intros Hf; tauto.
Qed.

Definition is_partition7 (p q r s t u v: list Line) : bool :=
  (forall_Line (fun x => inbL x p || inbL x q || inbL x r || inbL x s || inbL x t || inbL x u || inbL x v))
  && (forall_Line (fun x => negb (inbL x p && inbL x q && inbL x r && inbL x s && inbL x t && inbL x u && inbL x v))).

Definition intersection (l1 l2 : list Line) : list Line :=
  List.filter (fun n => List.existsb (eqL n) l2) l1.

Lemma eqL_eq : forall x y:Line, eqL x y = true <-> x=y.
Proof.
  intros x y.
  split.
  destruct x; destruct y; intros H; solve [inversion H | reflexivity ].
intros Hxy; rewrite Hxy; destruct y; solve [trivial].
Qed.

Lemma intersectionL l1 l2 n : In n (intersection l1 l2) <-> In n l1 /\ In n l2.
Proof.
unfold intersection.
rewrite filter_In; rewrite existsb_exists; split.
- intros [H1 [m [H2 e]]]; split; trivial.
  revert e; rewrite eqL_eq; intros e; congruence.
- intros [H1 H2]; split; trivial.
  exists n; split; trivial.
  destruct n; trivial.
Qed.

Definition disjointL (l1 l2:list Line) : bool :=
  match intersection l1 l2 with
  | [] => true
  | _ => false
  end.

Definition disj_7s (A B C D E F G:list Line) : bool :=
  (disjointL A B) && (disjointL A C) && (disjointL A D) && (disjointL A E) && (disjointL A F) && (disjointL A G)
  && (disjointL B C) && (disjointL B D) && (disjointL B E) && (disjointL B F) && (disjointL B G)
  && (disjointL C D) && (disjointL C E) && (disjointL C F) && (disjointL C G)
  && (disjointL D E) &&  (disjointL D F) && (disjointL D G)
  && (disjointL E F) && (disjointL E G)
  && (disjointL F G).

Definition is_packing7 (s1 s2 s3 s4 s5 s6 s7:list Line) : bool :=
  disj_7s s1 s2 s3 s4 s5 s6 s7 &&
          is_partition7 s1 s2 s3 s4 s5 s6 s7.

Lemma is_packing_descr_A :
  forall s1 s2 s3 s4 s5 s6 s7 : list Line, In [s1;s2;s3;s4;s5;s6;s7] packings -> (is_packing7 s1 s2 s3 s4 s5 s6 s7).
Proof.
  intros s1 s2 s3 s4 s5 s6 s7 HIn_P.
  repeat (destruct HIn_P as [HeqL | HIn_P]; [ inversion HeqL; reflexivity | idtac]).
  inversion HIn_P.
Qed.

Lemma In_spreads_decomp :
  forall s:list Line, In s spreads ->
                      S0=s \/ S1=s \/ S2=s \/ S3=s \/ S4=s \/ S5=s \/ S6=s \/ S7=s \/ S8=s \/ S9=s \/
                      S10=s \/ S11=s \/ S12=s \/ S13=s \/ S14=s \/ S15=s \/ S16=s \/ S17=s \/ S18=s \/ S19=s \/
                      S20=s \/ S21=s \/ S22=s \/ S23=s \/ S24=s \/ S25=s \/ S26=s \/ S27=s \/ S28=s \/ S29=s \/
                      S30=s \/ S31=s \/ S32=s \/ S33=s \/ S34=s \/ S35=s \/ S36=s \/ S37=s \/ S38=s \/ S39=s \/
                      S40=s \/ S41=s \/ S42=s \/ S43=s \/ S44=s \/ S45=s \/ S46=s \/ S47=s \/ S48=s \/ S49=s \/
                      S50=s \/ S51=s \/ S52=s \/ S53=s \/ S54=s \/ S55=s.
Proof.
  intros s Hs; unfold spreads in Hs.
  repeat (match goal with Hs: In s _ |- _ => inversion Hs;clear Hs; [tauto | idtac] end).
  inversion H0.
Qed.

Definition ltL (x y:Line) := PeanoNat.Nat.ltb (L2nat x) (L2nat y).

Fixpoint ltS (s1 s2: list Line) : bool :=
  match (s1,s2) with
  | ([],_) => false
  | (_,[]) => false
  | (x::xs,y::ys) => (ltL x y) || (eqL x y && ltS xs ys)
  end.
Lemma andb_andP : forall A B C D E F G H I J K L M N O P Q R S T U, A && B && C && D && E &&
        F && G && H && I &&
        J && K && L && M &&
        N && O && P && Q &&
        R && S && T && U -> A /\ B /\ C /\ D /\ E /\
        F /\ G /\ H /\ I /\
        J /\ K /\ L /\ M /\
        N /\ O /\ P /\ Q /\
        R /\ S /\ T /\ U.
Proof.
  intros a b c d e f g h i j k l m n o p q r s t u Hu'.
destruct  (and_bool_lr _ _ Hu') as [Ht' Hu].
destruct (and_bool_lr _ _ Ht') as [Hs' Ht].
destruct (and_bool_lr _ _ Hs') as [Hr' Hs].
destruct (and_bool_lr _ _ Hr') as [Hq' Hr].
destruct (and_bool_lr _ _ Hq') as [Hp' Hq].
destruct (and_bool_lr _ _ Hp') as [Ho' Hp].
destruct (and_bool_lr _ _ Ho') as [Hn' Ho].
destruct (and_bool_lr _ _ Hn') as [Hm' Hn].
destruct (and_bool_lr _ _ Hm') as [Hl' Hm].
destruct (and_bool_lr _ _ Hl') as [Hk' Hl].
destruct (and_bool_lr _ _ Hk') as [Hj' Hk].
destruct (and_bool_lr _ _ Hj') as [Hi' Hj].
destruct (and_bool_lr _ _ Hi') as [Hh' Hi].
destruct (and_bool_lr _ _ Hh') as [Hg' Hh].
destruct (and_bool_lr _ _ Hg') as [Hf' Hg].
destruct (and_bool_lr _ _ Hf') as [He' Hf].
destruct (and_bool_lr _ _ He') as [Hd' He].
destruct (and_bool_lr _ _ Hd') as [Hc' Hd].
destruct (and_bool_lr _ _ Hc') as [Hb' Hc].
destruct (and_bool_lr _ _ Hb') as [Ha Hb].
repeat split; assumption.
Qed.

Ltac inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10
     Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21 :=
  solve [inversion Hd1 |
         inversion Hd2 |
         inversion Hd3 |
         inversion Hd4 |
         inversion Hd5 |
         inversion Hd6 |
         inversion Hd7 |
         inversion Hd8 |
         inversion Hd9 |
         inversion Hd10 |
         inversion Hd11 |
         inversion Hd12 |
         inversion Hd13 |
         inversion Hd14 |
         inversion Hd15 |
         inversion Hd16 |
         inversion Hd17 |
         inversion Hd18 |
         inversion Hd19 |
         inversion Hd20 |
         inversion Hd21 ].

Ltac solve_In := solve [apply in_eq | apply in_cons; solve_In].

Definition statement_packings s := forall s2 s3 s4 s5 s6 s7 : list Line,
    In s2 spreads -> In s3 spreads -> In s4 spreads -> In s5 spreads -> In s6 spreads -> In s7 spreads ->
    ltS s s2 -> ltS s2 s3 -> ltS s3 s4 -> ltS s4 s5 -> ltS s5 s6 -> ltS s6 s7 ->
    is_packing7 s s2 s3 s4 s5 s6 s7 -> In [s;s2;s3;s4;s5;s6;s7] packings.
(*
Lemma aux_S0 : statement_packings S0.
Proof.
  intros s2 s3 s4 s5 s6 s7 Hs2 Hs3 Hs4 Hs5 Hs6 Hs7 le12 le23 le34 le45 le56 le67 Hp.
  specialize (and_bool_lr  _ _ Hp) as [Hp1 Hp2]; clear Hp.
  destruct (andb_andP _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hp1)
    as [Hd1 [Hd2 [Hd3 [Hd4 [Hd5 [ Hd6 [Hd7 [Hd8 [Hd9 [Hd10 [Hd11 [ Hd12 [Hd13 [Hd14 [Hd15 [Hd16 [Hd17 [Hd18 [Hd19 [Hd20 Hd21]]]]]]]]]]]]]]]]]]]]; clear Hp1 Hp2.
  Set Ltac Profiling.
  (* specialize (and_bool_lr  _ _ Hp2) as [Hp2a Hp2b].
  Search forall_Line.
  rewrite <- forall_forall_Line in Hp2a.
  rewrite <- forall_forall_Line in Hp2b.*)
  decompose [or] (In_spreads_decomp s2 Hs2); clear Hs2; subst s2;
    try solve [inversion le12 | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10
                                           Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21];
    decompose [or] (In_spreads_decomp s3 Hs3); clear Hs3; subst s3;
      try solve [inversion le23 | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10
                                             Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21].
  (* 225 cases to handle*)
  par:time( decompose [or] (In_spreads_decomp s4 Hs4); clear Hs4; subst s4;
          try solve [inversion le34
                    | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
                    | (decompose [or] (In_spreads_decomp s5 Hs5); clear Hs5; subst s5;
                       solve  [ inversion le45
                              | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
                              | (decompose [or] (In_spreads_decomp s6 Hs6); clear Hs6; subst s6;
                                 solve [inversion le56
                                       | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
                                       | (decompose [or] (In_spreads_decomp s7 Hs7); clear Hs7; subst s7;
                                          solve [ inversion le67 | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21 | solve_In])])])]).
Qed.
 *)

(*Ltac subst' r := match goal with H:_=r |- _ => rewrite <- H in *; clear H end.*)

Ltac solve_goal1 :=
 let s2 := fresh "s2" in
  let s3 := fresh "s3" in
  let s4 := fresh "s4" in
  let s5 := fresh "s5" in
  let s6 := fresh "s6" in
  let s7 := fresh "s7" in
  let Hs2 := fresh "Hs2" in
  let Hs3 := fresh "Hs3" in
  let Hs4 := fresh "Hs4" in
  let Hs5 := fresh "Hs5" in
  let Hs6 := fresh "Hs6" in
  let Hs7 := fresh "Hs7" in
  let le12 := fresh "le12" in
  let le23 := fresh "le23" in
  let le34 := fresh "le34" in
  let le45 := fresh "le45" in
  let le56 := fresh "le56" in
  let le67 := fresh "le67" in
  let Hp := fresh "Hp" in
  let Hp1 := fresh "Hp1" in
  let Hp2 := fresh "Hp2" in
  let Hd1 := fresh "Hd1" in
  let Hd2 := fresh "Hd2" in
  let Hd3 := fresh "Hd3" in
  let Hd4 := fresh "Hd4" in
  let Hd5 := fresh "Hd5" in
  let Hd6 := fresh "Hd6" in
  let Hd7 := fresh "Hd7" in
  let Hd8 := fresh "Hd8" in
  let Hd9 := fresh "Hd9" in
  let Hd10 := fresh "Hd10" in
  let Hd11 := fresh "Hd11" in
  let Hd12 := fresh "Hd12" in
  let Hd13 := fresh "Hd13" in
  let Hd14 := fresh "Hd14" in
  let Hd15 := fresh "Hd15" in
  let Hd16 := fresh "Hd16" in
  let Hd17 := fresh "Hd17" in
  let Hd18 := fresh "Hd18" in
  let Hd19 := fresh "Hd19" in
  let Hd20 := fresh "Hd20" in
  let Hd21 := fresh "Hd21" in
  intros s2 s3 s4 s5 s6 s7 Hs2 Hs3 Hs4 Hs5 Hs6 Hs7 le12 le23 le34 le45 le56 le67 Hp;
  destruct (and_bool_lr  _ _ Hp) as [Hp1 Hp2]; clear Hp;
  destruct (andb_andP _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hp1)
    as [Hd1 [Hd2 [Hd3 [Hd4 [Hd5 [ Hd6 [Hd7 [Hd8 [Hd9 [Hd10 [Hd11 [ Hd12 [Hd13 [Hd14 [Hd15 [Hd16 [Hd17 [Hd18 [Hd19 [Hd20 Hd21]]]]]]]]]]]]]]]]]]]]; clear Hp1 Hp2;
  decompose [or] (In_spreads_decomp s2 Hs2); clear Hs2; subst s2;
  try solve [inversion le12
            | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
            ];clear le12;
  decompose [or] (In_spreads_decomp s3 Hs3); clear Hs3; subst s3;
  try solve [inversion le23
        | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
            ]; clear le23.

Ltac solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 (*le12 le23*) le34 le45 le56 le67
     (*Hp1 Hp2*) Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21 :=

  time(decompose [or] (In_spreads_decomp s4 Hs4); clear Hs4; subst s4;
        solve [inversion le34
              | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
              | (clear le34; decompose [or] (In_spreads_decomp s5 Hs5); clear Hs5; subst s5;
                 solve  [ inversion le45
                        | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
                        | (clear le45; decompose [or] (In_spreads_decomp s6 Hs6); clear Hs6; subst s6;
                           solve [inversion le56
                                 | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21
                                 | (clear le56; decompose [or] (In_spreads_decomp s7 Hs7); clear Hs7; subst s7;
                                    solve [ inversion le67 | inversions Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21 | solve_In])])])]).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                    SF_Tactics.v                                    *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Terms.

Definition termred := SF -> SF -> Prop.

Definition preserve (R : termred) (P : SF -> Prop) :=
  forall x : SF, P x -> forall y : SF, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: SF-> SF -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Hint Constructors multi_step.

Definition reflective red := forall (M: SF), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Definition transitive red := forall (M N P: SF), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Hint Resolve preserves_app_multi_step.

Ltac inv1 prop :=
match goal with
| H: prop _ |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof.
unfold diamond; split_all. elim (H M P H1 N H0); split_all. inversion H2.
 exist x.
Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all. inversion H3.
elim(IHmulti_step H x); split_all. inversion H6.
exist x0. split. auto.
apply succ_red with x; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all. inversion H3.
elim(IHmulti_step H x); split_all. inversion H6.
exist x0. split. auto.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
inversion H3.
elim(IHmulti_step H x H4); split_all. inversion H6.
exist x0. split. auto.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Fixpoint rank (M: SF) :=
match M with
| Ref _ => 1
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

Ltac rank_tac := match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H | ]
end .


(** * Equivalences *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Equivalences.

Definition weq_to_InverseEquivalence X Y : X ≃ Y -> Equivalence Y X.
  intros [f r].
  unfold isweq in r.
  set (g := λ y, hfiberpr1 f y (pr1 (r y))).
  set (p := λ y, pr2 (pr1 (r y))).
  simpl in p.
  set (L := λ x, pr2 (r (f x)) (make_hfiber f x (idpath (f x)))).
  set (q := λ x, maponpaths pr1 (L x)).
  set (q' := λ x, !q x).
  refine (makeEquivalence Y X g f q' p _).
  intro y.
  admit.
Abort.

Definition Equivalence_to_invweq X Y : Equivalence X Y -> Y ≃ X.
Proof.
  intros [f [g [p [q h]]]]. exists g. unfold isweq. intro x.
  exists (f x,,q x). intros [y []]. apply (two_arg_paths_f (!p y)).
  admit.
Abort.

Definition weq_pathscomp0r {X} x {y z:X} (p:y = z) : (x = y) ≃ (x = z).
Proof.
  intros. exact (make_weq _ (isweqpathscomp0r _ p)).
Defined.

Definition iscontrretract_compute {X Y} (p:X->Y) (s:Y->X)
           (eps:∏ y : Y, p (s y) = y) (is:iscontr X) :
  iscontrpr1 (iscontrretract p s eps is) = p (iscontrpr1 is).
Proof.
  intros. unfold iscontrretract. destruct is as [ctr uni].
  simpl. reflexivity.
Defined.

Definition iscontrweqb_compute {X Y} (w:X ≃ Y) (is:iscontr Y) :
  iscontrpr1 (iscontrweqb w is) = invmap w (iscontrpr1 is).
Proof.
  intros. unfold iscontrweqb. rewrite iscontrretract_compute.
  reflexivity.
Defined.

Definition compute_iscontrweqb_weqfibtototal_1 {T} {P Q:T->Type}
           (f:∏ t, (P t) ≃ (Q t))
           (is:iscontr (total2 Q)) :
  pr1 (iscontrpr1 (iscontrweqb (weqfibtototal P Q f) is)) = pr1 (iscontrpr1 is).
Proof.
  intros. destruct is as [ctr uni]. reflexivity.
Defined.

Definition compute_pr1_invmap_weqfibtototal {T} {P Q:T->Type}
           (f:∏ t, (P t) ≃ (Q t))
           (w:total2 Q) :
  pr1 (invmap (weqfibtototal P Q f) w) = pr1 w.
Proof.
  intros. reflexivity.
Defined.

Definition compute_pr2_invmap_weqfibtototal {T} {P Q:T->Type}
           (f:∏ t, (P t) ≃ (Q t))
           (w:total2 Q) :
  pr2 (invmap (weqfibtototal P Q f) w) = invmap (f (pr1 w)) (pr2 w).
Proof.
  intros. reflexivity.
Defined.

Definition compute_iscontrweqb_weqfibtototal_3 {T} {P Q:T->Type}
           (f:∏ t, (P t) ≃ (Q t))
           (is:iscontr (total2 Q)) :
  maponpaths pr1 (iscontrweqb_compute (weqfibtototal P Q f) is)
  =
  compute_iscontrweqb_weqfibtototal_1 f is.
Proof.
  intros. destruct is as [ctr uni]. reflexivity.
Defined.

Definition iscontrcoconustot_comp {X} {x:X} :
  iscontrpr1 (iscontrcoconustot X x) = x,,idpath x.
Proof.
  reflexivity.
Defined.

Definition funfibtototal {X} (P Q:X->Type) (f:∏ x:X, P x -> Q x) :
  total2 P -> total2 Q.
Proof.
  intros [x p]. exact (x,,f x p).
Defined.

Definition weqfibtototal_comp {X} (P Q:X->Type) (f:∏ x:X, (P x) ≃ (Q x)) :
  invmap (weqfibtototal P Q f) = funfibtototal Q P (λ x, invmap (f x)).
Proof.
  intros. apply funextsec; intros [x q]. reflexivity.
Defined.

Definition eqweqmapap_inv {T} (P:T->Type) {t u:T} (e:t = u) (p:P u) :
  (eqweqmap (maponpaths P e)) ((eqweqmap (maponpaths P (!e))) p) = p.
Proof.
  intros. destruct e. reflexivity.
Defined.

Definition eqweqmapap_inv' {T} (P:T->Type) {t u:T} (e:t = u) (p:P t) :
  (eqweqmap (maponpaths P (!e))) ((eqweqmap (maponpaths P e)) p) = p.
Proof.
  intros. destruct e. reflexivity.
Defined.

Definition weqpr1_irr_sec {X} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) : weq (total2 P) X.
(* compare with weqpr1 *)
Proof.
  intros.
  set (isc := λ x, iscontraprop1 (invproofirrelevance _ (irr x)) (sec x)).
  apply Equivalence_to_weq.
  simple refine (makeEquivalence _ _ _ _ _ _ _).
  { exact pr1. }
  { intro x. exact (x,,sec x). }
  { intro x. reflexivity. }
  { intros [x p]. simpl. apply maponpaths. apply irr. }
  { intros [x p]. simpl. apply pair_path_in2_comp1. }
Defined.

Definition invweqpr1_irr_sec {X} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) : X ≃ (total2 P).
(* compare with weqpr1 *)
Proof.
  intros.
  set (isc := λ x, iscontraprop1 (invproofirrelevance _ (irr x)) (sec x)).
  apply Equivalence_to_weq.
  simple refine (makeEquivalence _ _ _ _ _ _ _).
  { intro x. exact (x,,sec x). }
  { exact pr1. }
  { intros [x p]. simpl. apply maponpaths. apply irr. }
  { intro x. reflexivity. }
  { intro x'. simpl. rewrite (irrel_paths (irr _) (irr _ _ _) (idpath (sec x'))).
    reflexivity. }
Defined.

Definition homotinvweqweq' {X} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (s:∏ x, P x) (w:total2 P) :
  invmap (weqpr1_irr_sec irr s) (weqpr1_irr_sec irr s w) = w.
Proof.
  revert w; intros [x p]. apply pair_path_in2. apply irr.
Defined.

Definition homotinvweqweq'_comp {X} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x)
           (x:X) (p:P x) :
  let f := weqpr1_irr_sec irr sec in
  let w := x,,p in
  let w' := invweq f x in
  @paths (w' = w)
            (homotinvweqweq' irr sec w)
            (maponpaths _ (irr x (sec x) (pr2 w))).
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Definition homotinvweqweq_comp {X} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x)
           (x:X) (p:P x) :
  let f := weqpr1_irr_sec irr sec in
  let w := x,,p in
  let w' := invweq f x in
  @paths (w' = w)
            (homotinvweqweq f w)
            (maponpaths _ (irr x (sec x) (pr2 w))).
Proof.
  try reflexivity.              (* this worked above but doesn't work here *)
Abort.

Definition homotinvweqweq_comp_3 {X} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x)
           (x:X) (p:P x) :
  let f := weqpr1_irr_sec irr sec in
  let g := invweqpr1_irr_sec irr sec in
  let w := x,,p in
  let w' := g x in
  @paths (w' = w)
            (homotweqinvweq g w)    (* !! *)
            (maponpaths _ (irr x (sec x) (pr2 w))).
Proof.
  reflexivity.
Defined.

Definition loop_correspondence {T X Y}
           (f:T ≃ X) (g:T->Y)
           {t t':T} {l:t = t'}
           {m:f t = f t'} (mi:maponpaths f l = m)
           {n:g t = g t'} (ni:maponpaths g l = n) :
     maponpaths (funcomp (invmap f) g) m @ maponpaths g (homotinvweqweq f t')
  = maponpaths g (homotinvweqweq f t) @ n.
Proof.
  intros. destruct ni, mi, l. simpl. rewrite pathscomp0rid. reflexivity.
Defined.

Definition loop_correspondence' {X Y} {P:X->Type}
           (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x)
           (g:total2 P->Y)
           {w w':total2 P} {l:w = w'}
           {m:weqpr1_irr_sec irr sec w = weqpr1_irr_sec irr sec w'} (mi:maponpaths (weqpr1_irr_sec irr sec) l = m)
           {n:g w = g w'} (ni:maponpaths g l = n) :
     maponpaths (funcomp (invmap (weqpr1_irr_sec irr sec)) g) m @ maponpaths g (homotinvweqweq' irr sec w')
  = maponpaths g (homotinvweqweq' irr sec w) @ n.
Proof.
  intros. destruct ni, mi, l. simpl. rewrite pathscomp0rid. reflexivity.
Defined.

(*
Local Variables:
compile-command: "make -C ../.. TAGS TAGS-Ktheory UniMath/Ktheory/Equivalences.vo"
End:
*)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library 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 the
COPYING file for more details.
*)

(** * Error of the multiplication is in the FLX/FLT format *)

From Coq Require Import Lia.
Require Import Core Operations Plus_error.

Section Fprop_mult_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Notation format := (generic_format beta (FLX_exp prec)).
Notation cexp := (cexp beta (FLX_exp prec)).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** Auxiliary result that provides the exponent *)
Lemma mult_error_FLX_aux:
  forall x y,
  format x -> format y ->
  (round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R ->
  exists f:float beta,
    (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R
    /\ (cexp (F2R f) <= Fexp f)%Z
    /\ (Fexp f = cexp x + cexp y)%Z.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hz.
set (f := (round beta (FLX_exp prec) rnd (x * y))).
destruct (Req_dec (x * y) 0) as [Hxy0|Hxy0].
contradict Hz.
rewrite Hxy0.
rewrite round_0...
ring.
destruct (mag beta (x * y)) as (exy, Hexy).
specialize (Hexy Hxy0).
destruct (mag beta (f - x * y)) as (er, Her).
specialize (Her Hz).
destruct (mag beta x) as (ex, Hex).
assert (Hx0: (x <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_l.
specialize (Hex Hx0).
destruct (mag beta y) as (ey, Hey).
assert (Hy0: (y <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_r.
specialize (Hey Hy0).
(* *)
assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z).
unfold cexp, FLX_exp.
rewrite mag_unique with (1 := Hex).
rewrite mag_unique with (1 := Hey).
rewrite mag_unique with (1 := Hexy).
cut (exy - 1 < ex + ey)%Z. lia.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := proj1 Hexy).
rewrite Rabs_mult.
rewrite bpow_plus.
apply Rmult_le_0_lt_compat.
apply Rabs_pos.
apply Rabs_pos.
apply Hex.
apply Hey.
(* *)
assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z).
unfold cexp, FLX_exp.
rewrite mag_unique with (1 := Hex).
rewrite mag_unique with (1 := Hey).
rewrite mag_unique with (1 := Hexy).
cut ((ex - 1) + (ey - 1) < exy)%Z.
generalize (prec_gt_0 prec).
clear ; lia.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 Hexy).
rewrite Rabs_mult.
rewrite bpow_plus.
apply Rmult_le_compat.
apply bpow_ge_0.
apply bpow_ge_0.
apply Hex.
apply Hey.
(* *)
assert (Hr: ((F2R (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) *
  Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) *
  beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y))) = f - x * y)%R).
rewrite Hx at 6.
rewrite Hy at 6.
rewrite <- F2R_mult.
simpl.
unfold f, round, Rminus.
rewrite <- F2R_opp, Rplus_comm, <- F2R_plus.
unfold Fplus. simpl.
now rewrite Zle_imp_le_bool with (1 := Hc2).
(* *)
exists (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) *
  Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) *
  beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y)).
split;[assumption|split].
rewrite Hr.
simpl.
clear Hr.
apply Z.le_trans with (cexp (x * y)%R - prec)%Z.
unfold cexp, FLX_exp.
apply Zplus_le_compat_r.
rewrite mag_unique with (1 := Hexy).
apply mag_le_bpow with (1 := Hz).
replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)).
apply error_lt_ulp...
rewrite ulp_neq_0; trivial.
unfold cexp.
now rewrite mag_unique with (1 := Hexy).
apply Hc1.
reflexivity.
Qed.

(** Error of the multiplication in FLX *)
Theorem mult_error_FLX :
  forall x y,
  format x -> format y ->
  format (round beta (FLX_exp prec) rnd (x * y) - (x * y))%R.
Proof.
intros x y Hx Hy.
destruct (Req_dec (round beta (FLX_exp prec) rnd (x * y) - x * y) 0) as [Hr0|Hr0].
rewrite Hr0.
apply generic_format_0.
destruct (mult_error_FLX_aux x y Hx Hy Hr0) as ((m,e),(H1,(H2,H3))).
rewrite <- H1.
now apply generic_format_F2R.
Qed.

Lemma mult_bpow_exact_FLX :
  forall x e,
  format x ->
  format (x * bpow e)%R.
Proof.
intros x e Fx.
destruct (Req_dec x 0) as [Zx|Nzx].
{ rewrite Zx, Rmult_0_l; apply generic_format_0. }
rewrite Fx.
set (mx := Ztrunc _); set (ex := cexp _).
pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta).
apply (generic_format_F2R' _ _ _ f).
{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. }
intro Nzmx; unfold mx, ex; rewrite <- Fx.
unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx).
unfold FLX_exp; lia.
Qed.

End Fprop_mult_error.

Section Fprop_mult_error_FLT.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Notation format := (generic_format beta (FLT_exp emin prec)).
Notation cexp := (cexp beta (FLT_exp emin prec)).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** Error of the multiplication in FLT with underflow requirements *)
Theorem mult_error_FLT :
  forall x y,
  format x -> format y ->
  (x * y <> 0 -> bpow (emin + 2*prec - 1) <= Rabs (x * y))%R ->
  format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hxy.
set (f := (round beta (FLT_exp emin prec) rnd (x * y))).
destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0].
rewrite Hr0.
apply generic_format_0.
destruct (Req_dec (x * y) 0) as [Hxy'|Hxy'].
unfold f.
rewrite Hxy'.
rewrite round_0...
ring_simplify (0 - 0)%R.
apply generic_format_0.
specialize (Hxy Hxy').
destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))).
now apply generic_format_FLX_FLT with emin.
now apply generic_format_FLX_FLT with emin.
rewrite <- (round_FLT_FLX beta emin).
assumption.
apply Rle_trans with (2:=Hxy).
apply bpow_le.
generalize (prec_gt_0 prec).
clear ; lia.
rewrite <- (round_FLT_FLX beta emin) in H1.
2:apply Rle_trans with (2:=Hxy).
2:apply bpow_le ; generalize (prec_gt_0 prec) ; clear ; lia.
unfold f; rewrite <- H1.
apply generic_format_F2R.
intros _.
simpl in H2, H3.
unfold cexp, FLT_exp.
case (Zmax_spec (mag beta (F2R (Float beta m e)) - prec) emin);
  intros (M1,M2); rewrite M2.
apply Z.le_trans with (2:=H2).
unfold cexp, FLX_exp.
apply Z.le_refl.
rewrite H3.
unfold cexp, FLX_exp.
assert (Hxy0:(x*y <> 0)%R).
contradict Hr0.
unfold f.
rewrite Hr0.
rewrite round_0...
ring.
assert (Hx0: (x <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_l.
assert (Hy0: (y <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_r.
destruct (mag beta x) as (ex,Ex) ; simpl.
specialize (Ex Hx0).
destruct (mag beta y) as (ey,Ey) ; simpl.
specialize (Ey Hy0).
assert (emin + 2 * prec -1 < ex + ey)%Z.
2: lia.
apply (lt_bpow beta).
apply Rle_lt_trans with (1:=Hxy).
rewrite Rabs_mult, bpow_plus.
apply Rmult_le_0_lt_compat; try apply Rabs_pos.
apply Ex.
apply Ey.
Qed.

Lemma F2R_ge: forall (y:float beta),
   (F2R y <> 0)%R -> (bpow (Fexp y) <= Rabs (F2R y))%R.
Proof.
intros (ny,ey).
rewrite <- F2R_Zabs; unfold F2R; simpl.
case (Zle_lt_or_eq 0 (Z.abs ny)).
apply Z.abs_nonneg.
intros Hy _.
rewrite <- (Rmult_1_l (bpow _)) at 1.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply IZR_le; lia.
intros H1 H2; contradict H2.
replace ny with 0%Z.
simpl; ring.
now apply sym_eq, Z.abs_0_iff, sym_eq.
Qed.

Theorem mult_error_FLT_ge_bpow :
  forall x y e,
  format x -> format y ->
  (bpow (e+2*prec-1) <= Rabs (x * y))%R ->
  (round beta (FLT_exp emin prec) rnd (x * y) - (x * y) <> 0)%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x * y) - (x * y)))%R.
Proof with auto with typeclass_instances.
intros x y e.
set (f := (round beta (FLT_exp emin prec) rnd (x * y))).
intros Fx Fy H1.
unfold f; rewrite Fx, Fy, <- F2R_mult.
simpl Fmult.
destruct (round_repr_same_exp beta (FLT_exp emin prec)
 rnd (Ztrunc (scaled_mantissa beta (FLT_exp emin prec) x) *
             Ztrunc (scaled_mantissa beta (FLT_exp emin prec) y))
      (cexp x + cexp y)) as (n,Hn).
rewrite Hn; clear Hn.
rewrite <- F2R_minus, Fminus_same_exp.
intros K.
eapply Rle_trans with (2:=F2R_ge _ K).
simpl (Fexp _).
apply bpow_le.
unfold cexp, FLT_exp.
destruct (mag beta x) as (ex,Hx).
destruct (mag beta y) as (ey,Hy).
simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z.
2: apply Zplus_le_compat; apply Z.le_max_l.
assert (e + 2*prec -1< ex+ey)%Z;[idtac|lia].
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=H1).
rewrite Rabs_mult, bpow_plus.
apply Rmult_lt_compat.
apply Rabs_pos.
apply Rabs_pos.
apply Hx.
intros K'; contradict H1; apply Rlt_not_le.
rewrite K', Rmult_0_l, Rabs_R0; apply bpow_gt_0.
apply Hy.
intros K'; contradict H1; apply Rlt_not_le.
rewrite K', Rmult_0_r, Rabs_R0; apply bpow_gt_0.
Qed.

Lemma mult_bpow_exact_FLT :
  forall x e,
  format x ->
  (emin + prec - mag beta x <= e)%Z ->
  format (x * bpow e)%R.
Proof.
intros x e Fx He.
destruct (Req_dec x 0) as [Zx|Nzx].
{ rewrite Zx, Rmult_0_l; apply generic_format_0. }
rewrite Fx.
set (mx := Ztrunc _); set (ex := cexp _).
pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta).
apply (generic_format_F2R' _ _ _ f).
{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. }
intro Nzmx; unfold mx, ex; rewrite <- Fx.
unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx).
unfold FLT_exp; rewrite Z.max_l; [|lia]; rewrite <- Z.add_max_distr_r.
set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; lia|].
apply Z.le_max_l.
Qed.

Lemma mult_bpow_pos_exact_FLT :
  forall x e,
  format x ->
  (0 <= e)%Z ->
  format (x * bpow e)%R.
Proof.
intros x e Fx He.
destruct (Req_dec x 0) as [Zx|Nzx].
{ rewrite Zx, Rmult_0_l; apply generic_format_0. }
rewrite Fx.
set (mx := Ztrunc _); set (ex := cexp _).
pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta).
apply (generic_format_F2R' _ _ _ f).
{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. }
intro Nzmx; unfold mx, ex; rewrite <- Fx.
unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx).
unfold FLT_exp; rewrite <-Z.add_max_distr_r.
replace (_ - _ + e)%Z with (mag beta x + e - prec)%Z; [ |ring].
apply Z.max_le_compat_l; lia.
Qed.

End Fprop_mult_error_FLT.


Require Import Coq.Program.Tactics.
Require Import List.
Import ListNotations.

From RT Require Import Pred Refn.

(* Primitive type of nats is a subtype of the base type *)
Lemma subtype_nat_base :
  forall n x y,
    subtype [] (TRefn x (PEq (PVar x) (PNat n))) (TBase y).
Proof.
  intros. constructor. constructor. firstorder.
Qed.

(* Every nat has base type *)
Lemma nat_has_base_type :
  forall n x, type_check [] (LNat n) (TBase x).
Proof.
  intros. eapply check_syn.
  - apply synth_nat.
  - apply subtype_nat_base with (x := 0).
Qed.

(* Nats that type check against a common nat are equal *)
Lemma nat_type_check_eq :
  forall n n' m x y,
    type_check [] (LNat n) (TRefn x (PEq (PVar x) (PNat m))) ->
    type_check [] (LNat n') (TRefn y (PEq (PVar y) (PNat m))) ->
    n = n'.
Proof.
  intros. inversion H; subst; clear H.
  inversion H1; subst; clear H1.
  inversion H2; subst; clear H2.
  inversion H3; subst; clear H3.
  unfold valid in H. simpl in H.
  rewrite PeanoNat.Nat.eqb_refl in H.
  inversion H0; subst; clear H0.
  inversion H1; subst; clear H1.
  inversion H2; subst; clear H2.
  inversion H3; subst; clear H3.
  unfold valid in H0. simpl in H0.
  rewrite PeanoNat.Nat.eqb_refl in H0.
  compute in H. compute in H0.
  rewrite PeanoNat.Nat.eqb_refl in H.
  rewrite PeanoNat.Nat.eqb_refl in H0.
  assert (H1: PNat n = PNat n). { reflexivity. }
  assert (H2: PNat n' = PNat n'). { reflexivity. }
  apply H in H1. apply H0 in H2. rewrite <- H1 in H2.
  injection H2 as H2. symmetry. assumption.
Qed.

(* The primitive type of + is a subtype of + when the second argument
is restricted to a particular nat *)
Lemma subtype_add_prim_inc :
  forall n,
    subtype []
      (TFun 0 (TBase 0) (TFun 1 (TBase 1) (TRefn 2 (PEq (PVar 2) (PAdd (PVar 0) (PVar 1))))))
      (TFun 0 (TBase 0) (TFun 1 (TRefn 1 (PEq (PVar 1) (PNat n)))
                           (TRefn 2 (PEq (PVar 2) (PAdd (PVar 0) (PVar 1)))))).
Proof.
  intros. constructor.
  - apply subtype_refl.
  - rewrite same_var_change_type. constructor.
    + apply subtype_ctxt_extend.
      -- reflexivity.
      -- apply subtype_nat_base.
    + rewrite same_var_change_type. constructor.
      rewrite same_var_change_pred. constructor.
      constructor. constructor. compute. intros.
      rewrite H1. reflexivity.
Qed.

(* |- \x.\y.x+y : x{True} -> y{y = 1} -> z{z = x + y} *)
Example type_check_inc_refn :
  type_check []
    (LAbs 0 (LAbs 1 (LAdd (LVar 0) (LVar 1))))
    (TFun 0 (TBase 0) (TFun 1 (TRefn 1 (PEq (PVar 1) (PNat 1)))
                         (TRefn 2 (PEq (PVar 2) (PAdd (PVar 0) (PVar 1)))))).
Proof.
  eapply check_syn.
  - apply synth_add with (z := 2).
  - apply subtype_add_prim_inc.
Qed.

(* |- (x{True} -> y{y = n} -> z{z = x + y}) <: (x{True} -> y{y = n} -> z{z = x + n}) *)
Lemma subtype_inc_refn_nat :
  forall n,
    subtype []
      (TFun 0 (TBase 0) (TFun 1 (TRefn 1 (PEq (PVar 1) (PNat n)))
                           (TRefn 2 (PEq (PVar 2) (PAdd (PVar 0) (PVar 1))))))
      (TFun 0 (TBase 0) (TFun 1 (TRefn 1 (PEq (PVar 1) (PNat n)))
                           (TRefn 2 (PEq (PVar 2) (PAdd (PVar 0) (PNat n)))))).
Proof.
  intros. constructor.
  - apply subtype_refl.
  - simpl. constructor.
    + apply subtype_ctxt_extend.
      -- reflexivity.
      -- apply subtype_refl.
    + simpl; constructor. simpl; constructor.
      simpl; constructor. simpl; constructor.
      compute. intros. injection H0 as H0.
      rewrite H0 in H1. rewrite H1. reflexivity.
Qed.

(* |- \x.\y.x+y : x{True} -> y{y = 1} -> z{z = x + 1} *)
Lemma type_check_inc :
  type_check []
    (LAbs 0 (LAbs 1 (LAdd (LVar 0) (LVar 1))))
    (TFun 0 (TBase 0) (TFun 1 (TRefn 1 (PEq (PVar 1) (PNat 1)))
                         (TRefn 2 (PEq (PVar 2) (PAdd (PVar 0) (PNat 1)))))).
Proof.
  eapply check_syn.
  - apply synth_add with (z := 2).
  - constructor.
    + apply subtype_refl.
    + simpl. constructor.
      -- apply subtype_ctxt_extend.
         ++ reflexivity.
         ++ apply subtype_nat_base.
      -- simpl. constructor. constructor. constructor.
         constructor. compute. intros. injection H0 as H0.
         subst. rewrite H1. reflexivity.
Qed.


(** Proof Reflection in Coq ; eval_subst_lems.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export subst.
Require Export eval_lift_lems.

Set Implicit Arguments.

Section eval_subst_lemmas.

Variable A : Set.
Variable l1 l2 : list nat.
Variable FUN : fun_piT A l1.
Variable REL : rel_piT A l2.
Let P := prf l1 l2.
Let F := frm l1 l2.
Let T := trm l1.
Let Ts := trms l1.
Let C := list F.
Let E := eval_frm' FUN REL.
Let Etrm := eval_trm FUN.
Let Ecxt := eval_cxt' FUN REL.

Lemma eval_subst_var_ok :
 forall (n i : nat) (VAR : nat -> A) (t : T),
 Etrm VAR (subst_var n i t) = insertVAR (Etrm (shiftVAR VAR n) t) VAR n i.
Proof.
simple induction n.
simple destruct i; reflexivity.
intros n' IH.
simple destruct i.
reflexivity.
intros i' V t.
simpl in |- *.
unfold Etrm in |- *.
rewrite (shiftVAR_lift_trm_O FUN V (subst_var n' i' t)).
exact (IH i' (fun p => V (S p)) t).
Qed.

Lemma eval_subst_trm_ok :
 forall (n : nat) (VAR : nat -> A) (t u : T),
 Etrm VAR (subst_trm n t u) =
 Etrm (insertVAR (Etrm (shiftVAR VAR n) u) VAR n) t.
Proof.
intros n V t u.
move t after u.
induction t.
simpl in |- *.
apply eval_subst_var_ok.
simpl in |- *.
rewrite mapn_mapn.
set (f := fun t => Etrm V (subst_trm n t u)) in *.
set (g := Etrm (insertVAR (Etrm (shiftVAR V n) u) V n)) in *.
rewrite (mapn_inn f g l H); reflexivity.
Qed.

Lemma eval_subst_trms_ok :
 forall (n : nat) (VAR : nat -> A) (k : nat) (l : Ts k) (u : T),
 eval_trms FUN VAR (mapn (fun t => subst_trm n t u) l) =
 eval_trms FUN (insertVAR (Etrm (shiftVAR VAR n) u) VAR n) l.
Proof.
intros n V k l u.
induction l; simpl in |- *.
reflexivity.
rewrite eval_subst_trm_ok; rewrite IHl; reflexivity.
Qed.

Lemma eval_subst_frm_ok :
 forall (p : F) (n : nat) (VAR : nat -> A) (u : T),
 E VAR (subst_frm n p u) <-> E (insertVAR (Etrm (shiftVAR VAR n) u) VAR n) p.
Proof.
simple induction p; clear p; simpl in |- *.
intros; apply piffp.
intros; apply piffp.
intros i l n V u.
rewrite (eval_subst_trms_ok n V l u).
apply piffp.
intros p1 IH1 p2 IH2 n V u.
elim (IH1 n V u); intros IH1a IH1b.
elim (IH2 n V u); intros IH2a IH2b.
split; auto.
intros p1 IH1 p2 IH2 n V u.
elim (IH1 n V u); intros IH1a IH1b.
elim (IH2 n V u); intros IH2a IH2b.
split; intro H; elim H; split; auto.
intros p1 IH1 p2 IH2 n V u.
elim (IH1 n V u); intros IH1a IH1b.
elim (IH2 n V u); intros IH2a IH2b.
split; intro H; elim H; auto.
intros p IH n V u.
split; intros H x; elim (IH (S n) (insertVAR_O x V) u); intros IHa IHb;
 unfold Etrm in |- *;
 elim
  (VARexteq_eval_frm FUN REL p _ _
     (insVARswap x (eval_trm FUN (shiftVAR (insertVAR_O x V) (S n)) u) n V));
 intros H1 H2.
rewrite <- (VARexteq_eval_trm FUN _ _ (insVAR_shift x n V)).
apply H2.
apply IHa.
apply H.
apply IHb.
apply H1.
rewrite (VARexteq_eval_trm FUN _ _ (insVAR_shift x n V)).
apply H.
(*exq*)
intros p IH n V u.
split; intro H; elim H; intros x H0; elim (IH (S n) (insertVAR_O x V) u);
 intros IHa IHb; unfold Etrm in |- *;
 elim
  (VARexteq_eval_frm FUN REL p _ _
     (insVARswap x (eval_trm FUN (shiftVAR (insertVAR_O x V) (S n)) u) n V));
 intros H1 H2; exists x.
rewrite <- (VARexteq_eval_trm FUN _ _ (insVAR_shift x n V)).
apply H2.
apply IHa.
exact H0.
apply IHb.
apply H1.
rewrite (VARexteq_eval_trm FUN _ _ (insVAR_shift x n V)).
exact H0.
Qed.

Lemma eval_subst_frm_ok1 :
 forall (p : F) (n : nat) (VAR : nat -> A) (t : T),
 E VAR (subst_frm n p t) -> E (insertVAR (Etrm (shiftVAR VAR n) t) VAR n) p.
Proof fun p n V t => proj1 (eval_subst_frm_ok p n V t).

Lemma eval_subst_frm_ok2 :
 forall (p : F) (n : nat) (VAR : nat -> A) (t : T),
 E (insertVAR (Etrm (shiftVAR VAR n) t) VAR n) p -> E VAR (subst_frm n p t).
Proof fun p n V t => proj2 (eval_subst_frm_ok p n V t).

End eval_subst_lemmas.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work 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 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.algebra.CPoly_Degree.
Import CRing_Homomorphisms.coercions.
From Coq Require Import Lia.

(**
* Reverse of polynomials
*)

Section Monomials.

(**
%\begin{convention}% Let [R] be a ring, and let [RX] be the
polynomials over this ring.
%\end{convention}%
*)

Variable R : CRing.
(* begin hide *)
Let RX := cpoly_cring R.
(* end hide *)

Fixpoint monom (a : R) (n : nat) {struct n} : cpoly_cring R :=
  match n with
  | O   => cpoly_linear _ a (cpoly_zero _)
  | S m => cpoly_linear _ [0] (monom a m)
  end.

Lemma monom_coeff : forall (c : R) n, nth_coeff n (monom c n) [=] c.
Proof.
 intros. induction  n as [| n Hrecn]; intros.
 simpl in |- *. algebra.
  simpl in |- *. algebra.
Qed.

Lemma monom_coeff' : forall (c : R) m n, m <> n -> nth_coeff n (monom c m) [=] [0].
Proof.
 intros c m.
 induction  m as [| m Hrecm]; intros.
  elim (O_or_S n); intro y. elim y. clear y. intros x y. rewrite <- y.
   simpl in |- *. algebra.
   elim (H y).
 elim (O_or_S n); intro y. elim y. clear y. intros x y. rewrite <- y.
  simpl in |- *. apply Hrecm. lia.
  rewrite <- y.
 simpl in |- *. algebra.
Qed.

Hint Resolve monom_coeff monom_coeff': algebra.

Lemma monom_degree : forall (a : R) n, degree_le n (monom a n).
Proof.
 unfold degree_le in |- *. intros.
 cut (n <> m). intro. algebra. lia.
Qed.

Lemma monom_S : forall (a : R) n, monom a (S n) [=] _X_[*]monom a n.
Proof.
 intros.
 apply eq_transitive_unfolded with (cpoly_linear _ [0] (monom a n)).
  simpl in |- *. split. algebra. cut (monom a n [=] monom a n). auto. algebra.
  astepl (_X_[*]monom a n[+]_C_ [0]).
 Step_final (_X_[*]monom a n[+][0]).
Qed.

Hint Resolve monom_S: algebra.

Lemma monom_wd_lft : forall (a b : R) n, a [=] b -> monom a n [=] monom b n.
Proof.
 intros.
 induction  n as [| n Hrecn].
  simpl in |- *. split; auto.
  astepl (_X_[*]monom a n).
 Step_final (_X_[*]monom b n).
Qed.

Hint Resolve monom_wd_lft: algebra_c.

Lemma monom_mult' : forall (a b : R) n, _C_ a[*]monom b n [=] monom (a[*]b) n.
Proof.
 intros.
 induction  n as [| n Hrecn].
  simpl in |- *. split; algebra.
  astepl (_C_ a[*] (_X_[*]monom b n)).
 astepl (_C_ a[*]_X_[*]monom b n).
 astepl (_X_[*]_C_ a[*]monom b n).
 astepl (_X_[*] (_C_ a[*]monom b n)).
 Step_final (_X_[*]monom (a[*]b) n).
Qed.

Hint Resolve monom_mult': algebra.

Lemma monom_mult : forall (a b : R) m n,
 monom a m[*]monom b n [=] monom (a[*]b) (m + n).
Proof.
 intros. induction  m as [| m Hrecm]; intros.
 replace (monom a 0) with (_C_ a). algebra. algebra.
   astepl (_X_[*]monom a m[*]monom b n).
 astepl (_X_[*] (monom a m[*]monom b n)).
 replace (S m + n) with (S (m + n)).
  Step_final (_X_[*]monom (a[*]b) (m + n)).
 auto.
Qed.

Lemma monom_sum : forall (p : RX) n,
 degree_le n p -> p [=] Sum 0 n (fun i => monom (nth_coeff i p) i).
Proof.
 intros.
 unfold RX in |- *; apply all_nth_coeff_eq_imp. intros.
 apply eq_symmetric_unfolded.
 apply eq_transitive_unfolded
   with (Sum 0 n (fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) i0))).
  apply nth_coeff_sum with (p_ := fun i0 : nat => monom (nth_coeff i0 p) i0).
 elim (le_lt_dec i n); intros.
  apply eq_transitive_unfolded with (nth_coeff i (monom (nth_coeff i p) i)).
   apply Sum_term with (f := fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) i0)) (i := i).
     auto with arith. auto.
    intros. algebra.
   algebra.
 apply eq_transitive_unfolded with ([0]:R).
  apply Sum_zero. auto with arith.
   intros. cut (i0 <> i). intro. algebra. lia.
  algebra.
Qed.

End Monomials.

#[global]
Hint Resolve monom_coeff monom_coeff' monom_mult monom_sum: algebra.

Arguments monom [R].

Section Poly_Reverse.

Variable R : CRing.
(* begin hide *)
Let RX := cpoly_cring R.
(* end hide *)

Definition Rev (n : nat) (p : RX) :=
  Sum 0 n (fun i => monom (nth_coeff i p) (n - i)).

Lemma Rev_coeff : forall n p i, i <= n -> nth_coeff i (Rev n p) [=] nth_coeff (n - i) p.
Proof.
 intros.
 unfold Rev in |- *.
 apply eq_transitive_unfolded with
   (Sum 0 n (fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) (n - i0)))).
  apply nth_coeff_sum with (p_ := fun i0 : nat => monom (nth_coeff i0 p) (n - i0)).
 apply eq_transitive_unfolded with (nth_coeff i (monom (nth_coeff (n - i) p) (n - (n - i)))).
  apply Sum_term with (i := n - i)
    (f := fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) (n - i0))).
    auto with arith. lia.
   intros.
  cut (n - j <> i). intro. algebra. lia.
   replace (n - (n - i)) with i. algebra. lia.
Qed.

Lemma Rev_coeff' : forall n p i, n < i -> nth_coeff i (Rev n p) [=] [0].
Proof.
 intros.
 unfold Rev in |- *.
 apply eq_transitive_unfolded with
   (Sum 0 n (fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) (n - i0)))).
  apply nth_coeff_sum with (p_ := fun i0 : nat => monom (nth_coeff (R:=R) i0 p) (n - i0)).
 apply Sum_zero. auto with arith.
  intros.
 cut (n - i0 <> i). intro. algebra. lia.
Qed.

Hint Resolve Rev_coeff Rev_coeff': algebra.

Lemma Rev_wd : forall n p p', degree_le n p -> p [=] p' -> Rev n p [=] Rev n p'.
Proof.
 unfold RX in |- *. intros.
 apply all_nth_coeff_eq_imp. intros.
 elim (le_lt_dec i n); intros.
  astepl (nth_coeff (n - i) p).
  Step_final (nth_coeff (n - i) p').
 Step_final ([0]:R).
Qed.

Hint Resolve Rev_wd: algebra_c.

Lemma Rev_rev : forall n p, degree_le n p -> Rev n (Rev n p) [=] p.
Proof.
 unfold RX in |- *. intros.
 apply all_nth_coeff_eq_imp. intros.
 elim (le_lt_dec i n); intros.
  astepl (nth_coeff (n - i) (Rev n p)).
  pattern i at 2 in |- *. replace i with (n - (n - i)).
  apply Rev_coeff.
   lia.
  lia.
 unfold degree_le in H.
 Step_final ([0]:R).
Qed.

Hint Resolve Rev_rev: algebra.

Lemma Rev_degree_le : forall n p, degree_le n (Rev n p).
Proof.
 unfold degree_le in |- *. algebra.
Qed.

Lemma Rev_degree : forall n p, p ! [0] [#] [0] -> degree n (Rev n p).
Proof.
 unfold degree_le in |- *. unfold degree in |- *. intros. split.
 astepl (nth_coeff (n - n) p).
  replace (n - n) with 0.
   astepl p ! [0]. auto.
   auto with arith.
 apply Rev_degree_le.
Qed.

Lemma Rev_monom : forall (c : R) m n, m <= n -> Rev n (monom c m) [=] monom c (n - m).
Proof.
 intros.
 apply all_nth_coeff_eq_imp. intros.
 elim (le_lt_dec i n); intro y.
  astepl (nth_coeff (n - i) (monom c m)).
  elim (eq_nat_dec m (n - i)); intro H0.
   cut (i = n - m). intro y0.
    rewrite <- y0. rewrite H0. Step_final c.
    lia.
  cut (n - m <> i). intro.
   Step_final ([0]:R).
  lia.
 cut (n - m <> i). intro.
  Step_final ([0]:R).
 lia.
Qed.

Hint Resolve Rev_monom: algebra.

Lemma Rev_zero : forall n, Rev n [0] [=] ([0]:RX).
Proof.
 intros.
 apply all_nth_coeff_eq_imp. intros.
 elim (le_lt_dec i n); intros.
  astepl (nth_coeff (n - i) [0]:R).
  Step_final ([0]:R).
 Step_final ([0]:R).
Qed.

Hint Resolve Rev_zero: algebra.

Lemma Rev_plus : forall p1 p2 n, Rev n (p1[+]p2) [=] Rev n p1[+]Rev n p2.
Proof.
 intros.
 apply all_nth_coeff_eq_imp. intros.
 elim (le_lt_dec i n); intros.
  astepl (nth_coeff (n - i) (p1[+]p2)).
  unfold RX in |- *.
  astepl (nth_coeff (n - i) p1[+]nth_coeff (n - i) p2).
  Step_final (nth_coeff i (Rev n p1) [+]nth_coeff i (Rev n p2)).
 astepl ([0]:R).
 astepl ([0][+] ([0]:R)).
 Step_final (nth_coeff i (Rev n p1) [+]nth_coeff i (Rev n p2)).
Qed.

Hint Resolve Rev_plus: algebra.

Lemma Rev_minus : forall p1 p2 n, Rev n (p1[-]p2) [=] Rev n p1[-]Rev n p2.
Proof.
 intros.
 apply all_nth_coeff_eq_imp. intros.
 elim (le_lt_dec i n); intros.
  astepl (nth_coeff (n - i) (p1[-]p2)).
  unfold RX in |- *.
  astepl (nth_coeff (n - i) p1[-]nth_coeff (n - i) p2).
  Step_final (nth_coeff i (Rev n p1) [-]nth_coeff i (Rev n p2)).
 astepl ([0]:R).
 astepl ([0][-] ([0]:R)).
 Step_final (nth_coeff i (Rev n p1) [-]nth_coeff i (Rev n p2)).
Qed.

Hint Resolve Rev_minus: algebra.

Lemma Rev_sum0 : forall a_ l n, Rev n (Sum0 l a_) [=] Sum0 l (fun i => Rev n (a_ i)).
Proof.
 intros.
 induction  l as [| l Hrecl].
  replace (Sum0 0 a_) with ([0]:RX).
   replace (Sum0 0 (fun i : nat => Rev n (a_ i))) with ([0]:RX).
    algebra. auto. auto.
   replace (Sum0 (S l) a_) with (Sum0 l a_[+]a_ l).
  replace (Sum0 (S l) (fun i : nat => Rev n (a_ i))) with
    (Sum0 l (fun i : nat => Rev n (a_ i)) [+]Rev n (a_ l)).
   astepl (Rev n (Sum0 l a_) [+]Rev n (a_ l)).
   apply bin_op_wd_unfolded. auto. algebra.
    auto. auto.
Qed.

Hint Resolve Rev_sum0: algebra.

Lemma Rev_sum : forall a_ k l n, Rev n (Sum k l a_) [=] Sum k l (fun i => Rev n (a_ i)).
Proof.
 intros.
 unfold Sum in |- *. unfold Sum1 in |- *.
 astepl (Rev n (Sum0 (S l) a_) [-]Rev n (Sum0 k a_)).
 apply cg_minus_wd; apply Rev_sum0.
Qed.

Lemma Rev_mult : forall n1 n2 p1 p2, degree_le n1 p1 -> degree_le n2 p2 ->
 Rev (n1 + n2) (p1[*]p2) [=] Rev n1 p1[*]Rev n2 p2.
Proof.
 intros.
 cut (degree_le (n1 + n2) (p1[*]p2)). intro.
  cut (p1[*]p2 [=] Sum 0 n2 (fun i2 : nat => Sum 0 n1
    (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2)))). intro.
   cut (Rev (n1 + n2) (p1[*]p2) [=] Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat =>
     monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 + n2 - (i1 + i2))))). intro.
    cut (Rev n1 p1 [=] Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1))). intro.
     cut (Rev n2 p2 [=] Sum 0 n2 (fun i2 : nat => monom (nth_coeff i2 p2) (n2 - i2))). intro.
      cut (Rev n1 p1[*]Rev n2 p2 [=] Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat =>
        monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 + n2 - (i1 + i2))))). intro.
       Step_final (Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat =>
         monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 + n2 - (i1 + i2))))).
      astepl (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1)) [*]
        Sum 0 n2 (fun i2 : nat => monom (nth_coeff i2 p2) (n2 - i2))).
      apply eq_transitive_unfolded with (Sum 0 n2 (fun i2 : nat =>
        Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1)) [*]
          monom (nth_coeff i2 p2) (n2 - i2))).
       apply eq_symmetric_unfolded.
       apply mult_distr_sum_lft with (f := fun i2 : nat => monom (nth_coeff i2 p2) (n2 - i2)).
      apply Sum_wd'. auto with arith. intro i2. intros.
       astepl (monom (nth_coeff i2 p2) (n2 - i2) [*]
         Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1))).
      apply eq_transitive_unfolded with (Sum 0 n1 (fun i1 : nat =>
        monom (nth_coeff i2 p2) (n2 - i2) [*]monom (nth_coeff i1 p1) (n1 - i1))).
       apply eq_symmetric_unfolded.
       apply mult_distr_sum_lft with (f := fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1)).
      apply Sum_wd'. auto with arith. intro i1. intros.
       astepl (monom (nth_coeff i1 p1) (n1 - i1) [*]monom (nth_coeff i2 p2) (n2 - i2)).
      astepl (monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 - i1 + (n2 - i2))).
      replace (n1 - i1 + (n2 - i2)) with (n1 + n2 - (i1 + i2)).
       algebra.
      lia.
     unfold Rev in |- *. algebra.
     unfold Rev in |- *. algebra.
    astepl (Rev (n1 + n2) (Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat =>
      monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2))))).
   apply eq_transitive_unfolded with (Sum 0 n2 (fun i2 : nat => Rev (n1 + n2) (Sum 0 n1 (fun i1 : nat =>
     monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2))))).
    apply Rev_sum with (a_ := fun i2 : nat => Sum 0 n1 (fun i1 : nat =>
      monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2))).
   apply Sum_wd'. auto with arith. intro i2. intros.
    apply eq_transitive_unfolded with (Sum 0 n1 (fun i1 : nat =>
      Rev (n1 + n2) (monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2)))).
    apply Rev_sum with (a_ := fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2)).
   apply Sum_wd'. auto with arith. intro i1. intros.
    apply Rev_monom. lia.
   astepl (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) i1) [*]
     Sum 0 n2 (fun i2 : nat => monom (nth_coeff i2 p2) i2)).
  apply eq_transitive_unfolded with (Sum 0 n2 (fun i2 : nat =>
    Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) i1) [*] monom (nth_coeff i2 p2) i2)).
   apply eq_symmetric_unfolded.
   apply mult_distr_sum_lft with (f := fun i2 : nat => monom (nth_coeff i2 p2) i2).
  apply Sum_wd'. auto with arith. intro i2. intros.
   astepl (monom (nth_coeff i2 p2) i2[*] Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) i1)).
  apply eq_transitive_unfolded with (Sum 0 n1 (fun i1 : nat =>
    monom (nth_coeff i2 p2) i2[*]monom (nth_coeff i1 p1) i1)).
   apply eq_symmetric_unfolded.
   apply mult_distr_sum_lft with (f := fun i1 : nat => monom (nth_coeff i1 p1) i1).
  apply Sum_wd'. auto with arith. intro i1. intros.
   Step_final (monom (nth_coeff i1 p1) i1[*]monom (nth_coeff i2 p2) i2).
 unfold RX in |- *. apply degree_le_mult; auto.
Qed.

End Poly_Reverse.

#[global]
Hint Resolve Rev_wd: algebra_c.
#[global]
Hint Resolve Rev_rev Rev_mult: algebra.

Arguments Rev [R].


Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics list.
From discprob.basic Require Import seq_ext.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
From discprob.measure Require Export dynkin borel integral isomorphism.
Require Import ClassicalEpsilon.

Section pushforward.
  Context {A1 A2: Type}.
  Context {F1 : sigma_algebra A1}.
  Context {F2 : sigma_algebra A2}.
  Context (μ: measure F1).
  Context (f: A1 → A2).
  Context (Hmeas: measurable f F1 F2).

  Definition pushforward : measure F2.
  Proof.
    refine {| measure_fun := λ U, μ (fun_inv f U) |}.
    - abstract (by intros ?? ->).
    - intros; apply measure_nonneg.
    - abstract (rewrite fun_inv_empty measure_empty //).
    - abstract (intros Us Hin Hdisj;
                rewrite fun_inv_unionF;
                apply measure_additivity;
                  by [ intros; eapply Hmeas | apply fun_inv_disjointF; auto]).
  Defined.

  Lemma wpt_hom_aux (wpt: weighted_partition F2):
    ∀ (r : R) (U : A1 → Prop),
      In (r, U) (map (λ rU : R * (A2 → Prop), (rU.1, fun_inv f rU.2)) wpt) → F1 U.
  Proof.
    intros r U Hin. apply in_map_iff in Hin as ((r'&U')&Heq&Hin).
    inversion Heq; subst. eapply Hmeas.
    by apply In_wpt_snd_measurable in Hin.
  Qed.

  Lemma wpt_hom_spec:
    ∀ wpt2 : weighted_partition F2, ∃ wpt1 : weighted_partition F1,
      ∀ x, wpt_fun wpt2 (f x) = wpt_fun wpt1 x.
  Proof.
    apply wpt_induction.
    - intros wpt1 wpt2 Heq.
      intros (wpt&?). exists wpt => ?. by rewrite -Heq.
    - intros U HmeasU.
      exists (wpt_indicator (fun_inv f U) (Hmeas _ HmeasU)).
      intros. rewrite ?wpt_indicator_spec.
      destruct excluded_middle_informative; eauto.
    - intros wpt1 wpt2 (wpt1'&Heq1') (wpt2'&Heq2').
      exists (wpt_plus wpt1' wpt2'). intros x.
      rewrite ?wpt_plus_spec. rewrite Heq1' Heq2'. done.
    - intros k wpt (wpt'&Heq').
      exists (wpt_scal k wpt'). intros x. rewrite ?wpt_scal_spec Heq'. auto.
  Qed.

  Lemma wpt_hom_fun (wpt: weighted_partition F2): weighted_partition F1.
  Proof.
    specialize (wpt_hom_spec wpt) => Hspec.
    apply constructive_indefinite_description in Hspec as (wpt'&?).
    exact wpt'.
  Defined.

  Lemma wpt_hom_fun_spec wpt: ∀ x, wpt_fun wpt (f x) = wpt_fun (wpt_hom_fun wpt) x.
  Proof.
    intros x.
    rewrite /wpt_hom_fun; destruct constructive_indefinite_description; eauto.
  Qed.

  Lemma wpt_change_of_variables (wpt1: weighted_partition F1) (wpt2: weighted_partition F2):
    (∀ x, wpt_fun wpt2 (f x) = wpt_fun wpt1 x) →
    wpt_integral μ wpt1 = wpt_integral pushforward wpt2.
  Proof.
    revert wpt2 wpt1.
    eapply (@wpt_induction _ F2 (λ wpt2, ∀ wpt1, (∀ x, wpt_fun wpt2 (f x) = wpt_fun wpt1 x) →
                                wpt_integral μ wpt1 = wpt_integral pushforward wpt2)).
    - intros wpt1 wpt1' Heq Hres1 wpt2 Heq2.
      rewrite Hres1.
      * apply wpt_integral_proper; by symmetry.
      * congruence.
    - intros U HmeasU wpt1 Heq.
      rewrite ?wpt_integral_indicator.
      transitivity (wpt_integral μ (wpt_indicator (fun_inv f U) (Hmeas _ HmeasU))).
      {
        apply wpt_integral_proper.
        intros z. rewrite -Heq ?wpt_indicator_spec //=.
      }
      rewrite wpt_integral_indicator //=.
    - intros wpt1 wpt2 Hspec1 Hspec2 wpt Heq.
      rewrite wpt_integral_plus.
      destruct (wpt_hom_spec wpt1) as (wpt1'&?).
      destruct (wpt_hom_spec wpt2) as (wpt2'&?).
      transitivity (wpt_integral μ (wpt_plus wpt1' wpt2')).
      {
        apply wpt_integral_proper => z. rewrite -Heq. rewrite ?wpt_plus_spec; congruence.
      }
      rewrite wpt_integral_plus; f_equal; eauto.
    - intros k wpt Hspec kwpt Heq.
      destruct (wpt_hom_spec wpt) as (wpt'&?).
      transitivity (wpt_integral μ (wpt_scal k wpt')).
      {
        apply wpt_integral_proper => z. rewrite -Heq. rewrite ?wpt_scal_spec; congruence.
      }
      rewrite ?wpt_integral_scal; f_equal; eauto.
  Qed.

  Lemma is_pos_integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g F2 (borel _)) v:
    (∀ x, 0 <= g x) →
    is_pos_integral μ (λ x, g (f x)) v ↔ is_pos_integral pushforward g v.
  Proof.
    intros Hpos.
    edestruct (wpt_approx_measurable g Hpos Hmeasg) as (wpt&Hincr&Hlim'&Hbound); eauto.
    split.
    - intros His_pos.
      eapply is_pos_integral_mct_wpt; eauto.
      eapply (is_lim_seq_ext (λ n, wpt_integral μ (wpt_hom_fun (wpt n)))).
      { intros n. apply wpt_change_of_variables. intros x.
        rewrite /wpt_hom_fun. destruct constructive_indefinite_description; eauto.
      }
      eapply (is_pos_integral_mct_wpt' μ (λ n, wpt_hom_fun (wpt n)));
        try eapply His_pos; eauto.
      * intros x. eapply is_lim_seq_ext; last eapply Hlim'.
        intros n => //=. apply wpt_hom_fun_spec.
      * intros x n. rewrite -?wpt_hom_fun_spec; eauto.
    - intros His_pos.
      eapply (is_pos_integral_mct_wpt _ (λ n, wpt_hom_fun (wpt n))); eauto.
      * eapply measurable_comp; eauto.
      * intros x. eapply is_lim_seq_ext; last eapply Hlim'.
        intros n => //=. apply wpt_hom_fun_spec.
      * intros x n. rewrite -?wpt_hom_fun_spec; eauto.
      *
      eapply (is_lim_seq_ext (λ n, wpt_integral pushforward (wpt n))).
      { intros n. symmetry. apply wpt_change_of_variables. intros x.
        rewrite /wpt_hom_fun. destruct constructive_indefinite_description; eauto.
      }
      eapply is_pos_integral_mct_wpt'; eauto.
  Qed.

  Lemma is_integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g F2 (borel _)) v:
    is_integral μ (λ x, g (f x)) v ↔ is_integral pushforward g v.
  Proof.
    split.
    - rewrite /is_integral. intros (Hmeas'&(v1&v2&Hpos1&Hpos2&Heq)).
      split; eauto. exists v1, v2.
      split_and!; auto.
      * eapply is_pos_integral_change_of_variables; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
      * eapply is_pos_integral_change_of_variables; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
    - rewrite /is_integral. intros (Hmeas'&(v1&v2&Hpos1&Hpos2&Heq)).
      split; eauto.
      { eapply measurable_comp; eauto. }
      exists v1, v2.
      split_and!; auto.
      * eapply is_pos_integral_change_of_variables in Hpos1; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
      * eapply is_pos_integral_change_of_variables in Hpos2; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
  Qed.

  Lemma Pos_integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g F2 (borel _)):
    (∀ x, 0 <= g x) →
    Pos_integral μ (λ x, g (f x)) = Pos_integral pushforward g.
  Proof.
    intros Hpos.
    destruct (Classical_Prop.classic (∃ v, is_pos_integral pushforward g v)) as [(v&Hex)|Hnex].
    { rewrite (is_pos_integral_unique _ _ _ Hex).
      apply is_pos_integral_unique.
      apply is_pos_integral_change_of_variables; eauto.
    }
    transitivity 0.
    * apply measurable_non_ex_pos_integral_0.
      ** eapply measurable_comp; eauto.
      ** intros (v&Hex).  eapply Hnex. exists v. apply is_pos_integral_change_of_variables; eauto.
    * symmetry; apply measurable_non_ex_pos_integral_0; eauto.
  Qed.

  Lemma Integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g F2 (borel _)):
    Integral μ (λ x, g (f x)) = Integral pushforward g.
  Proof.
    rewrite /Integral; f_equal.
    * eapply (Pos_integral_change_of_variables (λ x, Rmax (g x) 0)); eauto; first measurable.
      intros; apply Rmax_case_strong; nra.
    * eapply (Pos_integral_change_of_variables (λ x, Rmax (- g x) 0)); eauto; first measurable.
      intros; apply Rmax_case_strong; nra.
  Qed.

End pushforward.

Definition measure_restrict {A: Type} (F F': sigma_algebra A) (μ: measure F') (Hle: le_sigma F F'):
  measure F.
Proof.
  apply (pushforward μ id); abstract auto.
Defined.