(* External import(s). *)
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Import         ListNotations.
(* Internal import(s). *)
Require Import Basics.Identifier.
Require Import Basics.Aux.
Require Import Basics.Map.
Require Import Languages.Spass.Syntax.
Require Import Languages.Spass.Semantics.

Definition path       : Type := list cfg.

Definition baseCaseSet_varsAEqual: cfg -> cfg -> Prop :=
  fun c1 c2 =>
    match (c1, c2) with
    | ([_ | e1], [_ | e2]) => find A e1 = find A e2
    end.

Definition baseCaseSet_envsEqual: cfg -> cfg -> Prop :=
  fun c1 c2 => c1 = c2.

Definition isCompletePath (p: path): Prop :=
  match p with
  | nil         => False
  | _           =>
    match (last p emptyCfg) with
    | [EmptyStack | _] => True
    | _                => False
    end
  end.

Inductive isCompletePath_R: cfg -> cfg -> Prop :=
  | CPR_BaseCase: forall P,
      runStep P = None -> isCompletePath_R P P

  | CPR_IndCase : forall P P' P'',
      runStep P = Some P' /\ isCompletePath_R P' P'' ->
        isCompletePath_R P P''.

Definition fullSimulation (P Q: cfg) (baseCaseSet: cfg->cfg->Prop): Prop :=
  forall P', isCompletePath_R P P' ->
    exists Q', isCompletePath_R Q Q' /\
      baseCaseSet P' Q'.

Definition fullEquivalence (P Q:cfg) (baseCaseSet: cfg->cfg->Prop): Prop :=
  fullSimulation P Q baseCaseSet /\ fullSimulation Q P baseCaseSet.

Lemma stepLeft: forall P Q P' baseCaseSet,
  runStep P = Some P' /\ fullSimulation P' Q baseCaseSet  ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart PNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepLeft H] P' H'.
  inversion H'.
  - subst. rewrite HStepLeft in H0.
    inversion H0.
  - subst. destruct H0.
    rewrite HStepLeft in H0.
    injection H0.
    intro HInj.
    rewrite <- HInj in H1.
    specialize (H P').
    specialize (H H1).
    apply H.
Qed.

Lemma stepRight: forall P Q Q' baseCaseSet,
  runStep Q = Some Q' /\ fullSimulation P Q' baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart QNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepRight H] P' H'.
  specialize (H P').
  apply H in H'.
  destruct H', H0.
  assert (isCompletePath_R QStart x). {
    eapply CPR_IndCase.
    split.
    - apply HStepRight.
    - assumption.
  }
  exists x.
  split; assumption.
Qed.

Lemma stepLeftN (n:nat): forall P Q P' baseCaseSet,
  runNSteps n P = Some P' /\ fullSimulation P' Q baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart PNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepLeftN H] P' H'.
  inversion H'.
  - subst.
    unfold runNSteps, ret, bind in HStepLeftN.
    destruct (Nat.eqb n 0) eqn:H_eqb_n_0.
    + Search Nat.eqb.
      apply EqNat.beq_nat_true in H_eqb_n_0.
      rewrite H_eqb_n_0 in HStepLeftN.
      injection HStepLeftN as HInj.
      subst.
      apply H.
      assumption.
    + apply EqNat.beq_nat_false in H_eqb_n_0.
      assert (HAux: exists n', n = S n'). {
        exists (Nat.pred n).
        Search Nat.pred.
        symmetry.
        apply PeanoNat.Nat.succ_pred.
        assumption.
      }
      destruct HAux.
      rewrite H1 in HStepLeftN.
      simpl in HStepLeftN.
      unfold bind in HStepLeftN.
      rewrite H0 in HStepLeftN.
      inversion HStepLeftN.
  - subst. destruct H0.
    generalize dependent PStart.
    generalize dependent QStart.
    generalize dependent PNext.
    generalize dependent P'.
    generalize dependent P'0.
    induction n; intros.
    + unfold runNSteps, ret, bind in HStepLeftN.
      injection HStepLeftN as HInj.
      subst.
      apply H.
      assumption.
    + unfold runNSteps, ret, bind in HStepLeftN.
      rewrite H0 in HStepLeftN.
      inversion H1.
      * subst.
        destruct (Nat.eqb n 0) eqn:H_eqb_n_0.
        -- apply EqNat.beq_nat_true in H_eqb_n_0.
           rewrite H_eqb_n_0 in HStepLeftN.
           injection HStepLeftN as HInj.
           subst.
           apply H.
           assumption.
        -- apply EqNat.beq_nat_false in H_eqb_n_0.
           assert (HAux: exists n', n = S n'). {
            exists (Nat.pred n).
            Search Nat.pred.
            symmetry.
            apply PeanoNat.Nat.succ_pred.
            assumption.
           }
           destruct HAux.
           rewrite H3 in HStepLeftN.
           rewrite H2 in HStepLeftN.
           inversion HStepLeftN.
       * subst.
         destruct H2.
         specialize (IHn P'1).
         specialize (IHn P').
         specialize (IHn H3).
         specialize (IHn PNext).
         specialize (IHn QStart).
         specialize (IHn H).
         specialize (IHn P'0).
         specialize (IHn HStepLeftN).
         specialize (IHn H1).
         specialize (IHn H2).
         apply IHn.
Qed.

Lemma stepRightN (n:nat): forall P Q Q' baseCaseSet,
  runNSteps n Q = Some Q' /\ fullSimulation P Q' baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart QNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepRightN H] P' H'.
  generalize dependent PStart.
  generalize dependent QStart.
  generalize dependent QNext.
  generalize dependent P'.
  induction n; intros.
  - unfold runNSteps, ret, bind in HStepRightN.
    injection HStepRightN as HInj.
    subst.
    apply H.
    assumption.
  - assert (H'': exists Q' : cfg, isCompletePath_R QNext Q' /\ baseCaseSet P' Q'). {
      apply H.
      apply H'.
    }
    destruct H'', H0.
    unfold runNSteps, bind in HStepRightN.
    destruct (runStep QStart) eqn:H_step_QStart.
    + specialize (IHn P').
      specialize (IHn QNext).
      specialize (IHn c).
      specialize (IHn HStepRightN).
      specialize (IHn PStart).
      specialize (IHn H).
      specialize (IHn H').
      destruct IHn.
      destruct H2.
      exists x0.
      split.
      * eapply CPR_IndCase.
        split.
        -- apply H_step_QStart.
        -- apply H2.
      * apply H3.
    + inversion HStepRightN.
Qed.

Ltac stepLN n :=
  eapply (stepLeftN n); split;
  [reflexivity | unfold find, update, id_eqb];
  simpl.
Ltac stepRN n :=
  eapply (stepRightN n); split;
  [reflexivity | unfold find, update, id_eqb];
  simpl.

Ltac stepLNRM n m :=
  stepLN n; stepRN m.
Ltac stepLRN n :=
  stepLNRM n n.

Ltac stepL :=
  stepLN 1.
Ltac stepR :=
  stepRN 1.
Ltac stepLR :=
  stepLRN 1.

Ltac stepLUntilDone :=
  repeat stepL.
Ltac stepRUntilDone :=
  repeat stepR.
Ltac stepLRUntilDone :=
  stepLUntilDone; stepRUntilDone.

Ltac destLinIneq_native eqName :=
  match goal with
  | [ |- context[Nat.ltb ?x ?y] ] =>
      destruct (Nat.ltb x y) eqn:eqName;
       [(* - *)
        apply PeanoNat.Nat.ltb_lt in eqName;
        try (
         assert (~ x < y) by lia;
         contradiction
        ) |
        (* - *)
        apply PeanoNat.Nat.ltb_ge in eqName;
        try (
          assert (~ y <= x) by lia;
          contradiction
        )]
  | [ |- context[Nat.eqb ?x ?y] ] =>
      destruct (Nat.eqb x y) eqn:eqName;
      [(* - *)
       apply PeanoNat.Nat.eqb_eq in eqName;
       try (
        assert (~ x = y) by lia;
        contradiction
       ) |
       (* - *)
       apply PeanoNat.Nat.eqb_neq in eqName;
       try (
        assert (~ x <> y) by lia;
        contradiction
       )]
  end.

Tactic Notation "destLinIneq" :=
  let H := fresh in destLinIneq_native H.
Tactic Notation "destLinIneq" simple_intropattern(eqName) :=
  destLinIneq_native eqName.

Ltac destAndClearLinIneq_native eqName :=
  destLinIneq eqName; clear eqName.

Tactic Notation "destAndClearLinIneq" :=
  let H := fresh in destAndClearLinIneq_native H.
Tactic Notation "destAndClearLinIneq" simple_intropattern(eqName) :=
  destAndClearLinIneq_native eqName.

Ltac stepLUntilAfterIte :=
  stepLUntilDone;
  repeat destAndClearLinIneq;
  stepL.
Ltac stepRUntilAfterIte :=
  stepRUntilDone;
  repeat destAndClearLinIneq;
  stepR.
Ltac stepLRUntilAfterIte :=
  stepLUntilAfterIte;
  stepRUntilAfterIte.

Ltac fullSim base_case_set :=
  repeat (
    stepLRUntilDone;
    repeat destAndClearLinIneq);
  unfold fullSimulation;
  intros P' H_CPR;
  (exists P'; split;
     [(* - *)
      inversion H_CPR as [| config config' config'' contra];
       [(* + *)
        apply CPR_BaseCase; compute; reflexivity |
        (* + *)
        destruct contra as [contra]; inversion contra
       ] |
      (* - *)
      unfold base_case_set;
      inversion H_CPR as [| config config' config'' contra];
       [(* + *)
        unfold find; simpl; try (congruence || reflexivity) |
        (* + *)
        destruct contra as [contra]; inversion contra
       ]
     ]
  ) ||
  (eexists; split; simpl;
    [(* - *)
     inversion H_CPR as [| config config' config'' contra];
      [(* + *)
       apply CPR_BaseCase; compute; reflexivity |
       (* + *)
       destruct contra as [contra]; inversion contra
      ] |
     (* - *)
     unfold base_case_set;
     inversion H_CPR as [| config config' config'' contra];
      [(* + *)
       unfold find; simpl; try (congruence || reflexivity) |
       (* + *)
       destruct contra as [contra]; inversion contra
      ]
    ]
  ).


From elpi Require Import elpi.
From HB Require Import structures.
From mathcomp Require Import all_ssreflect.

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

(**
#
#
** Recap of lesson 1

 Proof language
   - [move=>] [name] [/view] [//] [/=] [[..|..]] to name/change the goal
   - [: name], [: (lem arg)]
   - [rewrite lem -lem]
   - [apply: lem]
   - [apply/view]
 Library
   - naming convention: [addnC], [eqP], [orbN], [orNb], ...
   - notations: [.+1], [if-is-then-else]
   - [Search (_ + _) inside ssrnat]
   - [Search addn "C" inside ssrnat]
   - Use the HTML doc!
 Approach
   - boolean predicates
   - [reflect P b] to link [bool] with [Prop]

#
#
--------------------------------------------------------
#
#
** Today
   - the SSReflect proof language (part 2)
     - stack model and views
     - [rewrite] idioms and patterns
     - forward reasoning with [have]
   - spec lemmas
     - [reflect]
     - [fooP]
     - idioms

#
#
--------------------------------------------------------

#
#
*** Bookkeeping 101
   - the goal is a stack
   - defective case/elim (the _top_ implicit tactic argument)
   - tactical [=>] for post processing
   - tactical [:] for pre processing
   - "rename", "reorder"
#
#
*)
Lemma negb_and :
  forall b c, ~~ (b && c) = ~~ b || ~~ c.
Proof.
(*
move=> b. move=> c. move: b. move: c. (* up and down *)
move=> c b. move: b c.  (* reverse order, it's a stack *)
move=> b; case: b. move=> c; case: c. (* no need to name _top_, it's the default subject *)
*)
by case; case. Qed.

(**
#
#

#
(notes)
#
We say that the goal (under the horizontal bar) is a stack, since
items can only be accessed accorrding to a stack discipline.
If the goal is [forall x y, x = 1 + 2 * y -> odd x] one has to
deal with [x] and [y] before accessing [x = 1 + 2 * y].
#

#

#
#
--------------------------------------------------------

#
#
*** Induction
  - [elim] with generalization
  - [in x *] alternative
  - [rewrite (lem args)] to specialize a lemma
#
#
*)
Lemma induction_fold (l : seq nat) x :
  foldl addn x l = x + foldl addn 0 l.
Proof.
(*#
elim: l => [|y ys IH] /=. (* first attempt *)
  by rewrite addn0.
(* we are stuck *)
#*)
elim: l x => [|y ys IH] x /=. (* better attempt, generalize and re-introduce x *)
  by rewrite addn0.
by rewrite IH (IH y) addnA. (* IH is now quantified *)
Qed.

(**
#
#

#
(notes)
#
Recall that [elim] (or [case]) actually operate on
the top of the stack, which is the last item generalized
by [:].
#

#

#
#

------------------------------------------------------------
#
#
** Views are just lemmas (plus some automatic adaptors)
   - lemmas like [A -> B] can be used as views too
   - boolean connectives have associated views ("P" suffix)

#
#
*)

Lemma test_leqW i j k :
  (i <= k) && (k.+1 <= j) -> i <= j.+1.
Proof.
(*# move=> /andP H; case: H. move=> /leqW leq_ik1. #*)
move=> /andP[/leqW leq_ik1 /leqW leq_k1j1]. (* process fully, then name *)
by apply: leq_trans leq_ik1 leq_k1j1.
Qed.

(**
#
#

#
(notes)
#
There is nothin special with the [/andP[H1 H2]] we did
in lesson 1, it is just the composition of [/view]
followed by a case split [[]] (in this case only one branch)
#

#

#
#

--------------------------------------
#
#
** [rewrite], one command to rule them all
  - 1/3 of the lines of Math Comp proofs are [rewrite]
  - side conditions handling via [//] and [?]
  - rewrite a boolean predicate ([is_true] hides an eqaution)
#
#
*)

Lemma test_leq_cond p : prime p -> p.-1.+1 + p = p.*2.
Proof.
(*#
move=> pr_p.
Search predn inside ssrnat.
rewrite prednK. (* main step *)
  by rewrite addnn. (* side condition *)
Search prime leq 0.
by apply: prime_gt0. (* conclusion *)
#*)
(* idiomatic use of conditional rewrite rules *)
by move=> pr_p; rewrite prednK ?addnn // prime_gt0.
Qed.

(**
#
#

#
#

--------------------------------------------------------
#
#
** [rewrite] and subterm selection
   - keyed matching drives the search
   - specialization via argument passing
   - specialization via pattern
   - localization via contextual pattern (approximate or precise)
   - LHS and RHS notations
#
#*)
Lemma subterm_selection n m :
  n + (m * 2).+1 = n * (m + m.+1).
Proof.
rewrite addnC.
rewrite (addnC m).
rewrite [_ + m]addnC.
rewrite [in n * _]addnC.
rewrite [X in _ = _ * X]addnC.
rewrite [in RHS]addnC.
Abort.

Lemma occurrence_selection n m :
  n + m = n + m.
Proof.
rewrite addnC. (* all occurrecens of the rule are replaced *)
rewrite [in RHS]addnC. (* limit to RHS of the goal *)
Abort.

Lemma no_pattern_from_the_rewrite_rule n : n + 0 = n.
Proof.
rewrite -[n in RHS]addn0. (* precise patterns for ambiguous rules *)
Abort.

(**
#
#

#
(notes)
#
The details can be found in the reference #manual#
or in the #paper#
#

#

#
#

------------------------------------------------------------
------------------------------------------------------------
#
#
** The reflect predicate
   - [reflect P b] is the preferred way to state that
     the predicate [P] (in [Prop]) is logically equivalent
     to [b = true]

#
#
*)
Module reflect_for_eqP.

Print reflect.

(* we use this boolean predicate in the examples below *)
Fixpoint eqn m n :=
  match m, n with
  | 0, 0 => true
  | j.+1,k.+1 => eqn j k
  | _, _ => false
  end.
Arguments eqn !m !n.

(**
#
#

#
#
----------------------------------------------------------
#
#
** Proving the reflection lemma for [eqn]
    - the convenience lemma [iffP]
    - the [congr] tactic
    - trivial branches [=> //]
    - rewrite on the fly [->]
    - [first by]
    - [congr]
#
#
*)
Lemma myeqP m n : reflect (m = n) (eqn m n).
Proof.
(*#
apply: (iffP idP) => [|->]; last by elim: n.
elim: m n; first by case.
move=> n IHn m eq_n1m.
case: m eq_n1m => // m eq_n1m1. (* case with generalization *)
congr (_.+1). (* cleanup of the goal *)
by apply: IHn.
#*)
apply: (iffP idP) => [|->]; last by elim: n.
by elim: m n => [|m IHm] // [|n] // /IHm->.
Qed.

Lemma test_myeqP n m : (eqn n m) -> m = n.
Proof. by move=> /myeqP ->. Qed.

End reflect_for_eqP.

(**
#
#

#
#

--------------------------------------------------------
#
#
** Spec lemmas
   - Inductive predicates to drive the proof:
     - you chose how many branches
     - you chose which equations are automatically applied
     - you chose which extra assumption a branch has
   - [of] syntax for inductives
#
#*)

Inductive leq_xor_gtn m n : bool -> bool -> Prop :=
  | LeqNotGtn of m <= n : leq_xor_gtn m n true false
  | GtnNotLeq of n < m  : leq_xor_gtn m n false true.

Axiom leqP : forall m n : nat, leq_xor_gtn m n (m <= n) (n < m).

(**
#
#

#
#
--------------------------------------------------------
#
#
** Let's try out [leqP] on an ugly goal
   - matching of indexes uses the same discipline of [rewrite]

   Bonus (time permitting):
   - generalization of unresolved implicits after [/leq_trans]
   - specialization of the top stack item via [/(_ arg)]
#
#*)
Lemma test_leqP m n1 n2 :
  (m <= (if n1 < n2 then n1 else n2)) =
  (m <= n1) && (m <= n2) && ((n1 < n2) || (n2 <= n1)).
Proof.
(* the indexes of [leqP] give rise to patterns, which are matched
   right to left. So the first one is [_ < _] which finds [n1 < n2]
   and replaces it with [false] in the first branch and [true] in the
   second. Then it is the turn of [n2 <= n1].

   use: Set Debug "ssreflect". for a slow motion *)
case: leqP => [leqn21 | /ltnW ltn12 ]; rewrite /= andbT.
  by rewrite andb_idl // => /leq_trans /(_ leqn21).
by rewrite andb_idr // => /leq_trans->.
Qed.

(**
#
#

#
(notes)
#
While I presonally find [/leq_trans] too clever and
likely unnecessary, it is used in the library, hence this slide
#

#

#
#
--------------------------------------------------------
#
#
** Another commodity: [ifP]
   - a spec lemma for if-then-else
   - handy with case, since matching spares you to write
     the expressions involved
   - remark how the goal is used as a work space
#
#*)
Lemma test_ifP n m : if n <= m then 0 <= m - n else m - n == 0.
Proof.
case: ifP => //.
(* MC idiom: don't introduce hyps if not necessary *)
by move=> /negbT; rewrite subn_eq0 leqNgt negbK=> /ltnW.
Qed.

(**
#
#
#
#
--------------------------------------------------------
--------------------------------------------------------
#
#
** Forward reasoning
   - [have : statement.]
   - [have := proof]
   - [have /view ... : .. := ..] and variations

Definition of all
<<
Fixpoint all a s := if s is x :: s' then a x && all a s' else true.
>>

Definition of count
<<
Fixpoint count a s := if s is x :: s' then a x + count s' else 0.
>>

A lemma linking the two concepts

#
#
*)
Lemma all_count (T : Type) (a : pred T) s :
  all a s = (count a s == size s).
Proof.
(* common start *)
elim: s => //= x s.

(* first try at using EM *)
have EM_a : a x || ~~ a x.
  by apply: orbN.
move: EM_a => /orP EM_a. case: EM_a => [-> | /negbTE-> ] //= _.

(*#
(* second try using views and have *)
have /orP[ ax | /negbTE n_ax ] : a x || ~~ a x by case: (a x).
  by rewrite ax.
rewrite n_ax /= => ?.
#*)

(*#
(* this is the best way of doing it *)
have [ax//|n_ax ?] := boolP (a x).
#*)

(* common conclusion *)
by rewrite add0n eqn_leq ltnNge count_size /= andbC.
Qed.

(**
#
#
#
#

--------------------------------------------------------
#
#
** References for this lesson:
  - SSReflect #manual#
  - documentation of the
       #library#
    - in particular #seq#

#
#
--------------------------------------------------------
#
#
** Demo (time permitting, or as an exercise)
   - you should be now able to read this proof

#
#*)

Lemma dvdn_fact m n : 0 < m <= n -> m %| n`!.
Proof.
case: m => //= m; elim: n => //= n IHn; rewrite ltnS leq_eqVlt.
by move=> /orP[ /eqP-> | /IHn]; [apply: dvdn_mulr | apply: dvdn_mull].
Qed.

Lemma prime_above m : {p | m < p & prime p}.
Proof.
(*# Check pdivP. #*)
have /pdivP[p pr_p p_dv_m1]: 1 < m`! + 1 by rewrite addn1 ltnS fact_gt0.
exists p => //; rewrite ltnNge; apply: contraL p_dv_m1 => p_le_m.
(*# Check dvdn_addr. #*)
by rewrite dvdn_addr ?dvdn_fact ?prime_gt0 // gtnNdvd ?prime_gt1.
Qed.

(**
#
#

#
(notes)
#
This proof is also explained in the
#Math Comp Book#
#

#

#
#
*)


(** Coq coding by choukh, May 2022 **)

From ZF Require Import Basic Hierarchy Universe.

(** 不同模型的集合间的∈-相似关系 **)
Section Bisimilarity.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.
Implicit Type R : 𝓜 → 𝓝 → Prop.

Local Definition ϵ左完全 R x a := ∀ y ∈ x, ∃ b ∈ a, R y b.
Local Definition ϵ右完全 R x a := ∀ b ∈ a, ∃ y ∈ x, R y b.

Inductive 相似 x a : Prop :=
  | bis_intro : ϵ左完全 相似 x a → ϵ右完全 相似 x a → 相似 x a.

End Bisimilarity.

Notation "x ≈ a" := (相似 x a) (at level 80) : zf_scope.
Notation "x ▷ a" := (ϵ左完全 相似 x a) (at level 80) : zf_scope.
Notation "x ◁ a" := (ϵ右完全 相似 x a) (at level 80) : zf_scope.

Definition 同构 (𝓜 𝓝 : ZF) := 左完全 (@相似 𝓜 𝓝) ∧ 右完全 (@相似 𝓜 𝓝).
Notation "𝓜 ≅ 𝓝" := (同构 𝓜 𝓝) (at level 80) : zf_scope.

Definition 定义域 {𝓜 𝓝 : ZF} (x : 𝓜) := ∃ a : 𝓝, x ≈ a.
Definition 值域 {𝓜 𝓝 : ZF} (a : 𝓝) := ∃ x : 𝓜, x ≈ a.
Notation 𝕯 := 定义域.
Notation 𝕹 := 值域.

(** 相似关系的对称性 **)
Section Symmetry.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.

Lemma 左嵌入 x a : x ≈ a → x ▷ a.
Proof. now intros []. Qed.

Lemma 右嵌入 x a : x ≈ a → x ◁ a.
Proof. now intros []. Qed.

Lemma 相似的对称性 x a : x ≈ a → a ≈ x.
Proof.
  pose proof (正则 x) as WF. revert a.
  induction WF as [x _ IH].
  intros a [l r]. split.
  - intros b ba. destruct (r b ba) as [y [yx yb]].
    exists y. split; auto.
  - intros y yx. destruct (l y yx) as [b [ba yb]].
    exists b. split; auto.
Qed.

Lemma 相似的函数性 : 函数性 (@相似 𝓜 𝓝).
Proof.
  intros x. induction (正则 x) as [x _ IH].
  intros a b [xa ax] [xb bx].
  apply 外延; intros c C.
  - destruct (ax c C) as [y [yx yc]].
    destruct (xb y yx) as [d [db yd]].
    rewrite (IH y yx c d); auto.
  - destruct (bx c C) as [y [yx yc]].
    destruct (xa y yx) as [d [db yd]].
    rewrite (IH y yx c d); auto.
Qed.

End Symmetry.

Section Symmetry_More.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.

Lemma 相似的单射性 : 单射性 (@相似 𝓜 𝓝).
Proof.
  intros x x' y yx%相似的对称性 yx'%相似的对称性. eapply 相似的函数性; eauto.
Qed.

Lemma 相似的完全性对称 : 右完全 (@相似 𝓜 𝓝) ↔ 左完全 (@相似 𝓝 𝓜).
Proof. split; intros H x; destruct (H x) as [a ax%相似的对称性]; eauto. Qed.

Lemma 嵌入的对称性 x a : x ▷ a ↔ a ◁ x.
Proof.
  split.
  - intros l y yx. destruct (l y yx) as [b [ba yb]].
    exists b. split; auto. now apply 相似的对称性.
  - intros r y yx. destruct (r y yx) as [b [ba yb]].
    exists b. split; auto. now apply 相似的对称性.
Qed.

Lemma 域对称 x : x ∈ₚ 𝕯 ↔ x ∈ₚ @𝕹 𝓝 𝓜.
Proof. split; intros [a xa]; exists a; now apply 相似的对称性. Qed.

Lemma 域集化对称 x : x =ₚ @𝕯 𝓜 𝓝 ↔ x =ₚ @𝕹 𝓝 𝓜.
Proof.
  split; intros sd; intros y; split; intros H.
  - apply 域对称, sd, H.
  - apply sd, 域对称, H.
  - apply 域对称, sd, H.
  - apply sd, 域对称, H.
Qed.

End Symmetry_More.

(** 相似关系保持结构 **)
Section StructurePreserving_Partial.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.

Lemma 相似保ϵ_偏 x y a b : x ≈ a → y ≈ b → y ∈ x → b ∈ a.
Proof.
  intros [xa _] yb yx.
  destruct (xa y yx) as [c [ca yc]].
  now rewrite (相似的函数性 yb yc).
Qed.

Lemma 嵌入保空 : 𝓜.(结构).(空) ▷ 𝓝.(结构).(空).
Proof. intros x H. zf. Qed.

Lemma 嵌入保并 x a : x ▷ a → ⋃ x ▷ ⋃ a.
Proof.
  intros H y [z [yz zx]]%并集.
  destruct (H z zx) as [b [ba [zb _]]].
  destruct (zb y yz) as [c [cb yc]].
  exists c. split; auto. apply 并集. now exists b.
Qed.

Lemma 嵌入保幂 x a : x ▷ a → 𝒫 x ▷ 𝒫 a.
Proof.
  intros xa y yx%幂集.
  set (a ∩ₚ (λ c, ∃ z ∈ y, z ≈ c)) as b.
  exists b. split. apply 幂集, 分离为子集. split.
  - intros z zy. destruct (xa z (yx z zy)) as [c [ca zc]].
    exists c. split; auto. apply 分离. split; eauto.
  - intros c cb. now apply 分离 in cb.
Qed.

Definition 关系嵌入 (R : 𝓜 → 𝓜 → Prop) : 𝓝 → 𝓝 → Prop :=
  λ a b, ∃ x y, x ≈ a ∧ y ≈ b ∧ R x y.
Notation "⌜ R ⌝" := (关系嵌入 R) (format "⌜ R ⌝").

Lemma 关系嵌入的函数性 R : 函数性 R → 函数性 ⌜R⌝.
Proof.
  intros FR a b c [x [y [xa [yb Rxy]]]] [x' [z [x'a [zc Rxz]]]].
  rewrite (相似的单射性 x'a xa) in Rxz.
  rewrite (FR x y z Rxy Rxz) in yb.
  apply (相似的函数性 yb zc).
Qed.

Lemma 左嵌入保替代 R x a : 函数性 R → R @ x ⊆ₚ 𝕯 → x ▷ a → R @ x ▷ ⌜R⌝ @ a.
Proof.
  intros FR dom xa y yR. destruct (dom y yR) as [b yb].
  exists b. split; auto. apply 替代. now apply 关系嵌入的函数性.
  apply 替代 in yR as [z [zx Rzy]]; auto.
  destruct (xa z zx) as [c [ca zc]].
  exists c. split; auto. now exists z, y.
Qed.

Fact 右嵌入保替代 R x a : 函数性 R → R @ x ⊆ₚ 𝕯 → x ◁ a → R @ x ◁ ⌜R⌝ @ a.
Proof.
  intros FR dom xa b br.
  apply 替代 in br as [c [ca [z [y [zc [yb Rzy]]]]]]. 2:now apply 关系嵌入的函数性.
  exists y. split; auto. apply 替代; auto. exists z. split; auto.
  destruct (xa c ca) as [z' [z'x z'c]]. now rewrite (相似的单射性 zc z'c).
Qed.

End StructurePreserving_Partial.

Section StructurePreserving.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.
Notation "⌜ R ⌝" := (关系嵌入 R) (format "⌜ R ⌝").

Lemma 相似保ϵ x y a b : x ≈ a → y ≈ b → (y ∈ x ↔ b ∈ a).
Proof.
  intros xa yb. split; intros H.
  - now apply (相似保ϵ_偏 xa yb).
  - now apply (相似保ϵ_偏 (相似的对称性 xa) (相似的对称性 yb)).
Qed.

Lemma 相似保空 : 𝓜.(结构).(空) ≈ 𝓝.(结构).(空).
Proof.
  split.
  - apply 嵌入保空.
  - now apply 嵌入的对称性, 嵌入保空.
Qed.

Lemma 相似保并 x a : x ≈ a → ⋃ x ≈ ⋃ a.
Proof.
  intros [xa ax]. split.
  - now apply 嵌入保并.
  - now apply 嵌入的对称性, 嵌入保并, 嵌入的对称性.
Qed.

Lemma 相似保幂 x a : x ≈ a → 𝒫 x ≈ 𝒫 a.
Proof.
  intros [xa ax]. split.
  - now apply 嵌入保幂.
  - now apply 嵌入的对称性, 嵌入保幂, 嵌入的对称性.
Qed.

Lemma 相似保替代 R x a : 函数性 R → R @ x ⊆ₚ 𝕯 → x ≈ a → R @ x ≈ ⌜R⌝ @ a.
Proof.
  intros FR dom xa. split.
  - now apply 左嵌入保替代, xa.
  - now apply 右嵌入保替代, xa.
Qed.

Lemma 相似保层 x a : x ≈ a → x ∈ₚ 层 → a ∈ₚ 层.
Proof.
  intros xa xS. revert a xa.
  induction xS as [x xS IH|x xS IH].
  - intros b pxb. assert (xpx: x ∈ 𝒫 x). apply 幂集. zf.
    destruct (左嵌入 pxb xpx) as [a [ab xa]].
    assert (bis: 𝒫 x ≈ 𝒫 a) by now apply 相似保幂.
    rewrite <- (相似的函数性 bis pxb). constructor. now apply IH.
  - intros b uxb. assert (xppux: x ∈ 𝒫 𝒫 ⋃ x) by apply 幂集, 幂并.
    assert (bis: 𝒫 𝒫 ⋃ x ≈ 𝒫 𝒫 b) by now apply 相似保幂, 相似保幂.
    destruct (左嵌入 bis xppux) as [a [appb xa]]. apply 相似保并 in xa as uxua.
    rewrite <- (相似的函数性 uxua uxb). constructor. intros c ca.
    destruct (右嵌入 xa ca) as [y [yx yc]]. eapply IH; eauto.
Qed.

End StructurePreserving.

(** 相似关系的定义域 **)
Section Domain.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.
Notation 𝕯 := (@𝕯 𝓜 𝓝).
Notation "⌜ R ⌝" := (关系嵌入 R) (format "⌜ R ⌝").

(* 对成员关系封闭 *)
Lemma 定义域是传递类 : 传递类 𝕯.
Proof.
  intros x y xy [a xa].
  destruct (左嵌入 xa xy) as [b [_ yb]]. now exists b.
Qed.

(* 对子集关系封闭 *)
Lemma 定义域是膨胀类 : 膨胀类 𝕯.
Proof.
  intros x y xpy%幂集 [a xa%相似保幂].
  destruct (左嵌入 xa xpy) as [b [_ J]]. now exists b.
Qed.

Lemma 定义域是空集封闭类 : ∅ ∈ₚ 𝕯.
Proof. exists ∅. apply 相似保空. Qed.

Lemma 定义域是并集封闭类 x : x ∈ₚ 𝕯 → ⋃ x ∈ₚ 𝕯.
Proof. intros [a H%相似保并]. now exists (⋃ a). Qed.

Lemma 定义域是幂集封闭类 x : x ∈ₚ 𝕯 → 𝒫 x ∈ₚ 𝕯.
Proof. intros [a H%相似保幂]. now exists (𝒫 a). Qed.

Lemma 定义域是替代封闭类 R x : 函数性 R → R @ x ⊆ₚ 𝕯 → x ∈ₚ 𝕯 → R @ x ∈ₚ 𝕯.
Proof.
  intros FR dom [a H%(相似保替代 FR dom)]. now exists (⌜R⌝ @ a).
Qed.

Lemma 定义域是封闭类 : 封闭类 𝕯.
Proof.
  split.
  - intros x y yx xD. eapply 定义域是传递类; eauto.
  - apply 定义域是空集封闭类.
  - intros x xu. now apply 定义域是并集封闭类.
  - intros x xu. now apply 定义域是幂集封闭类.
  - intros R x FR yD xD. apply 定义域是替代封闭类; auto.
    intros y [z [zx Rzy]]%替代; auto. eapply yD; eauto.
Qed.

Lemma 集化定义域是宇宙 u : u =ₚ 𝕯 → 宇宙 u.
Proof. intros. exists 𝕯. split; auto. apply 定义域是封闭类. Qed.

Lemma 集化值域是宇宙 u : u =ₚ @𝕹 𝓝 𝓜 → 宇宙 u.
Proof. intros. rewrite <- 域集化对称 in H. apply 集化定义域是宇宙, H. Qed.

End Domain.

(** 相似关系与宇宙 **)
Section Universe.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.

Lemma 相似保传递 x a : x ≈ a → 传递 x → 传递 a.
Proof.
  intros xa xT b c cb ba.
  destruct (右嵌入 xa ba) as [y [yx yb]].
  destruct (右嵌入 yb cb) as [z [zy zc]].
  eapply (@相似保ϵ 𝓜 𝓝); eauto.
Qed.

Lemma 相似保空集封闭 x a : x ≈ a → 空集封闭 x → 空集封闭 a.
Proof. intros xa xU. now apply (相似保ϵ xa 相似保空). Qed.

Lemma 相似保并集封闭 x a : x ≈ a → 并集封闭 x → 并集封闭 a.
Proof.
  intros xa CL b ba. destruct (右嵌入 xa ba) as [y [yx yb]].
  apply 相似保并 in yb. now apply (相似保ϵ xa yb), CL.
Qed.

Lemma 相似保幂集封闭 x a : x ≈ a → 幂集封闭 x → 幂集封闭 a.
Proof.
  intros xa CL b ba. destruct (右嵌入 xa ba) as [y [yx yb]].
  apply 相似保幂 in yb. now apply (相似保ϵ xa yb), CL.
Qed.

Lemma 相似保替代封闭 x a : x ≈ a → 替代封闭 x → 替代封闭 a.
Proof.
  intros xa CL R b FR H ba. destruct (右嵌入 xa ba) as [y [yx yb]].
  apply 相似的对称性 in xa. apply 相似的对称性, (相似保替代 FR) in yb as bis.
  - apply (相似保ϵ xa bis), CL; auto. now apply 关系嵌入的函数性.
    intros z z' [c [c' [cz [c'z' Rcc']]]] zy. apply (相似保ϵ xa c'z').
    apply (H c); auto. now apply (相似保ϵ yb cz).
  - intros c [d [db Rdc]]%替代; auto. apply 定义域是传递类 with a.
    now apply (H d). now exists x.
Qed.

Lemma 相似保宇宙 x a : x ≈ a → 宇宙 x → 宇宙 a.
Proof.
  intros xa xU. exists (λ b, b ∈ a). split. 2:easy. split.
  - now apply 宇宙传递, (相似保传递 xa) in xU.
  - now apply 宇宙对空集封闭, (相似保空集封闭 xa) in xU.
  - now apply 宇宙对并集封闭, (相似保并集封闭 xa) in xU.
  - now apply 宇宙对幂集封闭, (相似保幂集封闭 xa) in xU.
  - now apply 宇宙对替代封闭, (相似保替代封闭 xa) in xU.
Qed.

Lemma 相似保宇宙等级 n x a : x ≈ a → 等级 n x → 等级 n a.
Proof.
  revert x a. induction n; simpl. auto.
  intros x a xa [y [yx [yU zfn]]].
  destruct (左嵌入 xa yx) as [b [ba yb]].
  exists b. split; auto. split.
  now apply (相似保宇宙 yb). now apply (IHn y).
Qed.

End Universe.

(** 相似关系与层 **)
Section Hierarchy.
Context {𝓜 𝓝 : ZF}.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.
Arguments 相似 : clear implicits.

(* 定义域外的最低层可嵌入到值域外的任意层 *)
Lemma 外层嵌入 x a :
  x ∈ₚ 最小 (λ x, x ∈ₚ 层 ∧ x ∉ₚ @𝕯 𝓜 𝓝) →
  a ∈ₚ 层 → a ∉ₚ @𝕯 𝓝 𝓜 → x ▷ a.
Proof.
  intros [[xS xD] min] aS aR.
  induction xS as [x xS IH|x xS IH].
  - exfalso. 排中 (x ∈ₚ 𝕯).
    + now apply xD, 定义域是幂集封闭类.
    + now apply 幂集在上 with x, min.
  - destruct (层之集二分 xS) as [suc|lim]. apply IH; auto.
    intros y [z [yz zx]]%并集. 排中 (z ∈ₚ 𝕯) as [[c zc]|].
    + assert (cS : c ∈ₚ 层). apply 相似保层 with z; auto.
      destruct (层线序 aS cS) as [ac|ca].
      * exfalso. apply aR, 定义域是膨胀类 with c.
        apply ac. exists z. now apply 相似的对称性.
      * destruct (左嵌入 zc yz) as [b [ba yb]].
        exists b. split; auto. eapply 层传递; eauto.
    + exfalso. apply 无循环1 with z. apply min; auto.
Qed.

Lemma 存在外层 : ¬ 左完全 (相似 𝓜 𝓝) → ∃ x ∈ₚ 层, x ∉ₚ 𝕯.
Proof.
  intros H. 反证. apply H.
  intros y. 反证. apply 反设.
  destruct (全可及 y) as [z [yz zS]].
  exists z. split; auto. intros [a za].
  destruct (左嵌入 za yz) as [b [ba yb]].
  apply 反设0. now exists b.
Qed.

Lemma 外层包含定义域 x : 左完全 (相似 𝓝 𝓜) → x ∈ₚ 层 → x ∉ₚ 𝕯 → 𝕯 ⊆ₛ x.
Proof.
  intros sur xS ndx y [a ya].
  destruct (全可及 a) as [b [ab bS]].
  destruct (sur b) as [z bz].
  assert (zS : z ∈ₚ 层). eapply 相似保层; eauto. apply 相似的对称性 in bz.
  assert (yz : y ∈ z). eapply 相似保ϵ; eauto.
  destruct (层线序 zS xS); auto. contradict ndx.
  apply 定义域是传递类 with z; auto. now exists b.
Qed.

Lemma 定义域集化 : ¬ 左完全 (相似 𝓜 𝓝) → 左完全 (相似 𝓝 𝓜) → setLike (@𝕯 𝓜 𝓝).
Proof.
  intros H1 H2. apply 存在外层 in H1 as [x [xS ndx]].
  apply 集的子类可集化 with x, 外层包含定义域; auto.
Qed.

Lemma 值域域集化 : ¬ 左完全 (相似 𝓜 𝓝) → 左完全 (相似 𝓝 𝓜) → setLike (@𝕹 𝓝 𝓜).
Proof.
  intros H1 H2. pose proof (定义域集化 H1 H2) as [x s].
  rewrite 域集化对称 in s. now exists x.
Qed.

End Hierarchy.

(** 相似的完全性 **)
Section Totality.
Variable 𝓜 𝓝 : ZF.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.
Arguments 𝕯 : clear implicits.
Arguments 𝕹 : clear implicits.
Arguments 相似 : clear implicits.

(* 定义域外的最低层与值域外的最低层相似 *)
Lemma 外层相似 x a :
  x ∈ₚ 最小 (λ x, x ∈ₚ 层 ∧ x ∉ₚ 𝕯 𝓜 𝓝) →
  a ∈ₚ 最小 (λ a, a ∈ₚ 层 ∧ a ∉ₚ 𝕯 𝓝 𝓜) → x ≈ a.
Proof.
  intros H1 H2. split.
  - apply 外层嵌入. apply H1. apply H2. apply H2.
  - apply 嵌入的对称性, 外层嵌入. apply H2. apply H1. apply H1.
Qed.

Lemma 相似对层的完全性 : 层 ⊑ 𝕯 𝓜 𝓝 ∨ 层 ⊑ 𝕯 𝓝 𝓜.
Proof.
  反证. apply not_or_and in 反设 as [H1 H2].
  apply 非子类 in H1 as [x [xS ndx]].
  apply 非子类 in H2 as [a [aS nda]].
  destruct (层良基 (P:=(λ x, x ∉ₚ 𝕯 𝓜 𝓝)) (conj xS ndx)) as [y my].
  destruct (层良基 (P:=(λ a, a ∉ₚ 𝕯 𝓝 𝓜)) (conj aS nda)) as [b mb].
  apply my. exists b. now apply 外层相似.
Qed.

Theorem 相似的完全性 : 左完全 (相似 𝓜 𝓝) ∨ 右完全 (相似 𝓜 𝓝).
Proof.
  反证. apply not_or_and in 反设 as [H1 H2].
  rewrite 相似的完全性对称 in H2.
  apply 存在外层 in H1 as [x [xS ndx]].
  apply 存在外层 in H2 as [a [aS nda]].
  destruct 相似对层的完全性; auto.
Qed.

Theorem 相似的完全性三歧 :
  (左完全 (相似 𝓜 𝓝) ∧ 右完全 (相似 𝓜 𝓝)) ∨
  (左完全 (相似 𝓜 𝓝) ∧ setLike (𝕹 𝓜 𝓝)) ∨
  (右完全 (相似 𝓜 𝓝) ∧ setLike (𝕯 𝓜 𝓝)).
Proof.
  排中 (左完全 (相似 𝓜 𝓝)) as [l|nl];
  排中 (右完全 (相似 𝓜 𝓝)) as [r|nr].
  - now left.
  - right. left. split. apply l.
    rewrite 相似的完全性对称 in nr.
    now apply 值域域集化.
  - right. right. split. apply r.
    rewrite 相似的完全性对称 in r.
    now apply 定义域集化.
  - destruct 相似的完全性; easy.
Qed.

End Totality.

(** 模型间嵌入 **)
Section Embedding.
Variable 𝓜 𝓝 : ZF.
Implicit Type x y : 𝓜.
Implicit Type a b : 𝓝.
Notation 𝕯 := (@𝕯 𝓜 𝓝).
Notation 𝕹 := (@𝕹 𝓜 𝓝).
Arguments 相似 : clear implicits.

Definition i x := δ (λ a, x ≈ a).
Definition j a := δ (λ x, x ≈ a).

Lemma i规范 x : x ∈ₚ 𝕯 → x ≈ i x.
Proof.
  intros [a xa]. unfold i. apply δ规范 with a; auto.
  intros b c xb xc. apply (相似的函数性 xb xc).
Qed.

Lemma j规范 a : a ∈ₚ 𝕹 → j a ≈ a.
Proof.
  intros [x xa]. unfold j. apply δ规范 with x; auto.
  intros y z ya za. apply (相似的单射性 ya za).
Qed.

Lemma ij a : a ∈ₚ 𝕹 → i (j a) = a.
Proof.
  intros aR. apply δ求值.
  - apply j规范, aR.
  - hnf. apply 相似的函数性.
Qed.

Lemma ji x : x ∈ₚ 𝕯 → j (i x) = x.
Proof.
  intros aR. apply δ求值.
  - apply i规范, aR.
  - hnf. intros. eapply 相似的单射性; eauto.
Qed.

Lemma j定义域 a : 右完全 (相似 𝓜 𝓝) → j a ∈ₚ 𝕯.
Proof. intros. exists a. apply j规范, H. Qed.

Lemma i值域 x : 左完全 (相似 𝓜 𝓝) → i x ∈ₚ 𝕹.
Proof. intros. exists x. apply i规范, H. Qed.

End Embedding.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition turbine2_bmap_list := [Build_varinfo Tdouble 1%positive (-45e-1) (-3e-1);Build_varinfo Tdouble 2%positive (4e-1) (9e-1);Build_varinfo Tdouble 3%positive (38e-1) (78e-1)].

Definition turbine2_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list turbine2_bmap_list) in exact z).

Definition turbine2 (v : ftype Tdouble) (w : ftype Tdouble) (r : ftype Tdouble) :=
  cast Tdouble (((((6)%F64 * v)%F64 - ((((5e-1)%F64 * v)%F64 * (((w * w)%F64 * r)%F64 * r)%F64)%F64 / ((1)%F64 - v)%F64)%F64)%F64 - (25e-1)%F64)%F64).

Definition turbine2_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) turbine2 in exact e').

Derive turbine2_b
SuchThat (forall vmap, prove_roundoff_bound turbine2_bmap vmap turbine2_expr turbine2_b)
As turbine2_bound.
Proof.
idtac "Starting turbine2".
time "turbine2" (
try (subst turbine2_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try prove_roundoff_bound2;
try error_rewrites;
try ((prune_terms (cutoff 70);
try match goal with |- (Rabs ?e <= ?a - 0)%R =>
  rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*)
end;
try match goal with |- (Rabs ?e <= ?a - ?b)%R =>
                      let G := fresh "G" in
                      interval_intro (Rabs e) as G ;
                      eapply Rle_trans;
                      [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end));
try rewrite Rsqr_pow2;
try field_simplify_Rabs;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with ( i_bisect vxH,
i_bisect v,
i_bisect v0, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect v,
i_bisect v0, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect v0, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect v, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect vxH, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) as H'; apply H'; apply Rle_refl
end).
Qed.

Lemma check_turbine2_bound: ltac:(CheckBound turbine2_b 1.2e-13%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import Reals.
Require Import List.
Require Import Flocq.Core.Core.
Require Export Gappa_library.

Strategy 1000 [Generic_fmt.round].

Module Gappa_Private.

(* factor an integer into odd*2^e *)
Definition float2_of_pos x :=
  let fix aux (m : positive) e { struct m } :=
    match m with
    | xO p => aux p (Z.succ e)
    | _ => Float2 (Zpos m) e
    end in
  aux x Z0.

Lemma float2_of_pos_correct :
  forall x, float2R (float2_of_pos x) = IZR (Zpos x).
Proof.
intros x.
unfold float2_of_pos.
rewrite <- (Rmult_1_r (IZR (Zpos x))).
change (IZR (Zpos x) * 1)%R with (float2R (Float2 (Zpos x) 0%Z)).
generalize 0%Z.
induction x ; intros e ; try apply refl_equal.
rewrite IHx.
unfold float2R.
simpl.
replace (Zpos (xO x)) with (Zpos x * 2)%Z.
exact (Gappa_round_aux.float2_shift_p1 _ _).
now rewrite Zmult_comm.
Qed.

Definition compact_float2 m e :=
  match m with
  | Z0 => Float2 0 0
  | Zpos p =>
    match float2_of_pos p with
    | Float2 m e1 => Float2 m (e + e1)
    end
  | Zneg p =>
    match float2_of_pos p with
    | Float2 m e1 => Float2 (-m) (e + e1)
    end
  end.

Lemma compact_float2_correct :
  forall m e, float2R (compact_float2 m e) = float2R (Float2 m e).
Proof.
unfold float2R, F2R. simpl.
intros [|m|m] e ; simpl.
now rewrite 2!Rmult_0_l.
rewrite <- (float2_of_pos_correct m).
destruct (float2_of_pos m) as (m1, e1).
simpl.
rewrite Zplus_comm.
now rewrite bpow_plus, <- Rmult_assoc.
change (IZR (Zneg m)) with (- IZR (Zpos m))%R.
rewrite <- (float2_of_pos_correct m).
destruct (float2_of_pos m) as (m1, e1).
simpl.
rewrite Zplus_comm.
rewrite bpow_plus, <- Rmult_assoc.
now rewrite opp_IZR, Ropp_mult_distr_l_reverse.
Qed.

Inductive UnaryOp : Set :=
  | uoNeg | uoSqrt | uoAbs | uoInv.

Register uoAbs as gappa.gappa_private.uoAbs.
Register uoNeg as gappa.gappa_private.uoNeg.
Register uoInv as gappa.gappa_private.uoInv.
Register uoSqrt as gappa.gappa_private.uoSqrt.

Inductive BinaryOp : Set :=
  | boAdd | boSub | boMul | boDiv.

Register boAdd as gappa.gappa_private.boAdd.
Register boSub as gappa.gappa_private.boSub.
Register boMul as gappa.gappa_private.boMul.
Register boDiv as gappa.gappa_private.boDiv.

Inductive Format : Set :=
  | fFixed : Z -> Format
  | fFloat : Z -> Z -> Format
  | fFloatx : Z -> Format.

Register fFloat as gappa.gappa_private.fFloat.
Register fFloatx as gappa.gappa_private.fFloatx.
Register fFixed as gappa.gappa_private.fFixed.

Inductive Mode : Set :=
  | mRndDN
  | mRndUP
  | mRndZR
  | mRndNE
  | mRndNA.

Register mRndDN as gappa.gappa_private.mRndDN.
Register mRndUP as gappa.gappa_private.mRndUP.
Register mRndZR as gappa.gappa_private.mRndZR.
Register mRndNE as gappa.gappa_private.mRndNE.
Register mRndNA as gappa.gappa_private.mRndNA.

(* represent an expression on real numbers *)
Inductive RExpr :=
  | reUnknown : positive -> RExpr
  | reInteger : Z -> RExpr
  | reFloat2 : Z -> Z -> RExpr
  | reFloat10 : Z -> Z -> RExpr
  | reUnary : UnaryOp -> RExpr -> RExpr
  | reBinary : BinaryOp -> RExpr -> RExpr -> RExpr
  | reBpow2 : Z -> RExpr
  | reBpow10 : Z -> RExpr
  | rePow2 : Z -> RExpr
  | rePow10 : Z -> RExpr
  | reINR : positive -> RExpr
  | reIZR : Z -> RExpr
  | reRound : Format -> Mode -> RExpr -> RExpr.

Register RExpr as gappa.gappa_private.RExpr.
Register reUnknown as gappa.gappa_private.reUnknown.
Register reInteger as gappa.gappa_private.reInteger.
Register reFloat2 as gappa.gappa_private.reFloat2.
Register reFloat10 as gappa.gappa_private.reFloat10.
Register reUnary as gappa.gappa_private.reUnary.
Register reBinary as gappa.gappa_private.reBinary.
Register reBpow2 as gappa.gappa_private.reBpow2.
Register reBpow10 as gappa.gappa_private.reBpow10.
Register rePow2 as gappa.gappa_private.rePow2.
Register rePow10 as gappa.gappa_private.rePow10.
Register reRound as gappa.gappa_private.reRound.

Scheme Equality for positive.
Scheme Equality for Z.
Scheme Equality for UnaryOp.
Scheme Equality for BinaryOp.
Scheme Equality for Format.
Scheme Equality for Mode.
Scheme Equality for RExpr.

(* represent an atomic proposition *)
Inductive RAtom :=
  | raBound : option RExpr -> RExpr -> option RExpr -> RAtom
  | raRel : RExpr -> RExpr -> RExpr -> RExpr -> RAtom
  | raLe : RExpr -> RExpr -> RAtom
  | raEq : RExpr -> RExpr -> RAtom
  | raGeneric : Format -> RExpr -> RAtom
  | raFormat : Format -> RExpr -> RAtom.

Register RAtom as gappa.gappa_private.RAtom.
Register raBound as gappa.gappa_private.raBound.
Register raRel as gappa.gappa_private.raRel.
Register raEq as gappa.gappa_private.raEq.
Register raLe as gappa.gappa_private.raLe.
Register raGeneric as gappa.gappa_private.raGeneric.
Register raFormat as gappa.gappa_private.raFormat.

Inductive RTree :=
  | rtTrue : RTree
  | rtFalse : RTree
  | rtAtom : RAtom -> RTree
  | rtNot : RTree -> RTree
  | rtAnd : RTree -> RTree -> RTree
  | rtOr : RTree -> RTree -> RTree
  | rtImpl : RTree -> RTree -> RTree.

Register RTree as gappa.gappa_private.RTree.
Register rtTrue as gappa.gappa_private.rtTrue.
Register rtFalse as gappa.gappa_private.rtFalse.
Register rtAtom as gappa.gappa_private.rtAtom.
Register rtNot as gappa.gappa_private.rtNot.
Register rtAnd as gappa.gappa_private.rtAnd.
Register rtOr as gappa.gappa_private.rtOr.
Register rtImpl as gappa.gappa_private.rtImpl.

Section Convert.

Definition convert_exp (f : Format) : Z -> Z :=
  match f with
  | fFloat e p => FLT_exp e p
  | fFloatx p => FLX_exp p
  | fFixed e => FIX_exp e
  end.

Definition convert_format (f : Format) : R -> Prop :=
  match f with
  | fFloat e p => FLT_format radix2 e p
  | fFloatx p => FLX_format radix2 p
  | fFixed e => FIX_format radix2 e
  end.

Definition convert_mode (m : Mode) : R -> Z :=
  match m with
  | mRndZR => Ztrunc
  | mRndDN => Zfloor
  | mRndUP => Zceil
  | mRndNE => rndNE
  | mRndNA => rndNA
  end.

Variable unknown_values : list R.

(* convert to an expression on real numbers *)
Fixpoint convert_expr (t : RExpr) : R :=
  match t with
  | reUnknown x =>
    nth (nat_of_P x) (R0 :: unknown_values) R0
  | reInteger x => IZR x
  | reFloat2 x y => float2R (Float2 x y)
  | reFloat10 x y => float10R (Float10 x y)
  | reUnary o x =>
    match o with
    | uoNeg  => Ropp
    | uoSqrt => sqrt
    | uoAbs  => Rabs
    | uoInv  => Rinv
    end (convert_expr x)
  | reBinary o x y =>
    match o with
    | boAdd => Rplus
    | boSub => Rminus
    | boMul => Rmult
    | boDiv => Rdiv
    end (convert_expr x) (convert_expr y)
  | reBpow2 x =>
    bpow radix2 x
  | reBpow10 x =>
    bpow radix10 x
  | rePow2 x =>
    powerRZ 2%R x
  | rePow10 x =>
    powerRZ 10%R x
  | reINR x =>
    INR (nat_of_P x)
  | reIZR x =>
    IZR x
  | reRound f m x =>
    Generic_fmt.round radix2 (convert_exp f) (convert_mode m) (convert_expr x)
  end.

(* convert to an atomic proposition *)
Definition convert_atom (a : RAtom) : Prop :=
  match a with
  | raBound None _ None => True
  | raBound (Some l) e None => (convert_expr l <= convert_expr e)%R
  | raBound None e (Some u) => (convert_expr e <= convert_expr u)%R
  | raBound (Some l) e (Some u) => (convert_expr l <= convert_expr e <= convert_expr u)%R
  | raRel er ex l u => exists eps : R, (convert_expr l <= eps <= convert_expr u)%R /\ (convert_expr er = convert_expr ex * (1 + eps))%R
  | raLe x y => (convert_expr x <= convert_expr y)%R
  | raEq x y => (convert_expr x = convert_expr y)%R
  | raGeneric f x => generic_format radix2 (convert_exp f) (convert_expr x)
  | raFormat f x => convert_format f (convert_expr x)
  end.

Fixpoint convert_tree (t : RTree) : Prop :=
  match t with
  | rtTrue => True
  | rtFalse => False
  | rtAtom a => convert_atom a
  | rtNot t => not (convert_tree t)
  | rtAnd t1 t2 => (convert_tree t1) /\ (convert_tree t2)
  | rtOr t1 t2 => (convert_tree t1) \/ (convert_tree t2)
  | rtImpl t1 t2 => (convert_tree t1) -> (convert_tree t2)
  end.

Register convert_tree as gappa.gappa_private.convert_tree.

Lemma decidable_atom :
  forall a, { convert_atom a } + { not (convert_atom a) }.
Proof with auto with typeclass_instances.
intros [[l|] e [u|]|x y l u|x y|x y|fmt x|fmt x] ; simpl.
destruct (Rle_lt_dec (convert_expr l) (convert_expr e)) as [Hl|Hl].
destruct (Rle_lt_dec (convert_expr e) (convert_expr u)) as [Hu|Hu].
now left ; split.
right.
intros (_,H).
now apply Rlt_not_le with (1 := Hu).
right.
intros (H,_).
now apply Rlt_not_le with (1 := Hl).
destruct (Rle_lt_dec (convert_expr l) (convert_expr e)) as [Hl|Hl].
now left.
right.
now apply Rlt_not_le.
destruct (Rle_lt_dec (convert_expr e) (convert_expr u)) as [Hu|Hu].
now left.
right.
now apply Rlt_not_le.
now left.
destruct (Req_EM_T (convert_expr y) 0) as [Zy|Zy].
destruct (Req_EM_T (convert_expr x) 0) as [Zx|Zx].
destruct (Rle_lt_dec (convert_expr l) (convert_expr u)) as [H|H].
left.
exists (convert_expr l).
split.
split.
apply Rle_refl.
exact H.
now rewrite Zy, Rmult_0_l.
right.
intros (eps,((H1,H2),_)).
apply Rlt_not_le with (1 := H).
now apply Rle_trans with eps.
right.
intros (eps,(_,H')).
now rewrite Zy, Rmult_0_l in H'.
destruct (Rle_lt_dec (convert_expr l) (convert_expr x / convert_expr y - 1)) as [Hl|Hl].
destruct (Rle_lt_dec (convert_expr x / convert_expr y - 1) (convert_expr u)) as [Hu|Hu].
left.
exists (convert_expr x / convert_expr y - 1)%R.
split.
now split.
now field.
right.
intros (eps,((_,H),H')).
apply Rlt_not_le with (1 := Hu).
rewrite H'.
now replace (convert_expr y * (1 + eps) / convert_expr y - 1)%R with eps ; [idtac | field].
right.
intros (eps,((H,_),H')).
apply Rlt_not_le with (1 := Hl).
rewrite H'.
now replace (convert_expr y * (1 + eps) / convert_expr y - 1)%R with eps ; [idtac | field].
destruct (Rle_lt_dec (convert_expr x) (convert_expr y)) as [H|H].
now left.
right.
now apply Rlt_not_le.
apply Req_EM_T.
apply Req_EM_T.
destruct fmt as [e|e p|p].
simpl.
destruct (Req_EM_T (convert_expr x) (round radix2 (FIX_exp e) rndZR (convert_expr x))) as [H|H].
left.
apply FIX_format_generic.
rewrite H.
apply generic_format_round...
right.
contradict H.
apply sym_eq, round_generic...
now apply generic_format_FIX.
destruct (Z_lt_le_dec 0 p) as [Hp|Hp].
destruct (Req_EM_T (convert_expr x) (round radix2 (FLT_exp e p) rndZR (convert_expr x))) as [H|H].
left.
apply FLT_format_generic.
apply Hp.
rewrite H.
apply generic_format_round...
right.
contradict H.
apply sym_eq, round_generic...
now apply generic_format_FLT.
destruct p.
destruct (Req_EM_T (convert_expr x) 0) as [H|H].
left.
rewrite H.
exists (Float radix2 0 e).
apply sym_eq, F2R_0.
apply eq_refl.
apply Z.le_refl.
right.
intros ((xm,xe),H1,H2,H3).
simpl in H2.
assert (xm = Z0).
clear -H2 ; zify ; omega.
now rewrite H0, F2R_0 in H1.
now elim Hp.
right.
intros ((xm,xe),H1,H2,H3).
apply Zlt_not_le with (1 := H2).
apply Zabs_pos.
destruct (Z_lt_le_dec 0 p) as [Hp|Hp].
destruct (Req_EM_T (convert_expr x) (round radix2 (FLX_exp p) rndZR (convert_expr x))) as [H|H].
left.
apply FLX_format_generic.
apply Hp.
rewrite H.
apply generic_format_round...
right.
contradict H.
apply sym_eq, round_generic...
now apply generic_format_FLX.
destruct p.
destruct (Req_EM_T (convert_expr x) 0) as [H|H].
left.
rewrite H.
exists (Float radix2 0 0).
apply sym_eq, F2R_0.
apply eq_refl.
right.
intros ((xm,xe),H1,H2).
simpl in H2.
assert (xm = Z0).
clear -H2 ; zify ; omega.
now rewrite H0, F2R_0 in H1.
now elim Hp.
right.
intros ((xm,xe),H1,H2).
apply Zlt_not_le with (1 := H2).
apply Zabs_pos.
Qed.

Lemma decidable_tree :
  forall t, { convert_tree t } + { not (convert_tree t) }.
Proof.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2].
now left.
now right.
apply decidable_atom.
destruct Ht as [Ht|Ht].
now right.
now left.
destruct Ht1 as [Ht1|Ht1].
destruct Ht2 as [Ht2|Ht2].
now left ; split.
right.
now intros (_,H).
right.
now intros (H,_).
destruct Ht1 as [Ht1|Ht1].
left.
now left.
destruct Ht2 as [Ht2|Ht2].
left.
now right.
right.
now intros [H|H].
destruct Ht2 as [Ht2|Ht2].
left.
now intros _.
destruct Ht1 as [Ht1|Ht1].
right.
contradict Ht2.
now apply Ht2.
left.
now intros H.
Qed.

Fixpoint normalize_tree (t : RTree) (pos : bool) :=
  match t with
  | rtTrue => if pos then rtTrue else rtFalse
  | rtFalse => if pos then rtFalse else rtTrue
  | rtAtom a => if pos then t else rtNot t
  | rtNot t => normalize_tree t (negb pos)
  | rtImpl t1 t2 => (if pos then rtOr else rtAnd) (normalize_tree t1 (negb pos)) (normalize_tree t2 pos)
  | rtOr t1 t2 => (if pos then rtOr else rtAnd) (normalize_tree t1 pos) (normalize_tree t2 pos)
  | rtAnd t1 t2 => (if pos then rtAnd else rtOr) (normalize_tree t1 pos) (normalize_tree t2 pos)
  end.

Theorem normalize_tree_correct :
  forall t pos,
  convert_tree (normalize_tree t pos) <-> if pos then convert_tree t else not (convert_tree t).
Proof.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ;
  destruct pos ; split ; simpl ; try easy.
try (intros H ; now apply H).
apply (Ht false).
apply (Ht false).
intros H.
intros H'.
apply H'.
now apply (Ht true).
intros H.
apply (Ht true).
now destruct (decidable_tree t) as [H'|H'].
intros (H1,H2).
split.
now apply (Ht1 true).
now apply (Ht2 true).
intros (H1,H2).
split.
now apply (Ht1 true).
now apply (Ht2 true).
intros [H|H] (H1,H2).
now apply (Ht1 false).
now apply (Ht2 false).
specialize (Ht1 false).
specialize (Ht2 false).
intros H.
destruct (decidable_tree t1) as [H'|H'].
right.
apply Ht2.
contradict H.
now split.
left.
now apply Ht1.
intros [H|H].
left.
now apply (Ht1 true).
right.
now apply (Ht2 true).
intros [H|H].
left.
now apply (Ht1 true).
right.
now apply (Ht2 true).
intros (H1,H2) [H|H].
now apply (Ht1 false).
now apply (Ht2 false).
intros H.
split.
apply (Ht1 false).
contradict H.
now left.
apply (Ht2 false).
contradict H.
now right.
intros [H|H] H'.
now apply (Ht1 false) in H.
now apply (Ht2 true).
intros H.
destruct (decidable_tree t1) as [H'|H'].
right.
apply (Ht2 true).
now apply H.
left.
now apply (Ht1 false).
intros (H1,H2) H'.
apply (Ht1 true) in H1.
apply H' in H1.
now apply (Ht2 false).
intros H.
split.
destruct (decidable_tree t1) as [H'|H'].
now apply (Ht1 true).
now elim H.
apply (Ht2 false).
now contradict H.
Qed.

Fixpoint simplify_tree (t : RTree) :=
  match t with
  | rtNot rtTrue => rtFalse
  | rtNot rtFalse => rtTrue
  | rtAnd t1 t2 =>
    match simplify_tree t1, simplify_tree t2 with
    | rtTrue, t => t
    | rtFalse, _ => rtFalse
    | t, rtTrue => t
    | _, rtFalse => rtFalse
    | t1, t2 => rtAnd t1 t2
    end
  | rtOr t1 t2 =>
    match simplify_tree t1, simplify_tree t2 with
    | rtTrue, _ => rtTrue
    | rtFalse, t => t
    | _, rtTrue => rtTrue
    | t, rtFalse => t
    | t1, t2 => rtOr t1 t2
    end
  | _ => t
  end.

Theorem simplify_tree_correct :
  forall t,
  convert_tree t -> convert_tree (simplify_tree t).
Proof.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; try easy.
destruct t ; try easy.
intros H.
now apply H.
intros (H1,H2).
specialize (Ht1 H1).
specialize (Ht2 H2).
simpl.
destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; split ; easy.
intros [H|H].
specialize (Ht1 H).
simpl.
destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; left ; easy.
specialize (Ht2 H).
simpl.
destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; right ; easy.
Qed.

Section StableExpr.

Definition stable_expr f :=
  forall t, convert_expr (f t) = convert_expr t.

Variable chg_expr : RExpr -> RExpr.

(* apply a function recursively, starting from the leafs of an expression *)
Fixpoint transform_expr (t : RExpr) :=
  chg_expr
    match t with
    | reUnary o x => reUnary o (transform_expr x)
    | reBinary o x y => reBinary o (transform_expr x) (transform_expr y)
    | reRound f m x => reRound f m (transform_expr x)
    | _ => t
    end.

Theorem transform_expr_correct :
  stable_expr chg_expr ->
  stable_expr transform_expr.
Proof.
unfold stable_expr.
intros Hf t.
induction t ; simpl ; rewrite Hf ; simpl ; try easy.
now rewrite IHt.
now rewrite IHt1, IHt2.
now rewrite IHt.
Qed.

End StableExpr.

Definition stable_atom f :=
  forall a, convert_atom (f a) <-> convert_atom a.

Definition transform_atom_bound f a :=
  match a with
  | raBound (Some l) e (Some u) => raBound (Some (f l)) e (Some (f u))
  | raBound (Some l) e None => raBound (Some (f l)) e None
  | raBound None e (Some u) => raBound None e (Some (f u))
  | raRel er ex l u => raRel er ex (f l) (f u)
  | _ => a
  end.

Theorem transform_atom_bound_correct :
  forall f,
  stable_expr f ->
  stable_atom (transform_atom_bound (transform_expr f)).
Proof.
now intros f Hf [[l|] e [u|]|x y l u|x y|x y|fmt x|fmt x] ;
  simpl ; split ; repeat rewrite (transform_expr_correct _ Hf).
Qed.

Definition transform_atom_expr f a :=
  match a with
  | raBound l e u => raBound l (f e) u
  | raRel er ex l u => raRel (f er) (f ex) l u
  | raEq ex ey => raEq (f ex) (f ey)
  | raLe ex ey => raLe (f ex) (f ey)
  | raGeneric fmt e => raGeneric fmt (f e)
  | raFormat fmt e => raFormat fmt (f e)
  end.

Theorem transform_atom_expr_correct :
  forall f,
  stable_expr f ->
  stable_atom (transform_atom_expr (transform_expr f)).
Proof.
now intros f Hf [l e u|x y l u|x y|x y|fmt x|fmt x] ;
  simpl ; split ; repeat rewrite (transform_expr_correct _ Hf).
Qed.

Definition stable_tree f :=
  forall t, convert_tree (f t) <-> convert_tree t.

Section StableTree.

Variable chg_atom : RAtom -> RAtom.

Fixpoint transform_tree_atom (t : RTree) : RTree :=
  match t with
  | rtTrue => rtTrue
  | rtFalse => rtFalse
  | rtAtom a => rtAtom (chg_atom a)
  | rtNot t => rtNot (transform_tree_atom t)
  | rtAnd t1 t2 => rtAnd (transform_tree_atom t1) (transform_tree_atom t2)
  | rtOr t1 t2 => rtOr (transform_tree_atom t1) (transform_tree_atom t2)
  | rtImpl t1 t2 => rtImpl (transform_tree_atom t1) (transform_tree_atom t2)
  end.

Theorem transform_tree_atom_correct :
  stable_atom chg_atom ->
  stable_tree transform_tree_atom.
Proof.
intros Hs t.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; simpl ; intuition.
now apply Hs.
now apply Hs.
Qed.

End StableTree.

Definition stable_atom_tree f :=
  forall a (pos : bool),
  (if pos then convert_atom a else not (convert_atom a)) ->
  convert_tree (f pos a).

Section StableTree'.

Variable chg_atom : bool -> RAtom -> RTree.

Fixpoint transform_tree_atom' (t : RTree) : RTree :=
  match t with
  | rtTrue => rtTrue
  | rtFalse => rtFalse
  | rtAtom a => chg_atom true a
  | rtNot (rtAtom a) => chg_atom false a
  | rtAnd t1 t2 => rtAnd (transform_tree_atom' t1) (transform_tree_atom' t2)
  | rtOr t1 t2 => rtOr (transform_tree_atom' t1) (transform_tree_atom' t2)
  | _ => t
  end.

Theorem transform_tree_atom'_correct :
  stable_atom_tree chg_atom ->
  forall t,
  convert_tree t -> convert_tree (transform_tree_atom' t).
Proof.
intros Hs t.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; simpl ; intuition.
destruct t ; intuition.
Qed.

End StableTree'.

(* transform INR and IZR into real integers, change a/b and a*2^b into floats *)
Definition gen_float_func t :=
  match t with
  | reUnary uoNeg (reInteger (Zpos x)) =>
    reInteger (Zneg x)
  | reBinary boDiv (reInteger x) (reInteger (Zpos y)) =>
    match float2_of_pos y with
    | Float2 1 (Zpos y') => reFloat2 x (Zneg y')
    | _ => t
    end
  | reBinary boMul (reInteger x) (reBpow2 y) =>
    reFloat2 x y
  | reBinary boMul (reInteger x) (reBpow10 y) =>
    reFloat10 x y
  | reBinary boMul (reInteger x) (rePow2 y) =>
    reFloat2 x y
  | reBinary boMul (reInteger x) (rePow10 y) =>
    reFloat10 x y
  | reINR x =>
    reInteger (Zpos x)
  | reIZR x =>
    reInteger x
  | _ => t
  end.

Lemma gen_float_prop :
  stable_expr gen_float_func.
Proof.
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal.
(* unary ops *)
destruct o ; try apply refl_equal.
destruct x ; try apply refl_equal.
destruct z ; apply refl_equal.
(* binary ops *)
destruct o ; try apply refl_equal ;
  destruct x ; try apply refl_equal ;
  destruct y ; try apply refl_equal.
(* . x * 2^y *)
simpl.
now rewrite <- (bpow_powerRZ radix2).
(* . x * 10^y *)
simpl.
now rewrite <- (bpow_powerRZ radix10).
(* . x / 2*2*2*2 *)
destruct z0 ; try apply refl_equal.
generalize (float2_of_pos_correct p).
simpl.
destruct (float2_of_pos p) as ([|[m|m|]|m], [|e|e]) ; intros H ; try apply refl_equal.
rewrite <- H.
unfold convert_expr.
unfold float2R, F2R at 2. simpl.
now rewrite Rmult_1_l.
(* INR *)
simpl.
rewrite <- positive_nat_Z.
apply sym_eq, INR_IZR_INZ.
Qed.

(* remove pending powerRZ *)
Definition clean_pow_func t :=
  match t with
  | reBpow2 x => reFloat2 1 x
  | reBpow10 x => reFloat10 1 x
  | rePow2 x => reFloat2 1 x
  | rePow10 x => reFloat10 1 x
  | _ => t
  end.

Lemma clean_pow_prop :
  stable_expr clean_pow_func.
Proof.
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal.
apply (F2R_bpow radix2 x).
apply (F2R_bpow radix10 x).
simpl.
unfold float2R.
rewrite F2R_bpow.
apply bpow_powerRZ.
simpl.
unfold float10R.
rewrite F2R_bpow.
apply bpow_powerRZ.
Qed.

(* compute on constant terms, so that they are hopefully represented by a single float *)
Definition merge_float2_aux m e :=
  match compact_float2 m e with
  | Float2 m1 e1 => reFloat2 m1 e1
  end.

Definition merge_float2_func t :=
  match t with
  | reInteger x => merge_float2_aux x 0
  | reUnary uoNeg (reFloat2 x y) => merge_float2_aux (- x) y
  | reBinary boMul (reFloat2 x1 y1) (reFloat2 x2 y2) => merge_float2_aux (x1 * x2) (y1 + y2)
  | reFloat2 x y => merge_float2_aux x y
  | _ => t
  end.

Lemma merge_float2_prop :
  stable_expr merge_float2_func.
Proof.
assert (forall m e, convert_expr (merge_float2_aux m e) = convert_expr (reFloat2 m e)).
intros.
unfold merge_float2_aux.
generalize (compact_float2_correct m e).
now destruct (compact_float2 m e).
(* . *)
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal ; try exact (H x _).
(* integer *)
simpl.
unfold merge_float2_aux.
generalize (compact_float2_correct x 0).
rewrite <- (Rmult_1_r (IZR x)).
now destruct (compact_float2 x 0).
(* unary ops *)
destruct o ; try apply refl_equal.
destruct x ; try apply refl_equal.
simpl.
rewrite H.
now rewrite <- Gappa_dyadic.Fopp2_correct.
(* binary ops *)
destruct o ; try apply refl_equal.
destruct x ; try apply refl_equal.
destruct y ; try apply refl_equal.
simpl.
rewrite H.
now rewrite <- Gappa_dyadic.Fmult2_correct.
Qed.

(* change /a into 1/a *)
Definition remove_inv_func t :=
  match t with
  | reUnary uoInv x => reBinary boDiv (reInteger 1) x
  | _ => t
  end.

Lemma remove_inv_prop :
  stable_expr remove_inv_func.
Proof.
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal.
destruct o ; try apply refl_equal.
exact (Rmult_1_l _).
Qed.

Definition get_float2_bound b := transform_expr merge_float2_func (transform_expr clean_pow_func
  (transform_expr gen_float_func (transform_expr remove_inv_func b))).

Lemma get_float2_bound_correct :
  stable_expr get_float2_bound.
Proof.
intros b.
unfold get_float2_bound.
rewrite (transform_expr_correct _ merge_float2_prop).
rewrite (transform_expr_correct _ clean_pow_prop).
rewrite (transform_expr_correct _ gen_float_prop).
now rewrite (transform_expr_correct _ remove_inv_prop).
Qed.

Definition change_abs_func a :=
  match a with
  | raLe (reUnary uoAbs u as u') v => raBound (Some (reFloat2 0 0)) u' (Some v)
  | _ => a
  end.

Lemma change_abs_prop :
  stable_atom change_abs_func.
Proof.
intros [l v u|x y l u|v w|v w|f x|f x] ; try easy.
destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy.
destruct o ; try easy.
split.
now intros (_,H).
split.
replace (convert_expr (reFloat2 0 0)) with R0.
apply Rabs_pos.
apply eq_sym, Rmult_0_l.
exact H.
Qed.

Definition change_le_func a :=
  match a with
  | raLe x y =>
    match get_float2_bound x with
    | reFloat2 _ _ as x => raBound (Some x) y None
    | _ =>
      match get_float2_bound y with
      | reFloat2 _ _ as y => raBound None x (Some y)
      | _ => a
      end
    end
  | _ => a
  end.

Lemma change_le_prop :
  stable_atom change_le_func.
Proof.
intros [l v u|x y l u|v w|v w|f x|f x] ; try easy.
simpl.
assert (Hv := get_float2_bound_correct v).
assert (Hw := get_float2_bound_correct w).
destruct (get_float2_bound v) as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ;
  destruct (get_float2_bound w) as [x'|x'|x' y'|x' y'|o' x'|o' x' y'|x'|x'|x'|x'|x'|x'|f' m' x'] ;
  try easy ; try (now rewrite <- Hw) ; now rewrite <- Hv.
Qed.

Lemma change_rel_aux:
  forall x y b, (0 <= b /\ Rabs (x - y) <= b * Rabs y)%R <-> (exists eps, -b <= eps <= b /\ x = y * (1 + eps))%R.
Proof.
intros x y b.
split.
(* . *)
intros (H1, H2).
destruct (Req_dec y 0) as [Hy|Hy].
exists 0%R.
repeat split.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
apply H1.
rewrite Hy, Rmult_0_l.
destruct (Req_dec x 0) as [Hx|Hx] ; try exact Hx.
elim Rabs_no_R0 with (1 := Hx).
apply Rle_antisym.
now rewrite Hy, Rminus_0_r, Rabs_R0, Rmult_0_r in H2.
apply Rabs_pos.
exists ((x - y) / y)%R.
split.
2: now field.
apply Rabs_def2b.
apply Rmult_le_reg_l with (Rabs y).
now apply Rabs_pos_lt.
rewrite <- Rabs_mult.
replace (y * ((x - y) / y))%R with (x - y)%R by now field.
now rewrite Rmult_comm.
(* . *)
intros (eps, (H1, H2)).
repeat split.
destruct (Rle_or_lt 0 b) as [H|H] ; try exact H.
apply Ropp_le_cancel.
apply Rle_trans with b.
now apply Rle_trans with eps.
apply Rlt_le.
now rewrite Ropp_0.
rewrite H2.
replace (y * (1 + eps) - y)%R with (eps * y)%R by ring.
rewrite Rabs_mult.
apply Rmult_le_compat_r.
apply Rabs_pos.
unfold Rabs.
destruct (Rcase_abs eps) as [H|H].
apply Ropp_le_cancel.
now rewrite Ropp_involutive.
apply H1.
Qed.

Definition change_rel_func a :=
  match a with
  | raLe (reUnary uoAbs (reBinary boSub er ex)) (reBinary boMul u (reUnary uoAbs ex')) =>
    if RExpr_beq ex ex' then
      match get_float2_bound u with
      | reFloat2 (Zpos m) e => raRel er ex (reFloat2 (Zneg m) e) (reFloat2 (Zpos m) e)
      | _ => a
      end
    else a
  | _ => a
  end.

Lemma change_rel_prop :
  stable_atom change_rel_func.
Proof.
unfold change_rel_func.
intros [l v u|x y l u|v w|v w|f x|f x] ; try easy.
destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy.
destruct o ; try easy.
destruct x as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy.
destruct o ; try easy.
destruct w as [u|u|u v|u v|o u|o u v|u|u|u|u|u|u|f m u] ; try easy.
destruct o ; try easy.
destruct v as [v|v|v w|v w|o v|o v w|v|v|v|v|v|v|f m v] ; try easy.
destruct o ; try easy.
case_eq (RExpr_beq y v) ; try easy.
intros Hb.
rewrite <- internal_RExpr_dec_bl with (1 := Hb).
assert (H := get_float2_bound_correct u).
destruct (get_float2_bound u) as [u1|u1|m e|u1 u2|o u1|o u1 u2|u1|u1|u1|u1|u1|u1|f u1] ; try easy.
destruct m as [|m|m] ; try easy.
simpl in H |- *.
change (Float2 (Zneg m) e) with (Gappa_dyadic.Fopp2 (Float2 (Zpos m) e)).
rewrite Gappa_dyadic.Fopp2_correct.
rewrite H.
split ; intro H'.
now apply <- change_rel_aux.
apply -> change_rel_aux.
split.
rewrite <- H.
now apply (Gappa_dyadic.Fpos0_correct (Float2 (Zpos m) e)).
exact H'.
Qed.

Definition change_format_func (pos : bool) a :=
  let a' :=
    match a with
    | raGeneric (fFixed _ as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raGeneric (fFloat _ (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raGeneric (fFloatx (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raFormat (fFixed _ as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raFormat (fFloat _ (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raFormat (fFloatx (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | _ => a
    end in
  if pos then rtAtom a' else rtNot (rtAtom a').

Lemma change_format_prop :
  stable_atom_tree change_format_func.
Proof.
unfold change_format_func.
intros [l v u|x y l u|v w|v w|[em|em [|p|p]|[|p|p]] x|[em|em [|p|p]|[|p|p]] x] pos ; try (case pos ; easy) ; simpl ; intros H.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
exact H.
contradict H.
rewrite <- H.
apply generic_format_round.
apply FIX_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
exact H.
contradict H.
rewrite <- H.
apply generic_format_round.
now apply FLT_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
exact H.
contradict H.
rewrite <- H.
apply generic_format_round.
now apply FLX_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
now apply generic_format_FIX.
contradict H.
rewrite <- H.
apply FIX_format_generic.
apply generic_format_round.
apply FIX_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
apply generic_format_FLT.
exact H.
contradict H.
rewrite <- H.
apply FLT_format_generic.
easy.
apply generic_format_round.
now apply FLT_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
apply generic_format_FLX.
exact H.
contradict H.
rewrite <- H.
apply FLX_format_generic.
easy.
apply generic_format_round.
now apply FLX_exp_valid.
apply valid_rnd_N.
Qed.

Definition remove_unknown_func (pos : bool) a :=
  match a with
  | raBound l _ u =>
    match l with
    | Some (reFloat2 _ _)
    | None =>
      match u with
      | Some (reFloat2 _ _)
      | None => if pos then rtAtom a else rtNot (rtAtom a)
      | _ => rtTrue
      end
    | _ => rtTrue
    end
  | raRel _ _ (reFloat2 _ _) (reFloat2 _ _) => if pos then rtAtom a else rtNot (rtAtom a)
  | raEq _ _ => if pos then rtAtom a else rtNot (rtAtom a)
  | _ => rtTrue
  end.

Lemma remove_unknown_prop :
  stable_atom_tree remove_unknown_func.
Proof.
intros [[l|] v [u|]|x y l u|v w|v w|f x|f x] pos ; try (case pos ; easy) ; simpl ; intros H.
destruct l as [xl|xl|xl yl|xl yl|ol xl|ol xl yl|xl|xl|xl|xl|xl|xl|fl xl] ; try easy.
destruct u as [xu|xu|xu yu|xu yu|ou xu|ou xu yu|xu|xu|xu|xu|xu|xu|fu xu] ; try easy.
now destruct pos.
destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy.
now destruct pos.
destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy.
now destruct pos.
destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy.
destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy.
now destruct pos.
Qed.

End Convert.

Inductive Transform :=
  | trAtom (f : RAtom -> RAtom) : (forall uv, stable_atom uv f) -> Transform
  | trLeaf (f : bool -> RAtom -> RTree) : (forall uv, stable_atom_tree uv f) -> Transform
  | trBound (f : RExpr -> RExpr) : (forall uv, stable_expr uv f) -> Transform
  | trExpr (f : RExpr -> RExpr) : (forall uv, stable_expr uv f) -> Transform
  | trTree (f : RTree -> RTree) : (forall uv t, convert_tree uv t -> convert_tree uv (f t)) -> Transform.

Definition transform_once tr t :=
  match tr with
  | trAtom f _ => transform_tree_atom f t
  | trLeaf f _ => transform_tree_atom' f t
  | trBound f _ => transform_tree_atom (transform_atom_bound (transform_expr f)) t
  | trExpr f _ => transform_tree_atom (transform_atom_expr (transform_expr f)) t
  | trTree f _ => f t
  end.

Theorem transform_once_correct :
  forall uv tr t,
  convert_tree uv t ->
  convert_tree uv (transform_once tr t).
Proof.
intros uv [f Hf|f Hf|f Hf|f Hf|f Hf] t Ht ; simpl.
now apply transform_tree_atom_correct.
now apply transform_tree_atom'_correct.
apply transform_tree_atom_correct with (2 := Ht).
now apply transform_atom_bound_correct.
apply transform_tree_atom_correct with (2 := Ht).
now apply transform_atom_expr_correct.
now apply Hf.
Qed.

Definition transform :=
  fold_left (fun v t => transform_once t v).

Theorem transform_correct :
  forall l uv t,
  convert_tree uv t ->
  convert_tree uv (transform l t).
Proof.
intros l uv t Ht.
rewrite <- (rev_involutive l).
induction (rev l) as [|h l' Hl] ; simpl.
easy.
unfold transform.
rewrite fold_left_app.
simpl.
apply transform_once_correct.
apply Hl.
Qed.

Definition trans :=
  trAtom change_rel_func change_rel_prop ::
  trAtom change_abs_func change_abs_prop ::
  trBound remove_inv_func remove_inv_prop ::
  trBound gen_float_func gen_float_prop ::
  trBound clean_pow_func clean_pow_prop ::
  trBound merge_float2_func merge_float2_prop ::
  trExpr remove_inv_func remove_inv_prop ::
  trExpr gen_float_func gen_float_prop ::
  trExpr clean_pow_func clean_pow_prop ::
  trAtom change_le_func change_le_prop ::
  trLeaf change_format_func change_format_prop ::
  trLeaf remove_unknown_func remove_unknown_prop ::
  trTree simplify_tree simplify_tree_correct ::
  List.nil.

Theorem prepare_goal :
  forall uv t,
  convert_tree uv (rtNot (transform trans (normalize_tree t false))) ->
  convert_tree uv t.
Proof.
intros uv t.
change (not (convert_tree uv (transform trans (normalize_tree t false))) -> convert_tree uv t).
intros H.
destruct (decidable_tree uv t) as [H'|H'].
easy.
contradict H.
apply transform_correct.
now apply normalize_tree_correct.
Qed.

End Gappa_Private.

Import Gappa_Private.

Declare ML Module "gappatac".

Ltac gappa_prepare :=
  intros ; fold rndNE rndNA in * ;
  gappa_quote ;
  let convert_apply t :=
    match goal with
    | |- (convert_tree ?uv ?g) => t uv g
    end in
  let rec generalize_all m n l :=
    match l with
    | List.nil => clear
    | List.cons ?h ?q =>
      match n with
      | O =>
        generalize h ; clear ; intro ;
        convert_apply ltac:(fun uv _ => generalize_all (S m) (S m) uv)
      | S ?n => generalize_all m n q
      end
    end in
  convert_apply ltac:(fun uv _ => generalize_all O O uv) ;
  convert_apply ltac:(fun uv g => refine (prepare_goal uv g _)) ;
  convert_apply ltac:(fun uv g => let g := eval vm_compute in g in change (convert_tree uv g)).

Require Rregisternames.
Require Flocq.Core.Registernames.

Ltac gappa := abstract (gappa_prepare ; gappa_internal).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E P : Universe, ((wd_ C E /\ (wd_ A B /\ (wd_ C D /\ (col_ C D E /\ (col_ P A B /\ col_ P C D))))) -> col_ P C E)).
Proof.
  time tac.
Qed.

End FOFProblem.


(***************************************************************************
* Core Infrastructure                                                      *
* Multilanguage present in Ahmed & Blume ICFP 2011
* William J. Bowman, Phillip Mates & James T. Perconti                     *
***************************************************************************)

Require Export Core_Definitions.

(* ********************************************************************** *)
(** * Additional Definitions Used in the Proofs *)

(** Computing free type variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | s_typ_bool        => \{}
  | s_typ_arrow s1 s2 => (fv_tt s1) \u (fv_tt s2)

  | t_typ_bvar J      => \{}
  | t_typ_fvar X      => \{X}
  | t_typ_bool        => \{}
  | t_typ_pair t1 t2  => (fv_tt t1) \u (fv_tt t2)
  | t_typ_arrow t1 t2 => (fv_tt t1) \u (fv_tt t2)
  | typ_bad => \{}
  end.

(** Computing free type variables in a term *)

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | s_trm_bvar i    => \{}
  | s_trm_fvar x    => \{}
  | s_trm_true      => \{}
  | s_trm_false     => \{}
  | s_trm_abs s e1  => (fv_te e1)
  | s_trm_if e1 e2 e3 => (fv_te e1) \u (fv_te e2) \u (fv_te e3)
  | s_trm_app e1 e2 => (fv_te e1) \u (fv_te e2)

  | t_trm_bvar i    => \{}
  | t_trm_fvar x    => \{}
  | t_trm_true      => \{}
  | t_trm_false     => \{}
  | t_trm_pair e1 e2 => (fv_te e1) \u (fv_te e2)
  | t_trm_abs t e1  => (fv_tt t) \u (fv_te e1)
  | t_trm_if v e1 e2 => (fv_te v) \u (fv_te e1) \u (fv_te e2)
  | t_trm_let_fst v e2 => (fv_te v) \u (fv_te e2)
  | t_trm_let_snd v e2 => (fv_te v) \u (fv_te e2)
  | t_trm_app e1 t e2 => (fv_te e1) \u (fv_tt t) \u (fv_te e2)

  | s_trm_st m1 s1 => (fv_te m1)
  | t_trm_ts e1 s1 m2 => (fv_te e1) \u (fv_te m2)

  | trm_bad => \{}
  end.

(** Computing free term variables in a term *)

Fixpoint fv_ee (l : lang) (e : trm) {struct e} : vars :=
  match e with
  | s_trm_bvar i    => \{}
  | s_trm_fvar x    => if beq_lang l source then \{x} else \{}
  | s_trm_true      => \{}
  | s_trm_false     => \{}
  | s_trm_abs s e1  => (fv_ee l e1)
  | s_trm_if e1 e2 e3 => (fv_ee l e1) \u (fv_ee l e2) \u (fv_ee l e3)
  | s_trm_app e1 e2 => (fv_ee l e1) \u (fv_ee l e2)

  | t_trm_bvar i    => \{}
  | t_trm_fvar x    => if beq_lang l target then \{x} else \{}
  | t_trm_true      => \{}
  | t_trm_false     => \{}
  | t_trm_pair e1 e2 => (fv_ee l e1) \u (fv_ee l e2)
  | t_trm_abs t e1  => (fv_ee l e1)
  | t_trm_if v e1 e2 => (fv_ee l v) \u (fv_ee l e1) \u (fv_ee l e2)
  | t_trm_let_fst v e2 => (fv_ee l v) \u (fv_ee l e2)
  | t_trm_let_snd v e2 => (fv_ee l v) \u (fv_ee l e2)
  | t_trm_app e1 t e2 => (fv_ee l e1) \u (fv_ee l e2)

  | s_trm_st m1 s1 => (fv_ee l m1)
  | t_trm_ts e1 s1 m2 => (fv_ee l e1) \u (fv_ee l m2)

  | trm_bad => \{}
  end.

(************************************************************************)

(* turn an fvar into a bvar (inverse of open) *)
Fixpoint close_ee_rec (l : lang) (x : var) (k : nat) (e : trm) : trm :=
  match e with
  (* source terms *)
  | s_trm_bvar i => s_trm_bvar i
  | s_trm_fvar y => if andb (beq_lang l source) (LibReflect.decide (x = y))
                    then s_trm_bvar k else s_trm_fvar y
  | s_trm_true => s_trm_true
  | s_trm_false => s_trm_false
  | s_trm_abs s e => s_trm_abs s (close_ee_rec l x (inc_if_eq l source k) e)
  | s_trm_if e1 e2 e3 => s_trm_if (close_ee_rec l x k e1)
                                  (close_ee_rec l x k e2)
                                  (close_ee_rec l x k e3)
  | s_trm_app e1 e2 => s_trm_app (close_ee_rec l x k e1)
                                 (close_ee_rec l x k e2)
  | s_trm_st m s => s_trm_st (close_ee_rec l x k m) s
  (* target terms *)
  | t_trm_bvar i => t_trm_bvar i
  | t_trm_fvar y => if andb (beq_lang l target) (LibReflect.decide (x = y))
                    then t_trm_bvar k else t_trm_fvar y
  | t_trm_true => t_trm_true
  | t_trm_false => t_trm_false
  | t_trm_pair u1 u2 => t_trm_pair (close_ee_rec l x k u1)
                                   (close_ee_rec l x k u2)
  | t_trm_abs t m => t_trm_abs t (close_ee_rec l x (inc_if_eq l target k) m)
  | t_trm_if u m1 m2 => t_trm_if (close_ee_rec l x k u)
                                 (close_ee_rec l x k m1)
                                 (close_ee_rec l x k m2)
  | t_trm_let_fst u m => t_trm_let_fst (close_ee_rec l x k u)
                                       (close_ee_rec l x (inc_if_eq l target k) m)
  | t_trm_let_snd u m => t_trm_let_snd (close_ee_rec l x k u)
                                       (close_ee_rec l x (inc_if_eq l target k) m)
  | t_trm_app m1 t m2 => t_trm_app (close_ee_rec l x k m1)
                                   t
                                   (close_ee_rec l x k m2)
  | t_trm_ts e s m    => t_trm_ts (close_ee_rec l x k e)
                                  s
                                  (close_ee_rec l x (inc_if_eq l target k) m)
  (* blah *)
  | trm_bad => trm_bad
  end.

Definition close_ee (l : lang) (x : var) (e : trm) := close_ee_rec l x 0 e.
Definition s_close_ee := close_ee source.
Definition t_close_ee := close_ee target.

(************************************************************************)

(** Size of a type *)
Fixpoint typ_size (t : typ) : nat :=
  match t with
  (* source types *)
  | s_typ_bool        => 1
  | s_typ_arrow s1 s2   => (typ_size s1) + (typ_size s2)
  (* target types *)
  | t_typ_bvar _      => 1
  | t_typ_fvar _      => 1
  | t_typ_bool        => 1
  | t_typ_pair t1 t2  => 1 + (typ_size t1) + (typ_size t2)
  | t_typ_arrow t1 t2 => 1 + (typ_size t1) + (typ_size t2)
  (* blah *)
  | typ_bad => 1
  end.

(** Size of a term *)
Fixpoint trm_size (t : trm) : nat :=
  match t with
  (* source values *)
  | s_trm_bvar _ => 1
  | s_trm_fvar _ => 1
  | s_trm_true => 1
  | s_trm_false => 1
  | s_trm_abs s e => 1 + (typ_size s) + (trm_size e)
  (* source non-values *)
  | s_trm_if e1 e2 e3 => 1 + (trm_size e1) + (trm_size e2) + (trm_size e3)
  | s_trm_app e1 e2 => 1 + (trm_size e1) + (trm_size e2)

  (* target values *)
  | t_trm_bvar _ => 1
  | t_trm_fvar _ => 1
  | t_trm_true  => 1
  | t_trm_false => 1
  | t_trm_pair u1 u2 => 1 + (trm_size u1) + (trm_size u2)
  | t_trm_abs t m => 1 + (typ_size t) + (trm_size m)
  (* target non-values *)
  | t_trm_if u m1 m2 => 1 + (trm_size u) + (trm_size m1) + (trm_size m2)
  | t_trm_let_fst u m => 1 + (trm_size u) + (trm_size m)
  | t_trm_let_snd u m => 1 + (trm_size u) + (trm_size m)
  | t_trm_app u1 t u2 => 1 + (trm_size u1) + (typ_size t) + (trm_size u2)

  (* Boundary Terms *)
  | s_trm_st m s => 1 + (trm_size m) + (typ_size s)
  | t_trm_ts e s m => 1 + (trm_size e) + (typ_size s) + (trm_size m)

  (* error case *)
  | trm_bad => 1
  end.

Lemma typ_size_open_var : forall X t,
  typ_size (open_tt_var t X) = typ_size t.
Proof.
  intros. generalize 0.
  induction t; intros; simpl; auto.
  case_if*.
Qed.

Lemma s_trm_size_open_var : forall x t,
  trm_size (s_open_ee_var t x) = trm_size t.
Proof.
  intros. generalize 0.
  induction t; intros; simpl; auto.
  case_if*.
Qed.

Lemma t_trm_size_open_var : forall x t,
  trm_size (t_open_ee_var t x) = trm_size t.
Proof.
  intros. generalize 0.
  induction t; intros; simpl; auto.
  case_if*.
Qed.

(* empty substitutions don't do anyting *)

Lemma subst_tt_empty : forall t, subst_tt empty t = t.
Proof.
  induction t; simpl; fequals; auto. rewrite* get_none.
Qed.

Lemma subst_te_empty : forall e, subst_te empty e = e.
Proof.
  induction e; simpl; fequals; auto using subst_tt_empty.
Qed.

Lemma subst_ee_empty : forall l e, subst_ee l empty e = e.
Proof.
  induction e; simpl; fequals; auto; cases_if*; rewrite* get_none.
Qed.

(* weakening for substitutions *)

Lemma subst_tt_push : forall t X t' d, X \notin fv_tt t ->
  subst_tt (d & X ~ t') t = subst_tt d t.
Proof.
  induction t; simpl; intros; auto; try rewrite* IHt1; try rewrite* IHt2.
  rewrite get_push. cases_if*. false. auto using in_singleton_self.
Qed.

Lemma subst_te_push : forall e X t d, X \notin fv_te e ->
  subst_te (d & X ~ t) e = subst_te d e.
Proof.
  induction e; simpl; auto; intros; try rewrite* subst_tt_push;
    try rewrite* IHe; try rewrite* IHe1; try rewrite* IHe2; try rewrite* IHe3.
Qed.

Lemma subst_ee_push : forall e x e' g l, x \notin fv_ee l e ->
  subst_ee l (g & x ~ e') e = subst_ee l g e.
Proof.
  induction e; simpl; intros; auto;
    try rewrite* IHe; try rewrite* IHe1; try rewrite* IHe2; try rewrite* IHe3;
  cases_if*; rewrite get_push; cases_if*; false; auto using in_singleton_self.
Qed.

Lemma subst_tt_weaken : forall t X t' d d', X \notin fv_tt t ->
  subst_tt (d & X ~ t' & d') t = subst_tt (d & d') t.
Proof.
  induction t; simpl; intros; auto; try rewrite* IHt1; try rewrite* IHt2.
  repeat rewrite get_concat. destruct* (get v d').
  rewrite get_single. cases_if*. false. auto using in_singleton_self.
Qed.

Lemma subst_te_weaken : forall e X t d d', X \notin fv_te e ->
  subst_te (d & X ~ t & d') e = subst_te (d & d') e.
Proof.
  induction e; simpl; auto; intros; try rewrite* subst_tt_weaken;
    try rewrite* IHe; try rewrite* IHe1; try rewrite* IHe2; try rewrite* IHe3.
Qed.

Lemma subst_ee_weaken : forall e x e' g g' l, x \notin fv_ee l e ->
  subst_ee l (g & x ~ e' & g') e = subst_ee l (g & g') e.
Proof.
  induction e; simpl; intros; auto;
    try rewrite* IHe; try rewrite* IHe1; try rewrite* IHe2; try rewrite* IHe3;
  cases_if*; repeat rewrite get_concat; destruct* (get v g');
    rewrite get_single; cases_if*; false; auto using in_singleton_self.
Qed.

(* exchange for substitutions *)

Lemma subst_tt_exchange : forall t D1 D2 D3 D4, ok (D1 & D2 & D3 & D4) ->
  subst_tt (D1 & D2 & D3 & D4) t = subst_tt (D1 & D3 & D2 & D4) t.
Proof.
  induction t; simpl; intros; f_equal*.
  repeat rewrite get_concat.
  case_eq (get v D1); case_eq (get v D2); case_eq (get v D3); case_eq (get v D4); intros; auto;
  apply binds_func with (x := v) (E := D1 & D2 & D3 & D4); repeat apply* binds_concat_left_ok.
Qed.

(* fv and open *)

Lemma open_tt_rec_fv_tt : forall t n X,
  fv_tt (open_tt_rec n (t_typ_fvar X) t) = (fv_tt t \u \{ X }) \/
  fv_tt (open_tt_rec n (t_typ_fvar X) t) = (fv_tt t).
Proof.
  induction t; simpl; auto using subset_union_weak_l; intros.
  cases_if; simpl; auto. left. rewrite* union_empty_l.
  destruct (IHt1 n X); destruct (IHt2 n X).
    left. rewrite <- union_same with (E := \{ X });
          rewrite <- union_assoc; rewrite union_assoc with (E := fv_tt t2);
          rewrite union_comm with (E := fv_tt t2 \u \{ X }); rewrite union_assoc.
          rewrite H. rewrite* H0.
    left. rewrite H. rewrite H0.
          rewrite <- union_assoc. rewrite union_comm with (E := \{ X }). apply union_assoc.
    left. rewrite H. rewrite H0. apply union_assoc.
    right. rewrite H. rewrite* H0.
  destruct (IHt1 (S n) X); destruct (IHt2 (S n) X).
    left. rewrite <- union_same with (E := \{ X });
          rewrite <- union_assoc; rewrite union_assoc with (E := fv_tt t2);
          rewrite union_comm with (E := fv_tt t2 \u \{ X }); rewrite union_assoc.
          rewrite H. rewrite* H0.
    left. rewrite H. rewrite H0.
          rewrite <- union_assoc. rewrite union_comm with (E := \{ X }). apply union_assoc.
    left. rewrite H. rewrite H0. apply union_assoc.
    right. rewrite H. rewrite* H0.
Qed.

Lemma open_tt_var_fv_tt : forall t X,
  fv_tt (open_tt_var t X) = (fv_tt t \u \{ X }) \/
  fv_tt (open_tt_var t X) = (fv_tt t).
Proof.
  intros. apply* open_tt_rec_fv_tt.
Qed.

(* ********************************************************************** *)
(** * Tactics *)

(** Gathering free names already used in the proofs *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : typ => fv_tt x) in
  let D := gather_vars_with (fun x : trm => fv_te x) in
  let E := gather_vars_with (fun x : trm => fv_ee source x) in
  let F := gather_vars_with (fun x : trm => fv_ee target x) in
  let G := gather_vars_with (fun x : env_type => dom x) in
  let H := gather_vars_with (fun x : env_term => dom x) in
  let I := gather_vars_with (fun x : env_term => fold_vars fv_tt x) in
  let J := gather_vars_with (fun x : subst_type => dom x) in
  let K := gather_vars_with (fun x : subst_type => fold_vars fv_tt x) in
  let L := gather_vars_with (fun x : subst_term => dom x) in
  let M := gather_vars_with (fun x : subst_term => fold_vars fv_te x) in
  let N := gather_vars_with (fun x : subst_term =>
                               fold_vars (fv_ee source) x) in
  let O := gather_vars_with (fun x : subst_term =>
                               fold_vars (fv_ee target) x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u
          I \u J \u K \u L \u M \u N \u O).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto*.

(* try to auto a goal with a fresh variable needed *)
Ltac frauto :=
  eauto;
  let x := fresh "x" in
    pick_fresh x; eauto;
      try match goal with
            | [ H : (forall x : var, x \notin ?L -> _) |- _ ]
              => let Fr := fresh "Fr" in assert (Fr : x \notin L); eauto end.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

(* TODO:
Ltac get_env_type :=
  match goal with
  | |- wft ?D _ => D
  | |- typing ?D _ _ _ => D
  end.

Ltac get_env_term :=
  match goal with
  | |- typing _ ?G _ _ => G
  end.
*)

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

(* TODO:
Tactic Notation "apply_empty" constr(F) :=
  try apply_empty_bis (get_env_term) F;
  try apply_empty_bis (get_env_type) F.
*)

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; auto*.

(** Tactic to undo when Coq does too much simplification *)

Ltac unsimpl_map_bind :=
  match goal with |- context [ ?B (subst_tt ?Z ?P ?U) ] =>
    unsimpl ((subst_tt Z P) (B U)) end.

Tactic Notation "unsimpl_map_bind" "*" :=
  unsimpl_map_bind; auto*.


Require Import Poly.
Require Import List.
Require Import String.

(* Tipo das fórmulas ecumênicas *)

Inductive LF :=
| Atom   : string -> LF
| Neg  : LF -> LF
| And  : LF -> LF -> LF
| iOr  : LF -> LF -> LF
| cOr  : LF -> LF -> LF
| iImp : LF -> LF -> LF
| cImp : LF -> LF -> LF.

Inductive node :=
| Node (SL : SignedLF LF) (n : nat)
| R : nat -> nat -> node.

Notation "[ A ]"   := (Atom A) (at level 50).
Notation "~ A"     := (Neg A).
Notation "A /\ B"  := (And A B).
Notation "A \/i B" := (iOr A B) (at level 100).
Notation "A \/c B" := (cOr A B) (at level 100).
Notation "A ->i B" := (iImp A B) (at level 90).
Notation "A ->c B" := (cImp A B) (at level 90).

(** Nesse tableau, a memória guarda o index mais alto da árvore **)

Definition EcumenicalTableau
  (snapshot : poly_binary_tree node)
  (lc : list (check node))
  (listNodes : list node)
  (m : list(mem nat))
  (p : parameters)
  : stt node nat :=
  let memvalue := getRecordValueFromMemory nat (pop m (empty _)) 0 in
  match listNodes with
  | nil => state _ _ (Leaf _ nil) lc m
  | h::tl =>
      match h with
      | R k j => state _ _ (Leaf _ listNodes) lc m
      | Node SF n =>
          match SF with
          | T _ t L =>
              let unaryRule :=
                (fun node =>
                   state _ _ (Alpha _ node (Leaf _ (node::(explode listNodes)))) lc m) in
              let negationFRule :=
                (fun node =>
                   let nrecord := record _ 0 (memvalue+1) in
                   state _ _
                     (Alpha _ (R memvalue (memvalue+1))
                        (Alpha _ node
                           (Leaf _ (node::(explode listNodes))))) lc (nrecord::nil)) in
              let alphaRule :=
                (fun node1 node2 =>
                   state _ _
                     (Alpha _ node1
                        ((Alpha _ node2
                            (Leaf _ (node1::node2::(explode listNodes)))))) lc m) in
              let betaRule :=
                (fun node1 node2 =>
                   state _ _
                     (Beta _
                        (Alpha _ node1
                           ((Leaf _ (node1::(explode listNodes)))))
                        (Alpha _ node2
                           ((Leaf _ (node2::(explode listNodes)))))) lc m) in
              let specialBeta :=
                (fun node =>
                   if getSelector p then
                   state _ _
                     (Alpha _ node (Leaf _ (node::(explode listNodes))))
                     ((checkpoint _ snapshot (selector false))::lc)
                     m
                   else
                     state _ _
                       (Alpha _ node (Leaf _ (node::(explode listNodes))))
                       lc
                       m
                ) in
              match L with
              | Atom _ => state _ _ (Leaf _ (explode listNodes)) lc m
              | l /\ r =>
                  let an1 := (Node (T _ true l) 0) in
                  let an2 := (Node (T _ true r) 0) in
                  let bn1 := (Node (T _ false l) 0) in
                  let bn2 := (Node (T _ false r) 0) in
                  if t then alphaRule an1 an2
                  else betaRule bn1 bn2
              | l \/c r =>
                  let an1 := (Node (T _ true (Neg l)) 0) in
                  let an2 := (Node (T _ true (Neg r)) 0) in
                  let bn1 := (Node (T _ false (Neg l)) 0) in
                  let bn2 := (Node (T _ false (Neg r)) 0) in
                  if t then betaRule bn1 bn2
                  else alphaRule an1 an2
              | l ->c r =>
                  let an1 := (Node (T _ true l) 0) in
                  let an2 := (Node (T _ true (Neg r)) 0) in
                  let bn1 := (Node (T _ false l) 0) in
                  let bn2 := (Node (T _ false (Neg r)) 0) in
                  if t then betaRule bn1 bn2
                  else alphaRule an1 an2
              | l \/i r =>
                  let an1 := (Node (T _ false l) 0) in
                  let an2 := (Node (T _ false r) 0) in
                  let bn1 := (Node (T _ true l) 0) in
                  let bn2 := (Node (T _ true r) 0) in
                  if t then betaRule bn1 bn2
                  else
                    match p with
                    | none => specialBeta an1
                    | selector b => if b then specialBeta an1
                                    else specialBeta an2
                    end
              | l ->i r =>
                  let an1 := (Node (T _ true l) 0) in
                  let an2 := (Node (T _ false r) 0) in
                  let bn1 := (Node (T _ false l) 0) in
                  let bn2 := (Node (T _ true r) 0) in
                  if t then betaRule bn1 bn2
                  else alphaRule an1 an2
              | ~ r =>
                  let an1 := (Node (T _ false r) 0) in
                  let an2 := (Node (T _ true r) (memvalue+1)) in
                  if t then unaryRule an1
                  else negationFRule an2
              end
          end
      end
  end.

Open Scope string_scope.

Definition P := "P".
Definition Q := "Q".
Definition S := "S".
Definition X := "X".

Definition node0 := Node (T _ false ((([S] \/i [P]) \/i ([X] \/i [S])))) 0.
Definition node1 := Node (T _ false (~([S]))) 0.
Definition node2 := Node (T _ false (([X] \/i [S]))) 0.
Definition listnodes := node0::nil.

Compute make _ _ EcumenicalTableau (makeInitialTree _ listnodes listnodes).


(* -*- coq-prog-name: "d:/Documents/GitHub/coq-hit/bin/coqtop.exe" -*- *)

Inductive interval :=
| zero : interval
| one : interval
with paths :=
| seg : zero = one.

Definition function_extensionality
: forall A B (f g : A -> B), (forall x, f x = g x) -> f = g.
Admitted.

Inductive S¹ :=
| base : S¹
with paths :=
| loop : base = base.

Inductive unit := tt.
Definition unit_elim : forall (P : unit -> Type) (x : unit), P tt -> P x
  := fun P x Ptt => match x with
                      | tt => Ptt
                    end.

Inductive nat' := Z' | S' (x : nat').
Fixpoint nat'_elim (P : nat' -> Type) (x : nat')
: P Z' -> (forall n, P n -> P (S' n)) -> P x
  := fun Pz Ps =>
       match x with
         | Z' => Pz
         | S' x' => Ps x' (nat'_elim P x' Pz Ps)
       end.

Fail Fixpoint bad (x : unit) : Empty_set
  := match x with
       | tt => bad tt
     end.

Definition eq_elim : forall A (x : A) (P : forall y, eq x y -> Type),
                       P x eq_refl -> forall y (H : eq x y), P y H
  := fun A x P Prefl y H => match H with
                              | eq_refl => Prefl
                            end.

Definition J_nondep : forall {A} {x : A} (P : A -> Type),
                        P x -> forall {y}, x = y -> P y
  := fun A x P Prefl y H => match H with
                              | eq_refl => Prefl
                            end.

Definition S¹_elim (P : S¹ -> Type) (x : S¹) (Pbase : P base)
: (J_nondep P Pbase loop = Pbase) -> P x.
Proof.
  refine (fun Ploop => S¹_rect P Pbase Ploop x).
Defined.

Definition circle_contractible' : forall x : S¹, x = base.
Proof.
  refine (fun x => _).
  refine (S¹_elim
            (fun x' => x' = base) x
            eq_refl
            _).
  transitivity (eq_sym loop).
  { case loop; exact eq_refl. }
Abort.

(*Inductive zero_truncation (A : Type) :=
| incl (x : A)
with paths :=
| trunc (x y : A) (p q : incl x = incl y) : p = q.
*)
(*

Definition S¹_code (x : S¹) : Type
  := match x with
       | base => ℤ
       | loop => univalence applied to the automorphism (+1)
   end.

forall x : S¹, (base = x) ≃ ℤ
Idea:
  pattern match on x
  when x is base, we get 0
  on the loop,

Definition circle_contractible : forall x y : S¹, x = y.
Proof.
  refine (fun x => _).

  refine (S¹_elim
            (fun x' => forall y, x' = y) x
            _
            _).
About S¹_rect.
  *)

Definition choice_inf
: forall (I : Type) (X : I -> Type) (P : forall i, X i -> Prop),
    (forall i : I, { x : X i | P i x })
    -> { g : forall i, X i | forall i, P _ (g i) }.
Proof.
  refine (fun I X P proof_of_nonemptyness => _).
  refine (exist _ (fun i => proj1_sig (proof_of_nonemptyness i)) _).
  refine (fun i => proj2_sig (proof_of_nonemptyness i)).
Defined.

Inductive interval' := zero' | one'.
Axiom seg' : zero' = one'.

Inductive -1Trunc (A : Type) := incl (x : A).
Axiom -1trunc_istrunc : forall A (x y : -1Trunc A), x = y.

Inductive 0Trunc (A : Type) := incl (x : A).
Axiom 0trunc_istrunc : forall A (x y : 0Trunc A) (p q : x = y), p = q.

Definition choice_n
: forall (I : Type) (X : I -> Type) (P : forall i, X i -> Prop),
    (forall i : I, ∥ { x : X i | P i x } ∥_n)
    -> ∥ { g : forall i, X i | forall i, P _ (g i) } ∥_n.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.examples.composition
     lax_functor.examples.identity
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     general_category.

Section LaxAssociativity.
  Context `{Univalence}
          {C₁ C₂ C₃ C₄ : BiCategory}.
  Variable (F₃ : LaxFunctor C₃ C₄)
           (F₂ : LaxFunctor C₂ C₃)
           (F₁ : LaxFunctor C₁ C₂).

  Definition lax_associativity_d
    : PseudoTransformation_d
        (lax_comp (lax_comp F₃ F₂) F₁)
        (lax_comp F₃ (lax_comp F₂ F₁)).
  Proof.
    make_pseudo_transformation.
    - exact (fun X => id₁ (F₃ (F₂ (F₁ X)))).
    - exact (fun X Y f => left_unit_inv _ ∘ right_unit _).
    - exact (fun X Y f => right_unit_inv _ ∘ left_unit _).
  Defined.

  Definition is_lax_associativity_d
    : is_pseudo_transformation_p lax_associativity_d.
  Proof.
    make_is_pseudo_transformation.
    - intros X Y f g α ; simpl.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite !vcomp_assoc.
      reflexivity.
    - intros X ; cbn in *.
      rewrite <- right_unit_id_is_left_unit_id.
      rewrite !vcomp_assoc.
      rewrite right_unit_right.
      rewrite vcomp_right_identity.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite right_unit_id_is_left_unit_id.
      rewrite vcomp_assoc.
      rewrite left_unit_right.
      rewrite !vcomp_right_identity.
      rewrite <- !vcomp_assoc.
      repeat f_ap.
      rewrite Fmor₂_vcomp.
      reflexivity.
    - intros X Y Z f g ; cbn in *.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      symmetry.
      rewrite <- (vcomp_left_identity (id₂ (F₃ ₁ (F₂ ₁ (F₁ ₁ f))))).
      rewrite <- (vcomp_left_identity (id₂ (F₃ ₁ (F₂ ₁ (F₁ ₁ g))))).
      rewrite !interchange.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ (_ ∘ z))) (vcomp_assoc _ _ _)^).
      rewrite triangle_l.
      rewrite <- interchange.
      rewrite left_unit_left.
      rewrite vcomp_left_identity, hcomp_id₂.
      rewrite !vcomp_left_identity.
      rewrite <- right_unit_assoc.
      rewrite <- !vcomp_assoc.
      f_ap.
      rewrite Fmor₂_vcomp.
      rewrite !vcomp_assoc.
      f_ap.
      pose (left_unit_inv_assoc (F₃ ₁ (F₂ ₁ (F₁ ₁ g))) (F₃ ₁ (F₂ ₁ (F₁ ₁ f)))) as p.
      unfold bc_whisker_r in p.
      rewrite p ; clear p.
      rewrite <- !vcomp_assoc.
      rewrite assoc_left.
      apply vcomp_left_identity.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite right_unit_left, vcomp_left_identity.
      apply left_unit_right.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite left_unit_left, vcomp_left_identity.
      apply right_unit_right.
  Qed.

  Definition lax_associativity
    : PseudoTransformation (lax_comp (lax_comp F₃ F₂) F₁) (lax_comp F₃ (lax_comp F₂ F₁))
    := Build_PseudoTransformation lax_associativity_d is_lax_associativity_d.
End LaxAssociativity.