From stdpp Require Import prelude fin_maps.
From AML Require Import Signature Pattern Variables Substitution.
From AML.Proofs Require Import TautologicalProof ProofSystem Theorems.
From AML.Semantics Require Import Tautology.

Section sec_proofs.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  (single_premise_rule : Pattern -> Pattern -> Prop)
  .

Inductive MLProof (Gamma : PatternSet) : list Pattern -> Prop :=
| ml_empty_proof : MLProof Gamma []
| ml_proof_assumption :
    forall proof ϕ, MLProof Gamma proof ->
        ϕ ∈ Gamma ->
        MLProof Gamma (ϕ :: proof)
| ml_proof_tautology :
    forall proof ϕ, MLProof Gamma proof ->
        Tautology ϕ ->
        MLProof Gamma (ϕ :: proof)
| ml_proof_axiom :
    forall proof ϕ, MLProof Gamma proof ->
        MLAxiom ϕ ->
        MLProof Gamma (ϕ :: proof)
| ml_proof_modus_ponens : forall proof ϕ ψ χ,
    MLProof Gamma proof ->
    MLModusPonens ϕ ψ χ ->
    ϕ ∈ proof ->
    ψ ∈ proof ->
    MLProof Gamma (χ :: proof)
| ml_proof_single_premise : forall proof ϕ ψ,
    MLProof Gamma proof ->
    single_premise_rule ϕ ψ ->
    ϕ ∈ proof ->
    MLProof Gamma (ψ :: proof)
.

Lemma MLProof_app (Gamma : PatternSet) (proof1 proof2 : list Pattern) :
  MLProof Gamma proof1 ->
  MLProof Gamma proof2 ->
  MLProof Gamma (proof1 ++ proof2).
Proof.
  intros Hproof1 Hproof2.
  induction Hproof1; cbn; [done |..].
  - by apply ml_proof_assumption.
  - by apply ml_proof_tautology.
  - by apply ml_proof_axiom.
  - by apply ml_proof_modus_ponens with ϕ ψ;
      [ | | apply elem_of_app; left..].
  - by apply ml_proof_single_premise with ϕ; [..| apply elem_of_app; left].
Qed.

Lemma MLProof_suffix (Gamma : PatternSet) (proof1 proof2 : list Pattern) :
  MLProof Gamma (proof1 ++ proof2) ->
  MLProof Gamma proof2.
Proof.
  induction proof1; [done |]; inversion 1; subst.
  all: by apply IHproof1.
Qed.

Lemma MLTheoremProofs_iff (Gamma : PatternSet) (ϕ : Pattern) :
  Gamma ⊢[single_premise_rule] ϕ
    <->
  exists proof, MLProof Gamma (ϕ :: proof).
Proof.
  split.
  - induction 1.
    + by exists []; apply ml_proof_assumption; [constructor |].
    + by exists []; apply ml_proof_tautology; [constructor |].
    + by exists []; apply ml_proof_axiom; [constructor |].
    + destruct IHMLXGammaTheorem1 as [proof_ϕ Hproof_ϕ].
      destruct IHMLXGammaTheorem2 as [proof_ψ Hproof_ψ].
      exists ((ϕ :: proof_ϕ) ++ ψ :: proof_ψ).
      apply ml_proof_modus_ponens with ϕ ψ.
      * by apply MLProof_app.
      * done.
      * by apply elem_of_app; left; left.
      * by apply elem_of_app; right; left.
    + destruct IHMLXGammaTheorem as [proof_ϕ Hproof_ϕ].
      exists (ϕ :: proof_ϕ).
      by eapply ml_proof_single_premise; [..| left].
  - intros [proof Hproof].
    remember (length (ϕ :: proof)) as n.
    revert ϕ proof Hproof Heqn.
    induction n as [n Hind] using (well_founded_ind lt_wf).
    intros; inversion Hproof
      as [| | | | ? ? ? ? Hpf Hmp Hϕ0 Hψ | ? ? ? ? Hsp Hϕ0]; subst.
    + by apply ml_thm_assumption.
    + by apply ml_thm_tautology.
    + by apply ml_thm_axiom.
    + apply elem_of_list_split in Hϕ0 as (? & proof_ϕ0 & Heqproof_ϕ0).
      assert (Hϕ0 : MLProof Gamma (ϕ0 :: proof_ϕ0))
        by (subst; eapply MLProof_suffix; done).
      apply (f_equal length) in Heqproof_ϕ0.
      apply elem_of_list_split in Hψ as (? & proof_ψ & Heqproof_ψ).
      assert (Hψ : MLProof Gamma (ψ :: proof_ψ))
        by (subst; eapply MLProof_suffix; done).
      apply (f_equal length) in Heqproof_ψ.
      rewrite app_length in Heqproof_ϕ0, Heqproof_ψ; cbn in Heqproof_ϕ0, Heqproof_ψ.
      apply ml_thm_modus_ponens with ϕ0 ψ; [done |..]; eapply Hind.
      2,3,5,6: done.
      all: cbn; lia.
    + apply elem_of_list_split in Hϕ0 as (? & proof_ϕ0 & Heqproof_ϕ0).
      assert (Hϕ0 : MLProof Gamma (ϕ0 :: proof_ϕ0))
        by (subst; eapply MLProof_suffix; done).
      apply (f_equal length) in Heqproof_ϕ0.
      rewrite app_length in Heqproof_ϕ0; cbn in Heqproof_ϕ0.
      eapply ml_thm_single_premise; [done |].
      eapply Hind; [| done..].
      by cbn; lia.
Qed.

End sec_proofs.

Section sec_elaborated_proof.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  `{FinMap string StringMap}.

Inductive ElaboratedProofStep:=
| eps_assumpmtion : forall (idx : nat), ElaboratedProofStep
| eps_tautology : forall τ : Pattern, ElaboratedProofStep
| eps_ax_ex_quantifier : forall (x y : EVar) (ϕ : Pattern), ElaboratedProofStep
| eps_propagation_bot_l : forall (ϕ : Pattern), ElaboratedProofStep
| eps_propagation_bot_r : forall (ϕ : Pattern), ElaboratedProofStep
| eps_propagation_or_l : forall (ϕ_or_l ψ_or_r χ_app_r : Pattern), ElaboratedProofStep
| eps_propagation_or_r : forall (ϕ_or_l ψ_or_r χ_app_l : Pattern), ElaboratedProofStep
| eps_propagation_ex_l : forall (x : EVar) (ϕ_ex χ_app_r : Pattern), ElaboratedProofStep
| eps_propagation_ex_r : forall (x : EVar) (ϕ_ex χ_app_l : Pattern), ElaboratedProofStep
| eps_pre_fixpoint : forall (X : SVar) (ϕ_mu : Pattern), ElaboratedProofStep
| eps_existence : forall (x : EVar), ElaboratedProofStep
| eps_singleton_variable : forall (x : EVar) (phi : Pattern) (C1 C2 : AppContext),
    ElaboratedProofStep
| eps_ex_quantifier : forall (n : nat) (x : EVar), ElaboratedProofStep
| eps_framing_l : forall (n : nat) (chi : Pattern), ElaboratedProofStep
| eps_framing_r : forall (n : nat) (chi : Pattern), ElaboratedProofStep
| eps_set_variable_substitution : forall (n : nat) (psi : Pattern),
    ElaboratedProofStep
| eps_knaster_tarsky : forall (n : nat) (X : SVar) (phi : Pattern), ElaboratedProofStep
| eps_modus_ponens : forall (n_impl n_premise : nat), ElaboratedProofStep
.

End sec_elaborated_proof.

Section sec_derived_rules.

End sec_derived_rules.


Require Import Coq.Classes.Morphisms.
Require Import Relation_Definitions.

Fixpoint tuple' T n : Type :=
  match n with
  | O => T
  | S n' => (tuple' T n' * T)%type
  end.

Definition tuple T n : Type :=
  match n with
  | O => unit
  | S n' => tuple' T n'
  end.

Fixpoint to_list' {T} (n:nat) {struct n} : tuple' T n -> list T :=
  match n with
  | 0 => fun x => (x::nil)%list
  | S n' => fun xs : tuple' T (S n') => let (xs', x) := xs in (x :: to_list' n' xs')%list
  end.

Definition to_list {T} (n:nat) : tuple T n -> list T :=
  match n with
  | 0 => fun _ => nil
  | S n' => fun xs : tuple T (S n') => to_list' n' xs
  end.

Program Fixpoint from_list' {T} (y:T) (n:nat) (xs:list T) : length xs = n -> tuple' T n :=
  match n return _ with
  | 0 =>
    match xs return (length xs = 0 -> tuple' T 0) with
    | nil => fun _ => y
    | _ => _ (* impossible *)
    end
  | S n' =>
    match xs return (length xs = S n' -> tuple' T (S n')) with
    | cons x xs' => fun _ => (from_list' x n' xs' _, y)
    | _ => _ (* impossible *)
    end
  end.
Goal True.
  pose from_list'_obligation_3 as e.
  repeat (let e' := fresh in
          rename e into e';
          (pose (e' nat) as e || pose (e' 0) as e || pose (e' nil) as e || pose (e' eq_refl) as e);
          subst e').
  progress hnf in e.
  pose (eq_refl : e = eq_refl).
  exact I.
Qed.

Program Definition from_list {T} (n:nat) (xs:list T) : length xs = n -> tuple T n :=
match n return _ with
| 0 =>
    match xs return (length xs = 0 -> tuple T 0) with
    | nil => fun _ : 0 = 0 => tt
    | _ => _ (* impossible *)
    end
| S n' =>
    match xs return (length xs = S n' -> tuple T (S n')) with
    | cons x xs' => fun _ => from_list' x n' xs' _
    | _ => _ (* impossible *)
    end
end.

Lemma to_list_from_list : forall {T} (n:nat) (xs:list T) pf, to_list n (from_list n xs pf) = xs.
Proof.
  destruct xs; simpl; intros; subst; auto.
  generalize dependent t. simpl in *.
  induction xs; simpl in *; intros; congruence.
Qed.


Set Implicit Arguments.
Require Import CFML.CFLib CFML.CFLibCredits.
Require Import BinaryRandomAccessList_ml.
Require Import TLC.LibListZ LibZExtra TLC.LibIntTactics.
Require Import Filter Monotonic Dominated CFMLBigO.
Require Import Procrastination.Procrastination.

Require Import Generic DominatedNary LimitNary.
Require Import UltimatelyGreater.

Open Scope Z_scope.
Open Scope liblist_scope.

Notation "'int'" := Z.

Module BinaryRandomAccessListSpec.

Import BinaryRandomAccessList_ml.

(** invariant *)

Section Polymorphic.
Variables (a : Type).

Inductive btree : int -> tree_ a -> list a -> Prop :=
  | btree_nil : forall x,
      btree 0 (Leaf x) (x::nil)
  | btree_cons : forall p p' n t1 t2 L1 L2 L',
      btree p t1 L1 ->
      btree p t2 L2 ->
      p' = p+1 ->
      n = 2^p' ->
      L' = L1 ++ L2 ->
      btree p' (Node n t1 t2) L'.

Inductive inv : int -> rlist_ a -> list a -> Prop :=
  | inv_nil : forall p,
      0 <= p ->
      inv p nil nil
  | inv_cons : forall p (t: tree_ a) ts d L L' T,
      inv (p+1) ts L ->
      L' <> nil ->
      0 <= p ->
      (match d with
       | Zero => L = L'
       | One t => btree p t T /\ L' = T ++ L
       end) ->
      inv p (d :: ts) L'.

Definition Rlist (s: rlist_ a) (L: list a) :=
  inv 0 s L.

End Polymorphic.

Arguments btree [a].
Arguments inv [a].

(** Automation *)

(* Use [maths] hints and properties about btrees in ~-suffixed tactics *)
Create HintDb bral.
Ltac auto_tilde ::= eauto with maths bral.

(* Do not try to unfold Z.mul, e.g. in [2 * n] *)
Opaque Z.mul.

(* Hint Constructors btree inv. *)
(* Hint Extern 1 (@lt nat _ _ _) => rew_list; math. *)
(* Hint Resolve ZNth_zero ZUpdate_here ZUpdate_not_nil. *)
Hint Resolve app_not_empty_l app_not_empty_r.
Hint Extern 1 (0 <= length _) => math : zarith.

(** useful facts *)

Fixpoint tree_size {a: Type} (t:tree_ a) : nat :=
  match t with
  | Leaf _ => 0%nat
  | Node _ t1 t2 => (1 + tree_size t1 + tree_size t2)%nat
  end.

Definition Size {a: Type} (t:tree_ a) :=
  match t with
  | Leaf _ => 1
  | Node w _ _ => w
  end.

Lemma btree_size_correct : forall a p t L,
  @btree a p t L -> Size t = 2^p.
Proof. introv Rt. inverts~ Rt. Qed.

Lemma btree_size_pos : forall a p t L,
  @btree a p t L -> 0 <= p.
Proof. introv Rt. inductions Rt; math. Qed.

Hint Resolve btree_size_pos : bral.

Lemma btree_length_correct : forall a t p L,
  @btree a p t L -> length L = 2^p.
Proof.
  introv Rt. induction Rt. auto.
  subst. rew_list. rewrite~ pow2_succ.
Qed.

Lemma btree_size_length : forall a t p L,
  @btree a p t L -> length L = Size t.
Proof.
  intros. erewrite~ btree_size_correct. erewrite~ btree_length_correct.
Qed.

Lemma btree_not_empty : forall a p t L,
  @btree a p t L -> L <> nil.
Proof.
  introv Rt. intro; subst.
  forwards~: btree_length_correct. rew_list in *.
  forwards~: @pow2_ge_1 p. math.
Qed.

Hint Resolve btree_not_empty : bral.

Lemma inv_size_pos : forall a p ts L,
  @inv a p ts L ->
  0 <= p.
Proof. introv I. destruct~ I. Qed.

Hint Resolve inv_size_pos : bral.

Lemma inv_ts_not_empty : forall a p ts L,
  @inv a p ts L ->
  ts <> nil ->
  L <> nil.
Proof. introv I. destruct~ I. Qed.

Hint Resolve inv_ts_not_empty : bral.

Lemma inv_L_not_empty : forall a p ts L,
  @inv a p ts L ->
  L <> nil ->
  ts <> nil.
Proof. introv I H. destruct~ I. congruence. Qed.

Hint Resolve inv_L_not_empty : bral.

Lemma inv_to_empty : forall a p L,
  @inv a p nil L -> L = nil.
Proof. introv RL. inverts~ RL. Qed.

Lemma inv_from_empty : forall a p ts,
  @inv a p ts nil -> ts = nil.
Proof. introv RL. inverts RL; auto_false. Qed.

Ltac inv :=
  match goal with
  | I : inv _ nil ?L |- _ =>
    let H := fresh in
    pose proof (@inv_to_empty _ _ L I) as H;
    rewrite H in *; clear H; clear L
  | I : inv _ ?ts nil |- _ =>
    let H := fresh in
    pose proof (@inv_from_empty _ _ ts I) as H;
    rewrite H in *; clear H; clear ts
  end;
  rew_list in *.

Lemma group_ineq : forall n m, 0 <= n - m -> m <= n.
Proof. intros. math. Qed.

(* True but useless *)
(*
Lemma inv_length_correct : forall a ts p L,
    @inv a p ts L ->
    If ts = nil then
      length L = 0
    else
      (2 ^ p <= length L <= 2 ^ (length ts + p) - 2 ^ p).
Proof.
  induction ts.
  - intros. case_if. rewrites~ (>> to_empty ___).
  - { rename a0 into d. case_if; intros p L Rdts.
      - { inverts Rdts as. intros L0 T _t Rts Lnnil ?. forwards IH: IHts Rts.
          forwards~: pow2_ge_1 p.
          destruct d; intros; subst.
          - { assert (ts <> nil). { intro TS. apply Lnnil. subst. applys~ to_empty. }
              case_If. destruct IH as [IH1 IH2]. split.
              - rew_ineq <- IH1. rew_pow~ 2 p.
              - rewrite~ length_cons. rew_ineq IH2. rew_pow~ 2 p. }
          - { case_If.
              - { unpack; subst. forwards~: (>> to_empty ___); subst. split.
                  - forwards~: (>> length_correct ___). rew_list~.
                  - rew_length~. forwards~ Tlen: (>> length_correct ___). rew_pow~ 2 p. }
              - { destruct IH as [IH1 IH2]; unpack; subst.
                  split; forwards~ Tlen: (>> length_correct ___); rew_length~.
                  rew_ineq IH2. rewrite Tlen. rew_pow~ 2 p. } } } }
Qed.
*)

Lemma pow_r_eq : forall x y b,
  x = y -> b ^ x = b ^ y.
Proof. intros; subst~. Qed.

Local Ltac epow tac :=
  erewrite pow_r_eq; [ tac | auto_tilde ].

Tactic Notation "epow" ":" tactic(tac) :=
  epow tac.

Lemma inv_ts_len : forall a ts (p:int) L,
    @inv a p ts L ->
    ts <> nil ->
    2 ^ (p + (length ts) - 1) <= length L.
Proof.
  induction ts as [| d ts IHts ].
  { intros. false. }
  { intros p L Rdts _. inverts Rdts as. intros L0 T _t Rts Lnnil ? ?.
    destruct ts.
    - { (* ts = nil // interesting case *)
        destruct d; intros; subst. (* [d] must be a [One t] for the invariant to hold. *)
        - inv. false.
        - inv. unpack; subst. erewrite~ btree_length_correct. epow: reflexivity. }
    - { forwards IH: IHts Rts. congruence.
        destruct d; unpack; subst; rew_list in *.
        + epow: apply IH.
        + epow: rewrite IH. math. } }
Qed.

Lemma ts_bound : forall a ts p L,
    @inv a p ts L ->
    2 ^ (length ts) <= 2 * (length L) + 1.
Proof.
  destruct ts; rew_list; intros.
  { change (2^0) with 1. math. }
  { forwards I: inv_ts_len H. congruence.
    erewrite pow_r_eq in I; [| rew_list; ring_simplify; reflexivity].
    rew_pow~ 2 1. change (2^1) with 2.
    rew_pow~ 2 p in I. rewrite~ <-I.
    forwards~: pow2_ge_1 p. forwards~: Z.pow_nonneg 2 (length ts). math_nia. }
Qed.

Lemma ts_bound_log : forall a ts p L,
    @inv a p ts L ->
    length ts <= Z.log2 (2 * (length L) + 1).
Proof.
  intros. forwards~: ts_bound. forwards~: Z.log2_le_mono. rewrites~ Z.log2_pow2 in *.
Qed.

(* Useless *)
(*
Lemma p_bound_log : forall a ts p L,
    @inv a p ts L -> If ts <> nil then p <= Z.log2 (length L) else True.
Proof.
  introv Rts. forwards~ inv_bounds: inv_length_correct. case_If.
  - case_If. destruct inv_bounds as [I1 _].
    forwards~: Z.log2_le_mono. rewrites~ Z.log2_pow2 in *.
    inverts~ Rts.
  - auto.
Qed.
*)

(** Verification *)

Lemma empty_spec :
  forall a, Rlist (@empty a) (@nil a).
Proof. intros. rewrite (empty__cf a). constructors~. Qed.

Hint Extern 1 (RegisterSpec empty) => Provide empty_spec.

Lemma is_empty_spec :
  spec1 [cost]
    (forall a (l: rlist_ a),
     app is_empty [l]
       PRE (\$ cost tt)
       POST (fun (b: bool) => \[b = isTrue (l = nil)])).
Proof.
  xspecO_refine straight_line. xcf. xgo~.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec is_empty) => Provide (provide_specO is_empty_spec).

(* private *)
Lemma size_spec :
  spec1 [cost]
    (forall a (t: tree_ a),
     app size [t]
       PRE (\$ cost tt)
       POST (fun (n: int) => \[n = Size t])).
Proof.
  xspecO_refine straight_line. xcf. xgo~.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec size) => Provide (provide_specO size_spec).

Lemma link_spec :
  spec1 [cost]
    (forall a (t1 t2: tree_ a) p L1 L2,
     btree p t1 L1 -> btree p t2 L2 ->
     app link [t1 t2]
       PRE (\$ cost tt)
       POST (fun t' => \[btree (p+1) t' (L1 ++ L2)])).
Proof.
  xspecO_refine straight_line. xcf. xgo. constructors~.
  erewrite btree_size_correct in * by eauto. rewrite~ pow2_succ.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec link) => Provide (provide_specO link_spec).

Lemma cons_tree_spec_aux :
  specZ [cost \in_O (fun n => n)]
    (forall a (t: tree_ a) (ts: rlist_ a) p T L,
     btree p t T -> inv p ts L ->
     app cons_tree [t ts]
       PRE (\$ cost (length ts))
       POST (fun ts' => \[inv p ts' (T ++ L)])).
Proof.
  xspecO_refine recursive. intros ? ? ? ? a t ts. revert t.
  { induction ts; introv Rt Rts; inverts Rts; xcf.
    - weaken.
      xpay. xgo~.
      { constructors~. constructors~. }
      { rew_list. rewrite !Z.max_id. rewrite Z.add_0_r. defer. }
    - weaken. xpay.
      xmatch; unpack; subst.
      { xret. hsimpl. constructors~. }
      { xapps~. intros. xapps~. intros.
        xret. hsimpl. constructors~. rew_list~. }

    rew_cost. rew_list. generalize (length ts) (length_nonneg ts). defer. }

  close_cost. begin defer assuming a b.
  exists (fun n => a * n + b). repeat split.
  { ring_simplify. defer. }
  { introv HH. cancel z; case_max; defer. }

  cleanup_cost.
  { assert (0 <= a) by (deferred; math_lia). monotonic. }
  { dominated. }

  end defer. elia.
Qed.

Lemma cons_tree_spec_aux' :
  specZ [cost \in_O (fun n => n)]
    (forall a (t: tree_ a) (ts: rlist_ a) p T L,
     btree p t T -> inv p ts L ->
     app cons_tree [t ts]
       PRE (\$ cost (length ts))
       POST (fun ts' => \[inv p ts' (T ++ L)])).
Proof.
  begin defer assuming a b.
  xspecO (fun n => a * n + b). intros A t ts. revert t.
  { induction ts; introv Rt Rts; inverts Rts; xcf.
    - weaken.
      xpay. xgo~.
      { constructors~. constructors~. }
      { rew_list. rew_cost. defer. }
    - weaken. xpay.
      xmatch; unpack; subst.
      { xret. hsimpl. constructors~. }
      { xapps~. intros. xapps~. intros.
        xret. hsimpl. constructors~. rew_list~. }
      rew_list. rew_cost. cancel (length ts).
      all: case_max; auto with zarith; defer. }

  { assert (0 <= a) by (deferred; math_lia). monotonic. }
  { dominated. }

  end defer. elia.
Qed.

Lemma cons_tree_spec :
  specZ [ cost \in_O Z.log2 ]
    (forall a (t: tree_ a) (ts: rlist_ a) p T L,
     btree p t T -> inv p ts L ->
     app cons_tree [t ts]
       PRE (\$ cost (length L))
       POST (fun ts' => \[inv p ts' (T ++ L)])).
Proof.
  xspecO_refine straight_line. intros. weaken. xapplys~ cons_tree_spec_aux.
  apply cost_monotonic. rewrite~ ts_bound_log. generalize (length L). reflexivity.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec cons_tree) => Provide (provide_specO cons_tree_spec).

Lemma cons_spec :
  specZ [cost \in_O Z.log2]
    (forall a (x: a) (l: rlist_ a) L,
     Rlist l L ->
     app cons [x l]
       PRE (\$ cost (length L))
       POST (fun l' => \[Rlist l' (x::L)])).
Proof.
  xspecO_refine straight_line. xcf. xpay.
  weaken. xapp~. constructors~. hsimpl. rew_list~ in *.
  generalize (length L). reflexivity.
  cleanup_cost. (* FIXME: cleanup_cost should replace [cost cons_tree_spec] by its bound *)
  monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec cons) => Provide (provide_specO cons_spec).

Lemma uncons_tree_spec_aux :
  specZ [cost \in_O (fun n => n)]
    (forall a (ts: rlist_ a) p L,
     inv p ts L -> ts <> nil ->
     app uncons_tree [ts]
       PRE (\$ cost (length ts))
       POST (fun '(t', ts') =>
         \[exists T' L', btree p t' T' /\ inv p ts' L' /\ L = T' ++ L'])).
Proof.
  begin defer assuming a b. xspecO (fun n => a * n + b).
  induction ts as [| t ts']; introv Rts Ne; inverts Rts as.
  { xcf; xgo. }
  { introv ? I. intros. xcf. weaken. xpay. xmatch.
    { xcleanpat. inv. unpack; subst.
      xrets. exists. splits~. constructors~. rew_list~. }
    { forwards: inv_ts_not_empty I. congruence. xcleanpat.
      unpack; subst. xrets. exists. splits~. constructors~. }
    { xcleanpat. xapp~ as [t l]. intros; unpack; subst. xgo.
      - match goal with
        | B: btree _ (Node _ ?t1_ ?t2_) _, I: inv _ _ ?L_ |- _ =>
          rename t1_ into t1; rename t2_ into t2; rename L_ into L;
          inverts B
        end; subst.
        match goal with
        | H1: btree _ t1 ?L1_, H2: btree _ t2 ?L2_, E: (?p + 1) = (?p' + 1) |- _ =>
          rename L1 into L1; rename L2 into L2;
          maths (p = p'); clear E
        end; subst.
        eexists L1, (L2 ++ L). splits~. constructors~. rew_list~.
      - match goal with B: btree _ _ _ |- _ => inverts B end; subst.
        { math. } { jauto. } }

    rew_cost. rew_list. cancel (length ts'). all: case_max; defer. }

  { assert (0 <= a) by (deferred; math_lia). monotonic. }
  { dominated. }

  end defer. elia.
  Grab Existential Variables.  apply heap_is_gc. (* XXX *)
Qed.

Lemma uncons_tree_spec :
  specZ [cost \in_O Z.log2]
    (forall a (ts: rlist_ a) p L,
     inv p ts L -> ts <> nil ->
     app uncons_tree [ts]
       PRE (\$ cost (length L))
       POST (fun '(t', ts') =>
         \[exists T' L', btree p t' T' /\ inv p ts' L' /\ L = T' ++ L'])).
Proof.
  xspecO_refine straight_line. intros. weaken. xapplys~ uncons_tree_spec_aux.
  apply cost_monotonic. rewrite~ ts_bound_log. generalize (length L); reflexivity.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec uncons_tree) => Provide (provide_specO uncons_tree_spec).

Lemma head_spec :
  specZ [cost \in_O Z.log2]
    (forall a (l: rlist_ a) L,
     Rlist l L -> l <> nil ->
     app head [l]
       PRE (\$ cost (length L))
       POST (fun (x:a) => \[exists L', L = x :: L'])).
Proof.
  xspecO_refine straight_line. xcf. weaken. xpay. xapp~ as [t ts].
  intros (? & ? & B & I & ?); subst. xmatch.
  { xrets. inverts B. rew_list~. }
  { xfail. inverts* B; subst. forwards~: btree_size_pos. math. }
  rew_cost. generalize (length L); reflexivity.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec head) => Provide (provide_specO head_spec).

Lemma tail_spec :
  specZ [cost \in_O Z.log2]
    (forall a (l: rlist_ a) L,
     Rlist l L -> l <> nil ->
     app tail [l]
       PRE (\$ cost (length L))
       POST (fun tl => \[exists TL x, Rlist tl TL /\ L = x :: TL])).
Proof.
  xspecO_refine straight_line. xcf. weaken. xpay. xapp~ as [t ts].
  intros (? & ? & B & I & ?); subst. xmatch. xrets. inverts B; subst.
  { rew_list~ in *. }
  { forwards~: btree_size_pos. math. }
  rew_cost. generalize (length L); reflexivity.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec tail) => Provide (provide_specO tail_spec).

Lemma lookup_tree_spec :
  specZ [cost \in_O (fun n => n)]
    (forall a `{Inhab a} i (t: tree_ a) p L,
     btree p t L ->
     0 <= i < length L ->
     app lookup_tree [i t]
       PRE (\$ cost p)
       POST (fun x => \[ x = L[i] ])).
Proof.
  begin defer assuming a b. xspecO (fun n => a * n + b).
  intros a_ Ia i t. revert i.
  induction t; introv BT Bi; inverts BT; xcf.
  { weaken. xgo. subst. rewrite~ read_zero. rew_list~ in *.
    rew_cost. defer. }
  { weaken. xpay. xmatch. subst.
    match goal with B1: btree ?p _ _, B2: btree ?p _ _ |- _ =>
      forwards~: btree_length_correct B1; forwards~: btree_length_correct B2
    end. rew_list in Bi.
    xif; rewrites~ pow_succ_quot in *.
    { xapplys~ IHt1. rewrite read_app. case_if~. }
    { xapplys~ IHt2. rewrite read_app. case_if~.
      now match goal with H: length L1 = _ |- _ => rewrite H end. }

    rew_cost. subst. cancel p0. case_max; auto; defer. apply~ btree_size_pos.
    case_max; defer. }
  { assert (0 <= a) by (deferred; math_lia). monotonic. } { dominated. }
  end defer. elia.
Qed.

Hint Extern 1 (RegisterSpec lookup_tree) => Provide (provide_specO lookup_tree_spec).

Lemma update_tree_spec :
  specZ [cost \in_O (fun n => n)]
    (forall a `{Inhab a} i (x: a) (t: tree_ a) p L,
     btree p t L ->
     0 <= i < length L ->
     app update_tree [i x t]
       PRE (\$ cost p)
       POST (fun t' => \[btree p t' L[i := x]])).
Proof.
  begin defer assuming a b. xspecO (fun n => a * n + b).
  intros a_ Ia i x t. revert i x. induction t; introv BT Bi; inverts BT; xcf.
  { weaken. xgo~. subst. rewrite update_zero. constructors. now rew_list~ in *.
    rew_cost. defer. }
  { weaken. xpay. xmatch. subst. xcleanpat.
    match goal with B1: btree ?p _ _, B2: btree ?p _ _ |- _ =>
      forwards~: btree_length_correct B1; forwards~: btree_length_correct B2
    end. rew_list in Bi.
    xif; rewrites~ pow_succ_quot in *.
    { xapp_spec~ IHt1. intros. xret. hsimpl.
      rewrite~ update_app_l. constructors~. }
    { xapp_spec~ IHt2. intros. xret. hsimpl.
      erewrite~ update_app_r. constructors~. all: math. }

    rew_cost. subst. cancel p0. case_max; auto; defer. apply~ btree_size_pos.
    case_max; defer. }
  { assert (0 <= a) by (deferred; math). monotonic. } { dominated. }
  end defer. elia.
Qed.

Hint Extern 1 (RegisterSpec update_tree) => Provide (provide_specO update_tree_spec).

Definition product_positive_order :=
  product_filterType positive_filterType Z_filterType.

Lemma limit_positive_order_x_plus_y :
  limit product_positive_order Z_filterType (fun '(x,y) => x + y).
Proof.
  apply_nary (@limit_sum_ultimately_ge_l_nary 0).
  - apply ultimately_lift1. rewrite~ positiveP.
  - limit.
Qed.

Hint Resolve limit_positive_order_x_plus_y : limit.

Lemma limit_positive_0 :
  limit Z_filterType positive_filterType (fun _ => 0).
Proof.
  rewrite limitP. intros. rewrite positiveP, ZP in *.
  exists~ 0.
Qed.

Hint Resolve limit_positive_0 : limit.

(* XX *)
Ltac fold_product :=
  rewrite_strat (subterms (fold (product_filterType positive_filterType Z_filterType))).

Lemma dominated_positive_order_x_x_plus_y :
  dominated product_positive_order
    (fun '(x, y) => x) (fun '(x,y) => x + y).
Proof.
  apply_nary dominated_sum_r_nonneg_1_nary; fold_product.
  { (* ultimately_greater FIXME *)
    apply ultimately_lift1. rewrite~ positiveP. }
  { apply ultimately_lift2. ultimately_greater. }
  dominated.
Qed.

Hint Resolve dominated_positive_order_x_x_plus_y.

Lemma dominated_positive_order_y_x_plus_y :
  dominated product_positive_order
    (fun '(x, y) => y) (fun '(x,y) => x + y).
Proof.
  apply_nary dominated_sum_r_nonneg_2_nary; fold_product.
  { apply ultimately_lift1. rewrite~ positiveP. }
  { apply ultimately_lift2. ultimately_greater. }
  reflexivity.
Qed.

Hint Resolve dominated_positive_order_y_x_plus_y.

(* HACK HACK HACK

   - Partly because of https://github.com/coq/coq/issues/6805 which introduces
   buggy definitions in the context of side-goals spawned by setoid_rewrite;

   - Partly because we call [math] on one of these side-goals (through
   [auto_tilde] then [eauto with maths]), and CFML.CFTactics redefined [math_0]
   (called by math) to call [xclean] -- which in turns messes up with the buggy
   definition...
*)
Ltac math_0 ::=
  repeat (match goal with x := Morphisms.do_subrelation : _ |- _ => clear x end);
  xclean.

(* - est-ce qu'on sait prouver cette spec directement ? il semblerait que non *)
(* - est-ce que cette spec découle de la spec avec filtre produit ? oui! *)
(* - si on a cette spec, est-ce qu'on sait bien prouver la spec finale ?
     oui. (sans trop de surprise) *)
Definition lookup_spec_ind__external_forall :=
  forall p,
  0 <= p ->
  specO Z_filterType Z.le
    (fun cost =>
     forall a i (ts: rlist_ a) L,
     inv p ts L ->
     0 <= i < length L ->
     app lookup [i ts]
       PRE (\$ cost (length ts))
       POST (fun x => \[Nth (abs i) L x]))
    (fun n => n).

Definition lookup_spec_ind__nonstandard_product :=
  specO product_positive_order ZZle
    (fun cost =>
     forall a i (ts: rlist_ a) p L,
     inv p ts L ->
     0 <= i < length L ->
     app lookup [i ts]
       PRE (\$ cost (p, length ts))
       POST (fun x => \[Nth (abs i) L x]))
    (fun '(m,n) => m + n).

Definition lookup_spec__final :=
  specZ [cost \in_O Z.log2]
    (forall a i (ts: rlist_ a) L,
     Rlist ts L ->
     0 <= i < length L ->
     app lookup [i ts]
       PRE (\$ cost (length L))
       POST (fun x => \[Nth (abs i) L x])).

Goal lookup_spec_ind__nonstandard_product -> lookup_spec_ind__external_forall.
Proof.
  intro S.
  unfold lookup_spec_ind__external_forall, lookup_spec_ind__nonstandard_product in *.
  intros p NP.
  destruct S.
  eapply (@SpecO _ _ _ _ (fun len_ts => cost (p, len_ts))); auto.
  { monotonic. }
  { etransitivity.
    eapply dominated_comp_eq. apply cost_dominated.
    2: intros; reflexivity.
    { rewrite limitP. intros P UP. unfold product_positive_order in UP.
      rewrite productP in UP. destruct UP as (P1 & P2 & UP1 & UP2 & HH).
      rewrite positiveP, ZP in *. destruct UP2 as (n0 & HP2).
      exists (Z.max 0 n0). intros. apply HH. apply UP1. auto. apply HP2.
      eapply Z.max_lub_r. eauto. }
    { simpl. reflexivity. }
    dominated.
  }
Qed.

Goal lookup_spec_ind__external_forall -> lookup_spec__final.
Proof.
  intro S.
  unfold lookup_spec_ind__external_forall, lookup_spec__final in *.
  specializes S 0 __. xspecO (fun len_L => cost S (Z.log2 (2 * len_L + 1))).
  intros. weaken. xapplys~ S. apply cost_monotonic. rewrite~ ts_bound_log. math.
  monotonic.
  { etransitivity. apply dominated_comp. apply cost_dominated.
    unfold product_positive_order. limit. dominated. }
Qed.

Lemma lookup_spec_ind :
  specO product_positive_order ZZle
    (fun cost =>
     forall a `{Inhab a} i (ts: rlist_ a) p L,
     inv p ts L ->
     0 <= i < length L ->
     app lookup [i ts]
       PRE (\$ cost (p, length ts))
       POST (fun x => \[x = L[i]]))
    (fun '(m,n) => m + n).
Proof.
  xspecO_refine recursive. intros costf ? ? ?.
  intros a_ Ia i ts. revert i. induction ts; introv I Bi.
  { inv. math. }
  { inverts I. xcf. weaken. xpay. xmatch. { xapps~. }
    xcleanpat. unpack; subst. xapps~. xif.
    { xapps~. erewrite~ btree_size_length. math. hsimpl.
      rewrite read_app. case_if~.
      false. forwards~: btree_size_length b. }
    { xapps~. forwards~: btree_size_length. rew_list~ in *.
      xapps~. hsimpl. rewrite read_app. case_if~.
      now match goal with H: length T = _ |- _ => rewrite H end. }

    rew_list. rew_cost.
    asserts~ [HH1 HH2]: (0 <= p /\ 0 <= length ts).
    generalize p (length ts) HH1 HH2; defer. }

  close_cost.

  (* ici on est un peu triste car les équations de récurrence (et la solution
     qu'il faut deviner) sont polluées par les fonctions de coût opaques pour
     les fonctions auxiliaires.

     Mais on ne voit pas bien comment faire mieux.
   *)

  begin defer assuming a b c d.
  exists (fun '(m,n) => a * m + b * n + c * cost lookup_tree_spec (m+n) + d).
  repeat split.
  { intros m n Hm Hn. math_rewrite (m+(1+n) = m+1+n).
    rewrite~ (cost_monotonic lookup_tree_spec m (m+1+n)).
    cancel (cost lookup_tree_spec (m+1+n)). case_max; auto with zarith; defer.
    cancel m; cancel n. all: repeat case_max; auto with zarith. all: defer. }
  cleanup_cost.
  { intros [m n] [m' n'] [Hm Hn].
    assert (0 <= a /\ 0 <= b /\ 1 <= c) as (?&?&?) by (deferred; math_lia).
    forwards~ M: cost_monotonic lookup_tree_spec (m + n) (m' + n').
    rewrite~ M. auto with zarith. }

  repeat apply_nary dominated_sum_distr_nary;
    try apply_nary dominated_mul_cst_l_1_nary; dominated.
  eapply dominated_comp_eq with
    (J := Z_filterType) (p := fun '(t,x) => t + x).
  apply (cost_dominated lookup_tree_spec). limit.
  intros [? ?]. reflexivity. intros [? ?]. reflexivity.

  end defer. elia.
Qed.

Lemma lookup_spec :
  specZ [cost \in_O Z.log2]
    (forall a `{Inhab a} i (ts: rlist_ a) L,
     Rlist ts L ->
     0 <= i < length L ->
     app lookup [i ts]
       PRE (\$ cost (length L))
       POST (fun x => \[x = L[i]])).
Proof.
  xspecO (fun x => cost lookup_spec_ind (0, Z.log2 ((2 * x) + 1))).
  { intros. weaken. xapplys~ lookup_spec_ind.
    apply cost_monotonic. splits~. unfold Rlist in *. rewrite~ ts_bound_log.
    math. }

  { monotonic. }
  { etransitivity. apply dominated_comp. apply cost_dominated.
    unfold product_positive_order. limit. dominated. }
Qed.

Lemma update_spec_ind :
  specO product_positive_order ZZle (fun cost =>
    forall a `{Inhab a} i (x: a) (ts: rlist_ a) p L,
    inv p ts L ->
    0 <= i < length L ->
    app update [i x ts]
      PRE (\$ cost (p, length ts))
      POST (fun ts' => \[inv p ts' L[i := x]]))
  (fun '(m, n) => m + n).
Proof.
  xspecO_refine recursive. intros costf ? ? ?.
  intros a_ Ia i x ts. revert i x. induction ts; introv I Bi.
  { inv. math. }
  { inverts I; xcf. weaken. xpay.
    xmatch.
    { subst. xapps~. intros; unpack. xret~. hsimpl~. constructors~.
      intros Hnil. rewrite <-length_zero_eq_eq_nil in Hnil.
      now rewrite length_update in Hnil. }
    xapps~. unpack; subst.
    forwards~: btree_length_correct. forwards~: btree_size_correct.
    xif.
    { xapps~. intros. xret. hsimpl. rewrite~ update_app_l. constructors~. }
    { xapps~. xapps~. now rew_list~ in *. intros. xret. hsimpl.
      erewrite update_app_r with (i := 2^p). constructors~. all: math. }

    rew_list. rew_cost. asserts~ [HH1 HH2]: (0 <= p /\ 0 <= length ts).
    generalize p (length ts) HH1 HH2; defer. }

  close_cost.
  begin defer assuming a b c d.
  exists (fun '(m, n) => a*m + b*n + c*cost update_tree_spec (m+n) + d).
  split.
  { intros m n Hm Hn. math_rewrite (m+(1+n) = m+1+n).
    rewrite~ (cost_monotonic update_tree_spec m (m+1+n)).
    cancel (cost update_tree_spec (m+1+n)). case_max; auto with zarith; defer.
    cancel m; cancel n. all: repeat case_max. all: defer. }
  cleanup_cost.
  { intros [m n] [m' n'] [Hm Hn].
    assert (0 <= a /\ 0 <= b /\ 0 <= c) by (deferred; math_lia); unpack.
    forwards~ M: cost_monotonic update_tree_spec (m+n) (m'+n').
    auto with zarith. }

  repeat apply_nary dominated_sum_distr_nary;
    try apply_nary dominated_mul_cst_l_1_nary; dominated.
  eapply dominated_comp_eq with
    (J := Z_filterType) (p := fun '(t,x) => t + x).
  apply (cost_dominated update_tree_spec). limit.
  intros [? ?]. reflexivity. intros [? ?]. reflexivity.

  end defer. elia.
Qed.

Lemma update_spec :
  specZ [cost \in_O Z.log2]
    (forall a `{Inhab a} i (x: a) (ts: rlist_ a) L,
     Rlist ts L ->
     0 <= i < length L ->
     app update [i x ts]
       PRE (\$ cost (length L))
       POST (fun l' => \[Rlist l' L[i := x]])).
Proof.
  xspecO (fun x => cost update_spec_ind (0, Z.log2 ((2 * x) + 1))).
  { intros. weaken. xapplys~ update_spec_ind.
    apply cost_monotonic. splits~. rewrite~ ts_bound_log. math. }
  { monotonic. }
  { etransitivity. apply dominated_comp. apply cost_dominated.
    unfold product_positive_order. limit. dominated. }
Qed.

End BinaryRandomAccessListSpec.


Require Export Db.Lemmas.
Require Export StlcEqui.SpecSyntax.
Require Export StlcEqui.SpecEvaluation.
Require Export Coq.Program.Tactics.
Require Import Common.Common.
Require Import Common.Relations.

Require Import Lia.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     subst*);
  try discriminate;
  eauto with eval.

(* ** Evaluation contexts *)
Lemma ectx_cat (C₁ C₂: PCtx) :
  ECtx C₁ → ECtx C₂ → ECtx (pctx_cat C₁ C₂).
Proof.
  induction C₂; simpl; intros; destruct_conjs; auto.
Qed.

Lemma pctx_cat_app (t : Tm) (C₁ C₂ : PCtx) :
  pctx_app t (pctx_cat C₁ C₂) = pctx_app (pctx_app t C₁) C₂.
Proof.
  induction C₂; crush.
Qed.

Lemma eval_ctx C t t' (eC : ECtx C) :
  t --> t' -> pctx_app t C --> pctx_app t' C.
Proof.
  induction 1.
  rewrite <- ?pctx_cat_app in *.
  eauto using ectx_cat with eval.
Qed.

Lemma evalstar_ctx {t t'} C (eC: ECtx C) :
  t -->* t' → pctx_app t C -->* pctx_app t' C.
Proof.
  induction 1; eauto using eval_ctx with eval.
Qed.

Lemma evalplus_ctx C t t' (eC: ECtx C) :
  t -->+ t' → pctx_app t C -->+ pctx_app t' C.
Proof.
  induction 1; eauto using eval_ctx with eval.
Qed.

Lemma evaln_ctx {C t t' n} :
  ECtx C → evaln t t' n -> evaln (pctx_app t C) (pctx_app t' C) n.
Proof.
  intros ec.
  induction 1; unfold evaln; eauto using eval_ctx with eval.
Qed.

Lemma termination_closed_under_antireduction {t t'} :
  t --> t' → t'⇓ → t⇓.
Proof.
  destruct 2 as [v ?].
  exists v; crush.
Qed.

Lemma terminationN_closed_under_antireduction {t t' n} :
  t --> t' → TerminatingN t' n → TerminatingN t (S n).
Proof.
  destruct 2 as (v & m & ? & ? & ?).
  exists v, (S m); repeat split.
  - crush.
  - lia.
  - eapply stepRel_step; crush.
Qed.

Lemma termination_closed_under_antireductionStar {t t'} :
  t -->* t' → t'⇓ → t⇓.
Proof.
  intros e m. induction e;
  eauto using termination_closed_under_antireduction.
Qed.

Lemma value_ectx_inv C t (ec : ECtx C) :
  Value (pctx_app t C) → Value t.
Proof.
  intros v; induction C; crush.
Qed.

Lemma eval₀_ectx_inv C t (ec : ECtx C) {t' t''} :
  t'' -->₀ t' → t'' = pctx_app t C →
  Value t ∨ C = phole.
Proof.
  induction 1;
  destruct C; crush;
  try match goal with
      [ H : _ = pctx_app t C |- _ ] =>
      (assert (Value (pctx_app t C)) by (rewrite <- H; crush))
  end; eauto using value_ectx_inv.
Qed.

Lemma pctx_cat_phole_leftzero {C} :
  pctx_cat phole C = C.
Proof.
  induction C; crush; f_equal; crush.
Qed.

Lemma pctx_cat_assoc {C C' C''} :
  pctx_cat C (pctx_cat C' C'') = pctx_cat (pctx_cat C C') C''.
Proof.
  induction C''; crush; f_equal; crush.
Qed.

Lemma values_terminate {v : Tm} : Value v → v ⇓.
Proof.
  intros vv. exists v; crush.
Qed.

Definition normal' (t : Tm) := ∀ t', ¬ (t --> t').
Lemma values_are_normal' {t : Tm} : Value t -> normal' t.
Proof. induction 2 using eval_ind'; crush. Qed.

Lemma values_are_normal {t : Tm} : Value t -> normal t.
Proof.
  generalize @values_are_normal'.
  unfold normal, normal', not.
  intros ? ? t'; destruct t'; eauto.
Qed.

Lemma normal_evalStar {v t} : normal v -> v -->* t -> v = t.
Proof.
  intros nv [|t' ev ets]; [reflexivity|].
  exfalso; eapply nv; eauto.
Qed.

Lemma value_evalStar {v t} : Value v -> v -->* t -> v = t.
Proof.
  eauto using normal_evalStar, values_are_normal.
Qed.

Lemma values_terminateN {t n} : Value t → t ⇓_ n.
Proof.
  intros v. exists t, 0; repeat split.
  - crush.
  - lia.
  - eapply stepRel_zero.
Qed.

Section InvertECtxEq.

  Inductive EctxAppEq : ∀ (t : Tm) (C : PCtx) (t' : Tm) (C' : PCtx),  Prop :=
    | EctxAppEqLeft : ∀ t C C', ECtx C → EctxAppEq (pctx_app t C) C' t (pctx_cat C C')
    | EctxAppEqRight : ∀ t C C', ECtx C → EctxAppEq t (pctx_cat C C') (pctx_app t C) C'
    | ECtxValueLeft : ∀ t t' C C', Value t → EctxAppEq t C t' C'
    | ECtxValueRight : ∀ t t' C C', Value t' → EctxAppEq t C t' C'
  .

  Lemma ectxAppEqExtend {t C t' C'} C'' :
    EctxAppEq t C t' C' →
    EctxAppEq t (pctx_cat C C'') t' (pctx_cat C' C'').
  Proof.
    induction 1; rewrite <- ?pctx_cat_assoc; constructor; assumption.
  Qed.

  Lemma ectxAppEqExtendPAbs {t C t' C' τ} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pabs τ C) t' (pabs τ C').
  Proof.
    eapply (ectxAppEqExtend (pabs τ phole)).
  Qed.

  Lemma ectxAppEqExtendPInl {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pinl C) t' (pinl C').
  Proof.
    eapply (ectxAppEqExtend (pinl phole)).
  Qed.

  Lemma ectxAppEqExtendPInr {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pinr C) t' (pinr C').
  Proof.
    eapply (ectxAppEqExtend (pinr phole)).
  Qed.

  Lemma ectxAppEqExtendPProj₁ {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pproj₁ C) t' (pproj₁ C').
  Proof.
    eapply (ectxAppEqExtend (pproj₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPProj₂ {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pproj₂ C) t' (pproj₂ C').
  Proof.
    eapply (ectxAppEqExtend (pproj₂ phole)).
  Qed.

  Lemma ectxAppEqExtendPPair₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (ppair₁ C t₂) t' (ppair₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (ppair₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPPair₂ {t C t' C' t₁} :
    EctxAppEq t C t' C' →
    EctxAppEq t (ppair₂ t₁ C) t' (ppair₂ t₁ C').
  Proof.
    eapply (ectxAppEqExtend (ppair₂ t₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPApp₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (papp₁ C t₂) t' (papp₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (papp₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPApp₂ {t C t' C' t₁} :
    EctxAppEq t C t' C' →
    EctxAppEq t (papp₂ t₁ C) t' (papp₂ t₁ C').
  Proof.
    eapply (ectxAppEqExtend (papp₂ t₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPSeq₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pseq₁ C t₂) t' (pseq₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (pseq₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPIte₁ {t C t' C' t₂ t₃} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pite₁ C t₂ t₃) t' (pite₁ C' t₂ t₃).
  Proof.
    eapply (ectxAppEqExtend (pite₁ phole t₂ t₃)).
  Qed.

  Lemma ectxAppEqExtendPCaseof₁ {t C t' C' t₂ t₃} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pcaseof₁ C t₂ t₃) t' (pcaseof₁ C' t₂ t₃).
  Proof.
    eapply (ectxAppEqExtend (pcaseof₁ phole t₂ t₃)).
  Qed.

  Lemma ectxAppEqPHoleRight {t C} : ECtx C → EctxAppEq t C (pctx_app t C) phole.
  Proof.
    change C with (pctx_cat C phole); eauto using EctxAppEq.
  Qed.

  Lemma ectxAppEqPHoleLeft {t C} : ECtx C → EctxAppEq (pctx_app t C) phole t C.
  Proof.
    change C with (pctx_cat C phole); eauto using EctxAppEq.
  Qed.

  Lemma pctx_app_eq t C t' C' :
    ECtx C → ECtx C' →
    pctx_app t C = pctx_app t' C' →
    EctxAppEq t C t' C'.
  Proof.
    revert t' C';
    induction C; intros t' C' eC eC' eq';
    [simpl in *; subst;
     eauto using ectxAppEqPHoleLeft, ectxAppEqPHoleRight, EctxAppEq
    |idtac..];
    (destruct C';
      [change (pctx_app t' phole) with t' in *; subst;
       eauto using ectxAppEqPHoleLeft, ectxAppEqPHoleRight, EctxAppEq
      |idtac..]);
    crush;
    eauto using ectxAppEqExtendPAbs, ectxAppEqExtendPProj₂, ectxAppEqExtendPProj₁, ectxAppEqExtendPInr, ectxAppEqExtendPInl, ectxAppEqExtendPApp₁, ectxAppEqExtendPApp₂, ectxAppEqExtendPPair₁, ectxAppEqExtendPPair₂, ectxAppEqExtendPIte₁, ectxAppEqExtendPCaseof₁, ectxAppEqExtendPSeq₁;
    eauto using value_ectx_inv, ECtxValueRight, ECtxValueLeft.
  Qed.

End InvertECtxEq.

Lemma eval_ectx_inv C t (ec : ECtx C) {t' t''} :
  t'' --> t' → pctx_app t C = t'' →
  Value t ∨ exists t'', t' = pctx_app t'' C ∧ t --> t''.
Proof.
  induction 1.
  intros eq.
  pose proof (pctx_app_eq _ _ _ _ ec H0 eq) as inv.
  induction inv.
  - right.
    exists (pctx_app t' C).
    eauto using pctx_cat_app, eval_ctx₀.
  - destruct (eval₀_ectx_inv C t H1 H eq_refl); crush.
    right; exists t'.
    rewrite pctx_cat_phole_leftzero;
    eauto using (eval_ctx₀ phole).
  - left; crush.
  - exfalso.
    eapply (values_are_normal H1 t').
    eapply (eval_ctx₀ phole); crush.
Qed.

Lemma evalStar_ectx_inv C t (ec : ECtx C) v :
  pctx_app t C -->* v → Value v →
  exists v', Value v' ∧ t -->* v' ∧ pctx_app v' C -->* v.
Proof.
  intros es vv; depind es.
  - exists t; eauto using value_ectx_inv with eval.
  - destruct (eval_ectx_inv C t ec H eq_refl) as [vt|[t'' [eq e]]].
    + exists t; crush.
    + subst.
      destruct (IHes t'' C ec eq_refl vv) as (v' & vv' & es1' & es2').
      exists v'; crush.
Qed.

Lemma evaln_ectx_inv C t (ec : ECtx C) v n :
  evaln (pctx_app t C) v n → Value v →
  exists n' v', n' <= n /\ Value v' ∧ t -->* v' ∧ evaln (pctx_app v' C) v n'.
Proof.
  intros es vv; depind es.
  - exists 0, t; repeat split; eauto using value_ectx_inv, stepRel_zero with eval.
    eapply stepRel_zero.
  - destruct (eval_ectx_inv C t ec H eq_refl) as [vt|[t3 [eq e]]].
    + exists (S n), t; repeat split; eauto with eval.
      eapply stepRel_step; eauto.
    + subst.
      destruct (IHes t3 C ec eq_refl vv) as (n' & v' & nplen & vv' & es1' & es2').
      exists n', v'; repeat split; eauto with eval.
Qed.

Lemma inversion_termination_evalcontext C t (ec: ECtx C) :
  Terminating (pctx_app t C) → Terminating t.
Proof.
  destruct 1 as (v & vv & es).
  destruct (evalStar_ectx_inv C t ec v es) as (v' & vv' & es1 & es2); subst; crush.
  exists v'; crush.
Qed.

Corollary divergence_closed_under_evalcontext t :
  t⇑ → ∀ p, ECtx p → (pctx_app t p)⇑.
Proof. eauto using inversion_termination_evalcontext. Qed.

Corollary divergence_closed_under_evalcontext' {t C t'} :
  t⇑ → t' = pctx_app t C → ECtx C → t'⇑.
Proof. intros; subst; eauto using divergence_closed_under_evalcontext. Qed.

Ltac crushImpossibleEvals :=
  match goal with
          [ H : abs _ _ --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : true --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : false --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : unit --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : Value ?x, H' : ?x --> _ |- _ ] => exfalso; refine (values_are_normal' H _ H'); crush
        | [ Hx : Value ?x, Hy : Value ?y,  H' : pair ?x ?y --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H'); crush
        | [ Hx : Value ?x,  H' : inl ?x --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H'); crush
        | [ Hx : Value ?x,  H' : inr ?x --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H'); crush
  end.

Lemma TerminatingN_Terminating {t : Tm} {n} : t ⇓_ n -> t ⇓.
Proof.
  destruct 1 as (v & m & vv & ineq & es).
  exists v; eauto using stepRel_to_evalStar.
Qed.

Lemma evalStar_to_evaln {t t'} : t -->* t' → exists n, evaln t t' n.
Proof.
  induction 1.
  - exists 0; apply stepRel_zero.
  - destruct (IHclos_refl_trans_1n) as (n & en).
    exists (S n); eapply stepRel_step; crush.
Qed.

Lemma evaln_to_evalStar {t t' n} :
  evaln t t' n → t -->* t'.
Proof.
  induction 1; crush.
Qed.

(* Lemma ctxevaln_to_ctxevalStar {t t' n} : *)
(*   ctxevaln t t' n → ctxevalStar t t'. *)
(* Proof. *)
(*   induction 1; crush. *)
(* Qed. *)

(* (* The following implication is actually an equivalence, but we don't need that. *) *)
(* Lemma ctxeval_eval_ctx {t t'} : ctxeval t t' → forall Cu, ECtx Cu → pctx_app t Cu --> pctx_app t' Cu. *)
(* Proof. *)
(*   destruct 1; intros; rewrite <- ?pctx_cat_app; eauto using ectx_cat with eval. *)
(* Qed. *)

(* Lemma ctxevaln_ctx {t t' n} : *)
(*   ctxevaln t t' n -> forall C, ECtx C → evaln (pctx_app t C) (pctx_app t' C) n. *)
(* Proof. *)
(*   intros ec C eC; unfold evaln. *)
(*   induction ec; eauto using ctxeval_eval_ctx with eval. *)
(* Qed. *)

(* Lemma ctxevaln_evaln_ctx {t t' n} : ctxevaln t t' n → forall Cu, ECtx Cu → evaln (pctx_app t Cu) (pctx_app t' Cu) n. *)
(* Proof. *)
(*   induction 1; unfold evaln in *; *)
(*   econstructor; eauto using ctxeval_eval_ctx with eval. *)
(* Qed. *)

(* Lemma extend_ctxeval tu tu' Cu : ECtx Cu → ctxeval tu tu' → ctxeval (pctx_app tu Cu) (pctx_app tu' Cu). *)
(* Proof. *)
(*   intros eCu ce.  *)
(*   induction ce. *)
(*   rewrite <- ?pctx_cat_app. *)
(*   eauto using ctxeval, ectx_cat. *)
(* Qed. *)

(* Lemma extend_ctxevalStar {tu tu'} Cu : ECtx Cu → ctxevalStar tu tu' → ctxevalStar (pctx_app tu Cu) (pctx_app tu' Cu). *)
(* Proof. *)
(*   intros eCu ce.  *)
(*   unfold ctxevalStar. *)
(*   induction ce; *)
(*   eauto using extend_ctxeval with eval. *)
(* Qed. *)

(* Lemma ctxevalStar_evalStar {tu tu'} : ctxevalStar tu tu' → tu -->* tu'. *)
(* Proof. *)
(*   unfold ctxevalStar. *)
(*   induction 1; *)
(*   eauto using ctxeval_eval with eval. *)
(* Qed. *)

(* Lemma evalStar_ctxevalStar {tu tu'} : tu -->* tu' -> ctxevalStar tu tu'. *)
(* Proof. *)
(*   unfold ctxevalStar. *)
(*   induction 1; *)
(*   eauto using eval_ctxeval with eval. *)
(* Qed. *)

(* Lemma ctxevalStar_normal {tu tu'} : normal tu -> ctxevalStar tu tu' -> tu = tu'. *)
(* Proof. *)
(*   intros ntu eu. *)
(*   destruct eu as [|tu'' tu' eu]; try reflexivity. *)
(*   eapply ctxeval_eval in eu. *)
(*   exfalso. exact (ntu _ eu). *)
(* Qed. *)

(* This should hold, but doesn't? *)
Lemma Terminating_TerminatingN {t : Tm} : t ⇓ -> ∃ n, t ⇓_ n.
Proof.
  destruct 1 as (v & vv & es).
  destruct (evalStar_to_evaln es) as [n en].
  exists n; econstructor; crush.
Qed.

Lemma determinacy' {t t' t'' t'''} : t --> t' → t'' --> t''' → t = t'' → t' = t'''.
Proof.
  intros e₁.
  revert t'' t'''.
  induction e₁ using eval_ind';
  induction 1 using eval_ind'; crush; try crushImpossibleEvals.
Qed.

Lemma determinacy {t t' t''} : t --> t' → t --> t'' → t' = t''.
Proof.
  eauto using determinacy'.
Qed.

Lemma determinacyStar' {t1 t2 t3 t4} : t1 -->* t2 -> t3 -->* t4 -> t1 = t3 -> normal t4 -> t2 -->* t4.
Proof.
  intros e12. revert t3.
  induction e12 as [|x t5 t2 e15 e52]; intros t3 e34 -> n4; eauto.
  destruct e34 as [|t6 t4 e26 e64].
  - exfalso. eapply (n4 _ e15).
  - refine (IHe52 t6 e64 _ n4).
    eapply determinacy; eauto.
Qed.

Lemma determinacyStar {t1 t2 t4} : t1 -->* t2 -> t1 -->* t4 -> normal t4 -> t2 -->* t4.
Proof.
  eauto using determinacyStar'.
Qed.

(* Lemma determinacyStar_ctxeval {t1 t2 t4} : ctxevalStar t1 t2 -> ctxevalStar t1 t4 -> normal t4 -> ctxevalStar t2 t4. *)
(* Proof. *)
(*   eauto using evalStar_ctxevalStar, determinacyStar, ctxevalStar_evalStar. *)
(* Qed. *)

Lemma TerminatingD (t: Tm) (m: t⇓) :
  ∀ t', t --> t' → Terminating t'.
Proof.
  destruct m as (v & vv & es).
  destruct es;
  intros t' e; try crushImpossibleEvals.
  destruct (determinacy H e).
  exists z; crush.
Qed.

Lemma TerminatingDN (t: Tm) n (term: t ⇓_ (S n)) :
  ∀ t', t --> t' → TerminatingN t' n.
Proof.
  destruct term as (v & m & vv & ineq & esn).
  intros t' e.
  destruct esn; try crushImpossibleEvals.
  destruct (determinacy H e).
  exists t'', n0; repeat split.
  - crush.
  - lia.
  - crush.
Qed.

Lemma termination_closed_under_evalplus {t t'} :
  t -->+ t' → t⇓ → t'⇓.
Proof. intros e m; induction e; eauto using TerminatingD. Qed.

Lemma termination_closed_under_evalstar {t t'} :
  t -->* t' → t⇓ → t'⇓.
Proof. intros e m; induction e; eauto using TerminatingD. Qed.

Corollary divergence_closed_under_eval {t t'} :
  t --> t' → t'⇑ → t⇑.
Proof. eauto using TerminatingD with eval. Qed.

Corollary divergence_closed_under_evalplus {t t'} :
  t -->+ t' → t'⇑ → t⇑.
Proof. eauto using termination_closed_under_evalplus. Qed.

Corollary divergence_closed_under_evalstar {t t'} :
  t -->* t' → t'⇑ → t⇑.
Proof. eauto using termination_closed_under_evalstar. Qed.

Lemma cycles_dont_terminate {t} :
  t -->+ t → t⇑.
Proof.
  intros cycle.
  destruct 1 as (v & vv & ?).
  enough (forall t', t' -->+ t → t' -->* v → False) by eauto with eval.
  intros ? cycle'.
  induction 1 as [?|? ? ? e' ? IHes''];
    destruct (inversion_evalPlus cycle') as (? & cycleStart & ?).
  - refine (values_are_normal vv _ cycleStart).
  - rewrite <- ?(determinacy e' cycleStart) in *.
    eauto using IHes'', evalStarPlusToPlus.
Qed.

Lemma TerminatingN_lt {t n n'} :
  TerminatingN t n → n ≤ n' → TerminatingN t n'.
Proof.
  destruct 1 as (v & m & vv & ineq & esm).
  intros ineq'.
  exists v, m; repeat split; crush.
  lia.
Qed.

(* Lemma TerminatingN_eval1 {t t' n} : *)
(*   t --> t' → TerminatingN t' n → TerminatingN t (S n). *)
(* Proof. *)
(*   intros e term. *)
(*   destruct term as [v m]. *)
(*   apply (TerminatingIN t (S n) v (S m)); crush; try omega. *)
(*   eapply stepRel_step; crush. *)
(* Qed. *)

Lemma TerminatingN_eval {t t' n} :
  t --> t' → TerminatingN t' n ↔ TerminatingN t (S n).
Proof.
  intros term.
  split; intros;
  [eapply terminationN_closed_under_antireduction | eapply TerminatingDN];
  crush.
Qed.

Lemma TerminatingN_evaln {t t' n } n' :
  evaln t t' n → TerminatingN t' n' ↔ TerminatingN t (n + n').
Proof.
  induction 1; constructor; auto; intro term;
  change (S n + n') with (S (n + n')) in *;
  [rewrite <- (TerminatingN_eval H) | rewrite <- (TerminatingN_eval H) in term];
  apply IHstepRel; auto.
Qed.

Lemma evaln_split1 {t t' n} :
  evaln t t' (S n) → exists t'', eval t t'' ∧ evaln t'' t' n.
Proof.
  remember (S n) as n'.
  destruct 1; inversion Heqn'.
  subst.
  now exists t'.
Qed.

Lemma evaln_split {t t' } n n':
  evaln t t' (n + n') → exists t'', evaln t t'' n ∧ evaln t'' t' n'.
Proof.
  revert t; induction n.
  - intros; exists t; simpl in *; split; [apply stepRel_zero|assumption].
  - intros t esn.
    destruct (evaln_split1 esn) as (t'' & es & esn').
    destruct (IHn t'' esn') as (t3 & es1 & es2).
    exists t3; split; try assumption.
    eapply stepRel_step; crush.
Qed.

Lemma TerminatingN_xor_evaln {t t' n} :
  TerminatingN t n → evaln t t' (S n) → False.
Proof.
  intros term esn.
  replace (S n) with (n + 1) in esn by lia.
  destruct (evaln_split n 1 esn) as (t'' & en & e1).
  replace n with (n + 0) in term by lia.
  rewrite <- (TerminatingN_evaln 0 en) in term.
  destruct term as (v & m & vv & ineq & esm).
  assert (m = 0) by lia; subst.
  inversion esm; subst.
  inversion e1.
  crushImpossibleEvals.
Qed.

Section EvalInContext.
  Lemma eval₀_to_eval {t t'} :
    t -->₀ t' →
    t --> t'.
  Proof.
    intros e₀.
    change (t --> t') with (pctx_app t phole --> pctx_app t' phole).
    eapply (eval_ctx₀ phole); crush.
  Qed.

  Lemma eval_from_eval₀ {t t' t₀ t₀' C} :
    t₀ -->₀ t₀' →
    t = pctx_app t₀ C →
    t' = pctx_app t₀' C →
    ECtx C →
    t --> t'.
  Proof.
    intros; subst; eauto using eval_ctx₀.
  Qed.

  Lemma evalstar_ctx' {t t' t₀ t₀' C} :
    t₀ -->* t₀' →
    t = pctx_app t₀ C →
    t' = pctx_app t₀' C →
    ECtx C →
    t -->* t'.
  Proof.
    intros; subst; eauto using evalstar_ctx.
  Qed.

End EvalInContext.

Ltac inferContext :=
  cbn; try reflexivity;
  let rec inferC acc t t₀ :=
      match t with
        | t₀ => instantiate (1 := acc)
        | app ?t1 ?t2 => inferC (pctx_cat (papp₁ phole t2) acc) t1 t₀ + inferC (pctx_cat (papp₂ t1 phole) acc) t2 t₀
        | pair ?t1 ?t2 => inferC (pctx_cat (ppair₁ phole t2) acc) t1 t₀ + inferC (pctx_cat (ppair₂ t1 phole) acc) t2 t₀
        | seq ?t1 ?t2 => inferC (pctx_cat (pseq₁ phole t2) acc) t1 t₀
        | inl ?t1 => inferC (pctx_cat (pinl phole) acc) t1 t₀
        | inr ?t1 => inferC (pctx_cat (pinr phole) acc) t1 t₀
        | ite ?t1 ?t2 ?t3 => inferC (pctx_cat (pite₁ phole t2 t3) acc) t1 t₀
        | caseof ?t1 ?t2 ?t3 => inferC (pctx_cat (pcaseof₁ phole t2 t3) acc) t1 t₀
        | proj₁ ?t1 => inferC (pctx_cat (pproj₁ phole) acc) t1 t₀
        | proj₂ ?t1 => inferC (pctx_cat (pproj₂ phole) acc) t1 t₀
        | pctx_app t₀ ?C => instantiate (1 := pctx_cat C acc)
        | pctx_app ?t1 (pctx_cat ?C1 ?C2) => inferC (pctx_app (pctx_app t1 C1) C2) t₀
        | pctx_app ?t1 ?C => inferC (pctx_cat C acc) t1 t₀
      end
  in repeat match goal with
              | [ |- ?t = pctx_app ?t₀ (pctx_cat ?C1 ?C2) ] => (rewrite -> ?pctx_cat_app)
              | [ |- pctx_app ?t0 ?C = pctx_app ?t' ?C ] => f_equal
              | [ |- ?t = pctx_app ?t₀ ?C ] => (inferC phole t t₀; rewrite -> ?pctx_cat_app; cbn; rewrite -> ?pctx_cat_app in *; reflexivity)
            end.

Lemma test_inferContext (t : Tm) (C' : PCtx): True.
Proof.
  assert (pctx_app (pair (inl t) (inr unit)) C' = pctx_app t (pctx_cat (ppair₁ (pinl phole) (inr unit)) C')).
  inferContext.
  trivial.
Qed.

Ltac crushStlcEval :=
  match goal with
      [ |- ECtx (pctx_cat _ _) ] => eapply ectx_cat
    | [ |- ECtx (papp₁ _ _) ] => unfold ECtx
    | [ |- ECtx (papp₂ _ _) ] => unfold ECtx
    | [ |- ECtx (pinl _) ] => unfold ECtx
    | [ |- ECtx (pinr _) ] => unfold ECtx
    | [ |- ECtx phole ] => unfold ECtx
    | [ |- ECtx (pcaseof₁ _ _ _) ] => unfold ECtx
  end.


(*
We define an Indexed W type by five pieces of data.
First, we have two pieces that are the same as regular W types:
Data : Type
  The type of data carried by each node, traditionally A
Children : Data -> Type
  The children of a node with data x are named by (Children x).
  Traditionally B.
Then we specify the indices:
Index : Type
  The type of indices
index : Data -> Index
  A node with data x has is labeled (index x)
child_index : forall x : Data, Children x -> Index
  Child c : Children x is labeled (child_index x c)

The Indexed W type is a type family carrier : Index -> Type,
along with a constructor
sup : forall x : Data, (forall c : Children x, carrier (child_index x c)) ->
      carrier (index x)
We then require sup to satisfy an appropriate dependent induction principle.

Note that regular W types are a subset of Indexed W types, obtained by
setting Index = unit.
*)

From IWTypes Require Import FunctionExtensionality.

Record spec := {
  Data : Type;
  Children : Data -> Type;
  Index : Type;
  index : Data -> Index;
  child_index : forall x, Children x -> Index;
}.
Arguments Data S : rename.
Arguments Children {S} x : rename.
Arguments Index S : rename.
Arguments index {S} x : rename.
Arguments child_index {S} x c : rename.

Record impl {S : spec} := {
  carrier : Index S -> Type;
  sup :
    forall x : Data S,
    (forall (c : Children x), carrier (child_index x c)) ->
    carrier (index x);
  induct :
    forall (P : forall i, carrier i -> Type),
    (forall x children, (forall c, P _ (children c)) ->
     P _ (sup x children)) ->
    forall i m, P i m;
  induct_computes :
    forall P IS,
    forall x children,
    induct P IS _ (sup x children) =
    IS x children (fun c => induct P IS _ (children c));
}.
Arguments impl S : clear implicits.

Module unique.
Section unique.
(* We prove that the implementation of a spec is unique up to equivalence. *)

Context {FunExt : FunExt}.
Context {S} {I1 I2 : impl S}.

Definition I1_to_I2 : forall i, carrier I1 i -> carrier I2 i
  := induct I1
     (fun i _ => carrier I2 i)
     (fun x children IH => sup I2 x IH).

Definition I2_to_I1 : forall i, carrier I2 i -> carrier I1 i
  := induct I2
     (fun i _ => carrier I1 i)
     (fun x children IH => sup I1 x IH).

Definition I1_to_I2_sup
  : forall x children,
    I1_to_I2 _ (sup I1 x children) =
    sup I2 x (fun c => I1_to_I2 _ (children c))
  := induct_computes I1 _ _.

Definition I2_to_I1_sup
  : forall x children,
    I2_to_I1 _ (sup I2 x children) =
    sup I1 x (fun c => I2_to_I1 _ (children c))
  := induct_computes I2 _ _.

Definition I1_to_I2_to_I1_id
  : forall i m, I2_to_I1 i (I1_to_I2 i m) = m
  := induct I1
     (fun i m => I2_to_I1 i (I1_to_I2 i m) = m)
     (fun x children IH => eq_trans (eq_trans
      (f_equal (I2_to_I1 _) (I1_to_I2_sup _ _))
      (I2_to_I1_sup _ _))
      (f_equal (sup I1 x) (funext IH))).

(* The reverse holds by symmetry, so the two implementations are equivalent. *)

End unique.
End unique.

Module concrete.
Section concrete.
(* We prove that every spec has an implementation. *)

Context (S : spec).

Inductive IW : Index S -> Type
  := IWsup :
       forall (x : Data S) (children : forall c, IW (child_index x c)),
       IW (index x).

Definition IWinduct
  (P : forall i, IW i -> Type)
  (IS :
    forall x children, (forall c, P _ (children c)) ->
    P _ (IWsup x children))
  : forall i m, P i m
  := fix induct i (m : IW i) : P i m := match m with
     | IWsup x children => IS x children (fun c => induct _ (children c))
     end.
Definition IWcomputes P IS x children
  : IWinduct P IS _ (IWsup x children) =
    IS x children (fun c => IWinduct P IS _ (children c))
  := eq_refl.
Definition IWsat : impl S
  := Build_impl S IW IWsup IWinduct IWcomputes.

(*
With the above module unique,
this shows that every spec has a unique implementation.
With univalence, you probably have that impl S is contractable.
*)

End concrete.
Arguments IWsup {S} x children.
End concrete.


(** *)

Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Setoids.Setoid.

(** *)

Class POp_PartialOp
    {set : Type}
    (defined : relation set)
    {eq : relation set}
    (Eq : Equivalence eq)
    :=
        POp_buildPartialOp {

(** *)

            POp_set := set;
            POp_defined := defined;
            POp_eq := eq;
            POp_Equivalence := Eq;

(** *)

            POp_operator : forall x y : set, defined x y -> set
        }.

(** *)

Arguments POp_buildPartialOp {_ _ _} _ _ .

(** *)

Arguments POp_set {_ _ _ _} _ .
Arguments POp_defined {_ _ _ _} _ _ _.
Arguments POp_eq {_ _ _ _} _ _ _.
Arguments POp_Equivalence {_ _ _ _} _.
Arguments POp_operator {_ _ _ _} _ _ _ _.

(** *)

Generalizable Variables set defined eq Eq.

(** *)

Coercion POp_operator : POp_PartialOp >-> Funclass.

(** *)

Lemma POp_irrelevance
    `(Op : POp_PartialOp)
    : forall x y xy xy',
          POp_eq Op (Op x y xy) (Op x y xy').
(* begin hide *)
Proof.
    intros x y x_y_defined x_y_defined'.
    assert (irrelevance : x_y_defined = x_y_defined').
    now apply proof_irrelevance.
    now rewrite irrelevance.
Qed.
(* end hide *)

(** *)

Class POp_Commutative
    `(Op : POp_PartialOp)
    : Prop
    :=
        POp_buildCommutative {

(** *)

            POp_Commutative_PartialOp := Op;

(** *)

            POp_commutativity1 :
                forall x y,
                    POp_defined Op x y -> POp_defined Op y x;

(** *)

            POp_commutativity2 :
                forall x y,
                    POp_defined Op y x -> POp_defined Op x y;

(** *)

            POp_commutativity3 :
                forall x y xy,
                    POp_eq _ (Op x y xy) (Op y x (POp_commutativity1 x y xy))
        }.

(** *)

Arguments POp_buildCommutative {_ _ _ _} _ _ _ _.

(** *)

Arguments POp_Commutative_PartialOp {_ _ _ _ _} _.
Arguments POp_commutativity1 {_ _ _ _ _} _ _ _ _.
Arguments POp_commutativity2 {_ _ _ _ _} _ _ _ _.
Arguments POp_commutativity3 {_ _ _ _ _} _ _ _ _.

(** *)

Generalizable Variables Op.

(** *)

Coercion POp_Commutative_PartialOp : POp_Commutative >-> POp_PartialOp.

(** *)

Class POp_Associative
    `(Op : POp_PartialOp)
    : Prop
    :=
        POp_buildAssociative {

(** *)

            POp_Associative_PartialOp := Op;

(** *)

            POp_associativity1 :
                forall x y z xy, POp_defined _ (Op x y xy) z ->
                    forall yz, POp_defined _ x (Op y z yz);

            POp_associativity2 :
                forall x y z yz, POp_defined _ x (Op y z yz) ->
                    forall xy, POp_defined _ (Op x y xy) z;

(** *)

            POp_associativity3 :
              forall x y z xy yz xyz,
                      POp_eq _ (Op x (Op y z yz) xyz)
                          (Op (Op x y xy) z (POp_associativity2 x y z yz xyz xy))
        }.


Require Import Classical Tac.
Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms
  Coq.Classes.SetoidTactics Coq.Program.Basics.
Require Export Coq.Sets.Classical_sets.

Import ProperNotations.

Create HintDb ens discriminated.

Arguments In {_} _ _.
Arguments Included {_} _ _.
Arguments Empty_set {_} _.
Arguments Full_set {_} _.
Arguments Singleton {_} _ _.
Arguments Union {_} _ _ _.
Arguments Add {_} _ _ _.
Arguments Intersection {_} _ _ _.
Arguments Couple {_} _ _ _.
Arguments Triple {_} _ _ _ _.
Arguments Complement {_} _ _.
Arguments Setminus {_} _ _ _.
Arguments Subtract {_} _ _ _.
Arguments Disjoint {_} _ _.
Arguments Inhabited {_} _.
Arguments Strict_Included {_} _ _.
Arguments Same_set {_} _ _.

Hint Unfold In Included Add Complement Setminus Subtract Strict_Included
  Same_set : ens.
Hint Constructors Full_set Singleton Union Intersection Couple Triple Disjoint
  Inhabited : ens.

(* -------------------------------------------------------------------------- *)
(* Properties of Same_set *)

Instance Same_set_reflexive {U} : Reflexive (@Same_set U).
Proof. red. auto with ens. Qed.

Instance Same_set_symmetric {U} : Symmetric (@Same_set U).
Proof. red. auto with ens. Qed.

Instance Same_set_transitive {U} : Transitive (@Same_set U).
Proof. red. unfold Same_set. intuition (auto with ens). Qed.

Instance Same_set_Equivalence {U} : Equivalence (@Same_set U).
Proof. typeclass. Qed.

Instance subrelation__Same_set__Included U :
  subrelation (@Same_set U) (@Included U).
Proof. red. unfold Same_set. auto. Qed.

Instance subrelation__Same_set__flip_Included U :
  subrelation (@Same_set U) (flip (@Included U)).
Proof. red. unfold Same_set. auto. Qed.

(* -------------------------------------------------------------------------- *)
(* Properties of Strict_Included *)

Instance Strict_Included_irreflexive {U} : Irreflexive (@Strict_Included U).
Proof. red. red. unfold complement. introv Hcontra. inverts Hcontra. false. Qed.

Instance Strict_Included_transitive {U} : Transitive (@Strict_Included U).
Proof.
  red. unfold Same_set. unfold Strict_Included. introv Hxy Hyz. norm_hyp_auto.
  split.
  - intuition (auto with ens).
  - intro. subst.
    assert (y = z) by (apply Extensionality_Ensembles; auto with ens). false.
Qed.

Instance Strict_Included_Strict_Order {U} : StrictOrder (@Strict_Included U).
Proof. typeclass. Qed.

(* -------------------------------------------------------------------------- *)
(* Properties of Included *)

Instance subrelation__Strict_Included__Included {U} :
  subrelation (@Strict_Included U) (@Included U).
Proof. red. auto with ens. Qed.

Instance Included_reflexive {U} : Reflexive (@Included U).
Proof. auto with ens. Qed.

Instance Included_transitive {U} : Transitive (@Included U).
Proof. red. unfold Same_set. intuition (auto with ens). Qed.

Instance Included_antisymmetric {U} :
  Antisymmetric (Ensemble U) (@Same_set U) (@Included U).
Proof. red. unfold Same_set; auto. Qed.

Instance Included_PreOrder {U} : PreOrder (@Included U).
Proof. typeclass. Qed.

Instance Included_PartialOrder {U} : PartialOrder (@Same_set U) (@Included U).
Proof. typeclass. Qed.

(* -------------------------------------------------------------------------- *)
(* Properties of Union *)

Lemma Union_sym :
  forall U (A B : Ensemble U),
  Same_set (Union A B) (Union B A).
Proof. split; red; introv H; inverts H; auto with ens. Qed.

Lemma Union_neutral_r :
  forall U (A : Ensemble U),
  Same_set (Union A Empty_set) A.
Proof.
  split; red; introv H.
  - inverts1 H; [assumption | inverts H].
  - auto with ens.
Qed.

Lemma Union_neutral_l :
  forall U (A : Ensemble U),
  Same_set (Union Empty_set A) A.
Proof. intros. rewrite Union_sym. apply Union_neutral_r. Qed.

Lemma Union_absorption_r :
  forall U (A : Ensemble U),
  Same_set (Union A Full_set) Full_set.
Proof. split; red; introv H; [inverts H|]; auto with ens. Qed.

Lemma Union_absorption_l :
  forall U (A : Ensemble U),
  Same_set (Union Full_set A) Full_set.
Proof. intros. rewrite Union_sym. apply Union_absorption_r. Qed.

Lemma Union_same :
  forall U (A : Ensemble U),
  Same_set (Union A A) A.
Proof. split; red; introv H; [inverts H|]; auto with ens. Qed.

(* -------------------------------------------------------------------------- *)
(* Properties of Intersection *)

Lemma Intersection_sym :
  forall U (A B : Ensemble U),
  Same_set (Intersection A B) (Intersection B A).
Proof. split; introv H; inverts H; auto with ens. Qed.

Lemma Intersection_neutral_r :
  forall U (A : Ensemble U),
  Same_set (Intersection A Full_set) A.
Proof. split; red; introv H; [inverts H|]; auto with ens. Qed.

Lemma Intersection_neutral_l :
  forall U (A : Ensemble U),
  Same_set (Intersection Full_set A) A.
Proof. intros. rewrite Intersection_sym. apply Intersection_neutral_r. Qed.

Lemma Intersection_absorption_r :
  forall U (A : Ensemble U),
  Same_set (Intersection A Empty_set) Empty_set.
Proof. split; red; introv H; inverts H; auto. Qed.

Lemma Intersection_absorption_l :
  forall U (A : Ensemble U),
  Same_set (Intersection Empty_set A) Empty_set.
Proof. intros. rewrite Intersection_sym. apply Intersection_absorption_r. Qed.

Lemma Intersection_same :
  forall U (A : Ensemble U),
  Same_set (Intersection A A) A.
Proof. split; red; introv H; [inverts H|]; auto with ens. Qed.

(* -------------------------------------------------------------------------- *)
(* Properties of Disjoint *)

Instance Disjoint_symmetric {U} : Symmetric (@Disjoint U).
Proof.
  introv H. inverts1 H. constructor. intro a. specialize H with a.
  contradict H. inverts H; auto with ens.
Qed.

(* -------------------------------------------------------------------------- *)
(* Morphisms *)

Instance morph__In__Same_set {U} :
  Proper (Same_set ==> eq ==> iff) (@In U).
Proof.
  unfold Proper, respectful. introv Heqset Heq. subst. inverts Heqset.
  intuition (auto with ens).
Qed.

Instance morph__Included__Same_set {U} :
  Proper (eq ==> Same_set ==> iff) (@Included U).
Proof.
  unfold Proper, respectful. introv Heq Heqset. subst. inverts Heqset.
  intuition.
Qed.

Instance morph__Union__Included {U} :
  Proper (Included ==> Included ==> Included) (@Union U).
Proof. unfold Proper, respectful. introv H1 H2 H. inverts H; auto with ens. Qed.

Instance morph__Union__Same_set {U} :
  Proper (Same_set ==> Same_set ==> Same_set) (@Union U).
Proof.
  unfold Proper, respectful. introv H1 H2.
  inversion H1 as [H11 H12]; inversion H2 as [H21 H22]; split.
  - rewrite H11, H21. reflexivity.
  - rewrite H12, H22. reflexivity.
Qed.

Instance morph__Add__Included {U} :
  Proper (Included ==> eq ==> Included) (@Add U).
Proof. unfold Add. solve_proper. Qed.

Instance morph__Add__Same_set {U} :
  Proper (Same_set ==> eq ==> Same_set) (@Add U).
Proof. unfold Add. solve_proper. Qed.

Instance morph__Intersection__Same_set {U} :
  Proper (Same_set ==> Same_set ==> Same_set) (@Intersection U).
Proof.
  unfold Proper, respectful, Same_set, Included. split; introv tmp;
    inverts tmp; intuition (auto with ens).
Qed.

Instance morph__Complement__Same_set {U} :
  Proper (Same_set ==> Same_set) (@Complement U).
Proof.
  unfold Proper, respectful. repeat autounfold with ens. iauto.
Qed.

Instance morph__Setminus__Same_set {U} :
  Proper (Same_set ==> Same_set ==> Same_set) (@Setminus U).
Proof.
  unfold Proper, respectful. repeat autounfold with ens. iauto.
Qed.

Instance morph__Subtract__Same_set {U} :
  Proper (Same_set ==> eq ==> Same_set) (@Subtract U).
Proof. unfold Subtract. solve_proper. Qed.

Instance morph__Disjoint__Same_set {U} :
  Proper (Same_set ==> Same_set ==> iff) (@Disjoint U).
Proof.
  unfold Proper, respectful.
  split; introv tmp; inverts tmp; constructor; intros;
    [rewrite <- H, <- H0 | rewrite H, H0]; auto.
Qed.

Instance morph__Inhabited__Same_set {U} :
  Proper (Same_set ==> iff) (@Inhabited U).
Proof.
  unfold Proper, respectful. split; introv tmp; inverts tmp; econstructor;
    [rewrite <- H | rewrite H]; eassumption.
Qed.

(* -------------------------------------------------------------------------- *)
(* Misc. Lemmas *)

Lemma not_Included__counterexample :
  forall U (A B : Ensemble U),
  ~ Included A B <->
  exists x, In A x /\ ~ In B x.
Proof.
  split.
  - introv Hnincl. unfold Included in Hnincl.
    rewrite not_forall__exists_not in Hnincl. inverts Hnincl.
    apply imply_to_and in H. eauto.
  - introv Hex Hcontra. norm_hyp_auto. auto with sets.
Qed.

Lemma not_Same_set__not_Included :
  forall U (A B : Ensemble U),
  ~ Same_set A B <->
  ~ Included A B \/ ~ Included B A.
Proof.
  split; introv H.
  - rewrite <- not_and__or. eauto.
  - rewrite <- not_and__or in H. auto with ens.
Qed.

Lemma not_Same_set__counterexample :
  forall U (A B : Ensemble U),
  ~ Same_set A B <->
  exists x, (In A x /\ ~ In B x) \/ (~ In A x /\ In B x).
Proof.
  split; introv H.
  - apply not_Same_set__not_Included in H. destruct H;
      apply not_Included__counterexample in H; eauto 10.
  - introv Hcontra. inverts1 Hcontra. destruct H as [? H]. destruct H; eauto.
Qed.

Lemma counterexample__not_Same_set__l :
  forall U (A B : Ensemble U) x,
  In A x /\ ~ In B x ->
  ~ Same_set A B.
Proof. introv H. apply not_Same_set__counterexample; eauto. Qed.

Lemma counterexample__not_Same_set__r :
  forall U (A B : Ensemble U) x,
  In B x /\ ~ In A x ->
  ~ Same_set A B.
Proof. introv H. apply not_Same_set__counterexample; eauto 10. Qed.

Lemma in_disjoint_union_inv :
  forall U (A B : Ensemble U) x,
  Disjoint A B ->
  In (Union A B) x ->
  (In A x /\ ~ In B x) \/ (~ In A x /\ In B x).
Proof.
  introv Hdis Hin. inverts1 Hdis. specialize Hdis with x.
  destruct (classic (In A x)); destruct (classic (In B x)); auto.
  - contradict Hdis. auto with ens.
  - inverts Hin; auto.
Qed.

Lemma disjoint_union__Setminus__r :
  forall U (A B : Ensemble U),
  Disjoint A B ->
  Same_set (Setminus (Union A B) B) A.
Proof.
  introv Hdis. inverts Hdis. split; red; introv Hin.
  - inversion Hin as [Hunion HB]. inverts Hunion; [assumption | false].
  - constructor.
    * auto with ens.
    * specialize H with x. contradict H. auto with ens.
Qed.

Lemma disjoint_union__Setminus__l :
  forall U (A B : Ensemble U),
  Disjoint A B ->
  Same_set (Setminus (Union A B) A) B.
Proof.
  intros. rewrite Union_sym. apply disjoint_union__Setminus__r.
  symmetry. assumption.
Qed.

Lemma disjoint_union_injective_r :
  forall U (A B B' : Ensemble U),
  Disjoint A B ->
  Disjoint A B' ->
  Same_set (Union A B) (Union A B') ->
  Same_set B B'.
Proof.
  introv Hdis Hdis' Heq.
  rewrite <- (disjoint_union__Setminus__l _ A B),
          <- (disjoint_union__Setminus__l _ A B'); [|assumption..].
  rewrite Heq. reflexivity.
Qed.

Lemma disjoint_union_injective_l :
  forall U (A A' B : Ensemble U),
  Disjoint A B ->
  Disjoint A' B ->
  Same_set (Union A B) (Union A' B) ->
  Same_set A A'.
Proof.
  introv Hdis Hdis' H. rewrite_strat (subterms Union_sym) in H.
  symmetry in Hdis, Hdis'. eapply disjoint_union_injective_r; eauto.
Qed.

Lemma Empty_or_Inhabited :
  forall U (A : Ensemble U),
  Same_set A Empty_set \/ Inhabited A.
Proof.
  intros. destruct (classic (exists x, In A x)) as [H | H].
  - right. inverts H. econstructor; eassumption.
  - left. unfold Same_set. split.
    * unfold Included. introv Hcontra. contradict H. eauto.
    * apply Included_Empty.
Qed.

Lemma disjoint_union__Same_set__inv_l :
  forall U (A A' B B' : Ensemble U),
  Disjoint A B' ->
  Disjoint B A' ->
  Same_set (Union A B) (Union A' B') ->
  Same_set A A'.
Proof.
  introv Hdis Hdis' Heq. split; red; introv H.
  * assert (In (Union A' B') x) as tmp by (rewrite <- Heq; auto with ens).
    inverts1 tmp.
    + assumption.
    + inverts1 Hdis. contradict Hdis; eauto with ens.
  * assert (In (Union A B) x) as tmp by (rewrite Heq; auto with ens).
    inverts1 tmp.
    + assumption.
    + inverts1 Hdis'. contradict Hdis'; eauto with ens.
Qed.

Lemma disjoint_union__Same_set__inv_r :
  forall U (A A' B B' : Ensemble U),
  Disjoint A B' ->
  Disjoint B A' ->
  Same_set (Union A B) (Union A' B') ->
  Same_set B B'.
Proof.
  intros until 0. intros ? ? Heq. rewrite_strat (subterms Union_sym) in Heq.
  eapply disjoint_union__Same_set__inv_l; eauto.
Qed.

Lemma disjoint_union__Same_set__inv :
  forall U (A A' B B' : Ensemble U),
  Disjoint A B' ->
  Disjoint B A' ->
  Same_set (Union A B) (Union A' B') ->
  Same_set A A' /\ Same_set B B'.
Proof.
  split; eauto using disjoint_union__Same_set__inv_l,
    disjoint_union__Same_set__inv_r.
Qed.


Require Import Classical ClassicalFacts.
Require Import Reals.
Require Import micromega.Lra.

(*
****************************************************************************************
This file develops the tactics `push_neg` and `contrapose` which are inspired by similar
tactics available in Lean's mathlib library.

* `push_neg` and `push_neg_in` push negations into hypotheses containing nested
  quantifiers.

 For example, if we have a hypothesis like this in the local context:

 (H : ~ (forall ϵ:posreal, exists δ:posreal, forall x, (Rabs(x - x0) <= δ)%R ->
                                             ((Rabs (f x - f x0))< ϵ)%R))

`push_neg_in H` transforms it to:

 (H : exists x : posreal,
        forall x1 : posreal,
        exists x2 : R, (Rabs (x2 - x0) <= x1)%R /\ (Rabs (f x2 - f x0) >= x)%R

 *`contrapose` and `contrapose_in` replace an implication by it's contrapositive.

 NOTE: These tactics may utilize classical axioms (the law of excluded middle).
****************************************************************************************
*)

Section rewrites.

  Lemma not_not (P : Prop): ~(~ P) <-> P.
  Proof.
    split; intros.
    + now apply NNPP.
    + firstorder.
  Qed.

  Lemma not_and (P Q:Prop) : ~(P /\ Q) <-> (P -> ~Q).
  Proof.
    firstorder.
  Qed.

  Lemma not_or (P Q:Prop) : ~(P \/ Q) <-> (~ P /\ ~ Q).
  Proof.
    firstorder.
  Qed.

  Lemma not_forall {A : Type} (S : A -> Prop): ~(forall x, S x) <-> exists x, ~ S x.
  Proof.
    split; intros.
    + now apply not_all_ex_not.
    + firstorder.
  Qed.

  Lemma not_exists {A : Type} (S : A -> Prop): ~(exists x, S x) <-> forall x, ~ S x.
  Proof.
    firstorder.
  Qed.

  Lemma not_imply : forall P Q:Prop, ~ (P -> Q) <-> P /\ ~ Q.
  Proof.
    intros P Q.
    split; intros.
    - now apply imply_to_and.
    - firstorder.
  Qed.

  Lemma not_lt (a b : R): ~ (a < b)%R <-> (a >= b)%R.
  Proof.
    lra.
  Qed.

  Lemma not_le (a b : R): ~ (a <= b)%R <-> (a > b)%R.
  Proof.
    lra.
  Qed.

  Lemma not_gt (a b : R): ~ (a > b)%R <-> (a <= b)%R.
  Proof.
    lra.
  Qed.

  Lemma not_ge (a b : R): ~ (a >= b)%R <-> (a < b)%R.
  Proof.
    lra.
  Qed.

  Lemma not_eq {A : Type} (a b : A) : ~(a = b) <-> a <> b.
  Proof.
    reflexivity.
  Qed.

  Lemma not_impl_contr (p q : Prop) : (~q -> ~p) <-> (p -> q).
  Proof.
    split; intros; try (apply NNPP); firstorder.
  Qed.

End rewrites.

Ltac push_neg :=
  repeat match goal with
  | [ |- context[~ (_ < _)%R]] => setoid_rewrite not_lt
  | [ |- context[~ (_ <= _)%R]] => setoid_rewrite not_le
  | [ |- context[~ (_ > _)%R]] => setoid_rewrite not_gt
  | [ |- context[~ (_ >= _)%R]] => setoid_rewrite not_ge
  | [ |- context[~ (~ _)]] => setoid_rewrite not_not
  | [ |- context[~ (_ /\ _)]] => setoid_rewrite not_and
  | [ |- context[~(_ \/ _)]] => setoid_rewrite not_or
  | [ |- context[~(_ -> _)]] => setoid_rewrite not_imply
  | [ |- context[~(_ = _)]] => setoid_rewrite not_eq
  | [ |- context[~ exists _, _]] => setoid_rewrite not_exists
  | [ |- context[~ (forall _, _)]] => setoid_rewrite not_forall
  end.

Ltac push_neg_in H :=
  repeat match type of H with
  | context[~ (_ < _)%R] => setoid_rewrite not_lt in H
  | context[~ (_ <= _)%R] => setoid_rewrite not_le in H
  | context[~ (_ > _)%R] => setoid_rewrite not_gt in H
  | context[~ (_ >= _)%R] => setoid_rewrite not_ge in H
  | context[~ (~ _)] => setoid_rewrite not_not in H
  | context[~ (_ /\ _)] => setoid_rewrite not_and in H
  | context[~(_ \/ _)] => setoid_rewrite not_or in H
  | context[~(_ -> _)] => setoid_rewrite not_imply in H
  | context[~(_ = _)] => setoid_rewrite not_eq in H
  | context[~ exists _, _] => setoid_rewrite not_exists in H
  | context[~ (forall _, _)] => setoid_rewrite not_forall in H
  end.

Ltac contrapose :=
  match goal with
| [ |- ~ (_ -> _)] => setoid_rewrite not_impl_contr
| [ |- (_ -> _)] => setoid_rewrite <-not_impl_contr
  end.

Ltac contrapose_in H :=
  match type of H with
| ~ (_ -> _) => setoid_rewrite not_impl_contr in H
| (_ -> _) => setoid_rewrite <-not_impl_contr in H
  end.

Ltac contra_neg := contrapose; push_neg.

Ltac contra_neg_in H := contrapose_in H ; push_neg_in H.

Lemma tests1
      (p q : Prop)
      (P : nat -> Prop) (x y z : R)
      (H1 : ~ exists x : nat, P x)
      (H2 : ~ forall x : nat, P x)
      (H3 : ~ (x < y)%R)
      (H4 : ~ (x <= y)%R)
      (H5 : ~ (x > y)%R)
      (H6 : ~ (~ q))
      (H7 : ~ (p -> (p -> q)))
      (H8 : ~ (p /\ q))
      (H9 : ~ (p \/ q)): True.
Proof.
  push_neg_in H1.
  push_neg_in H2.
  push_neg_in H3.
  push_neg_in H4.
  push_neg_in H5.
  push_neg_in H6.
  push_neg_in H7.
  push_neg_in H8.
  push_neg_in H9.
  trivial.
Qed.

Lemma tests2 {x : nat -> R}
      (H1 : ~ exists x y : nat, forall z:nat, x = z \/ y = z)
      (H2 : ~ forall x y : nat, x = y /\ y = x)
      (H3 : ~(forall eps : R, exists N:nat, forall m n : nat, m >= N -> n >= N -> (Rabs (x n - x m)%R <= eps)%R))
  : True.
Proof.
  push_neg_in H1.
  push_neg_in H2.
  push_neg_in H3.
  trivial.
Qed.

Lemma test3 {f : R -> R}(x0 : R)
      (H : ~ (forall ϵ:posreal, exists δ:posreal, forall x, (Rabs(x - x0) <= δ)%R ->
                                             ((Rabs (f x - f x0))< ϵ)%R)) : True.
Proof.
  push_neg_in H.
  trivial.
Qed.

Lemma test4 {p q : Prop} (Hpq1 : (p -> q)) (Hpq2 : ~q -> ~p) : (~q -> ~p) /\ (p -> q).
Proof.
  split.
  + clear Hpq2. contrapose_in Hpq1. exact Hpq1.
  + clear Hpq1. contrapose_in Hpq2. push_neg_in Hpq2.
    exact Hpq2.
Qed.

Lemma test5 {p q : Prop} (Hpq1 : (p -> q)) (Hpq2 : ~q -> ~p) : (~q -> ~p) /\ (p -> q).
Proof.
  split.
  + clear Hpq2. now contra_neg.
  + clear Hpq1. now contra_neg_in Hpq2.
Qed.


Add LoadPath "." as CoqDirectory.
Load partie4.

(* 5.1 *)

(* Ces fonctions ont été pénbibles à faire. En effet, les conventions d'écriture
divergent entre le sujet et Coq. On s'est trompés plusieurs fois (inversions des termes en
compilant/décompilant des Applciation) *)
Fixpoint tau_code (t: Instruction) : DeBruijn :=
    match t with
    | (Access n)=> Var n
    | (Push cp c) => Application (tau_code c) (tau_code cp)
    | Grab c => Lambda (tau_code c)
    end
.
(* τ((c0,e0).e)  =  [0←τ(c0)[0←τ(e0)],u1...un]oùτ(e) = [0←u1...un] *)

Fixpoint tau_environment_aux (e: Environment) : list DeBruijn :=
    match e with
    | Stack (c_0, e_0) e_suite =>
        ((tau_code(c_0))[0 <-- (tau_environment_aux e_0)]) :: (tau_environment_aux e_suite)
    | Nil => []
    end
.

Definition tau_environment : Environment -> DeBruijn -> DeBruijn :=
    fun e t => t[0 <-- (tau_environment_aux e)]
.

Fixpoint tau_aux (c: Instruction) (e: Environment) (s: Stack_type) : DeBruijn :=
    match s with
    | Stack (c_0, e_0) s_suite =>
        Application (tau_environment e (tau_code c)) (tau_aux c_0 e_0 s_suite)
    | Nil => tau_environment e (tau_code c)
    end
.

Definition tau : State -> DeBruijn :=
    (fun '(c, e, s) => tau_aux c e s)
.

(* 5.2 *)

(* Pas mal *)
Lemma protected_tau :
    forall (c: Instruction), S(tau_code c)
.
Proof.
    intro c.
    induction c.
    intuition.
    intuition.
    intuition.
    unfold tau_code in H. simpl in H. intuition.
Qed.

(* Lemme qui est apapremment utile, je ne me souviens plus trop *)
Lemma tau_comp_identity_wtf :
    forall (t: DeBruijn), tau (CompState t) = tau_code (Comp t)
.
Proof.
    intro t.
    induction t.
    trivial.

    simpl. unfold tau_environment.
    simpl. assert (S(tau_code (Comp t))). apply (protected_tau (Comp t)).
    rewrite safe_deprotect. exact H.
    reflexivity.

    simpl.
    unfold tau_environment.
    assert (tau_environment_aux Nil = []). auto.
    rewrite H. rewrite (substitution_multiple_nil).
    assert (S(tau_code (Comp t1))). apply (protected_tau (Comp t1)).
    assert (S(tau_code (Comp t2))). apply (protected_tau (Comp t2)).
    assert (S(tau_code (Comp t1)) /\ S(tau_code (Comp t2))). intuition.
    unfold protected. intuition. reflexivity.

    simpl. unfold tau_environment.
    intuition.
Qed.

(* Théorème plutôt pas mal :
Il nous permet d'être sûr que notre définition de Comp et de Tau sont cohérentes
entre elles. Elles peuvent être fausses par rapport à la définition du sujet mais au
moins elles ont des erreurs qui font qu'elles sont cohérentes : la décompilation
d'un code compilé retourne bien exactement le code de départ. *)
Theorem tau_compt_identity :
    forall (t: DeBruijn), S(t) -> tau(CompState t) = t
.
Proof.
    induction t.

    simpl.
    trivial.

    simpl. unfold tau_environment. simpl. move => S.
    assert (deprotect (tau_code (Comp t)) = tau_code (Comp t)).
    apply safe_deprotect. apply protected_tau. rewrite H.
    rewrite <- tau_comp_identity_wtf. rewrite IHt. exact S. reflexivity.

    move => S. simpl in S. apply destruct_false_or in S. destruct S.
    simpl. unfold tau_environment. simpl.
    assert (deprotect (tau_code (Comp t1)) = tau_code (Comp t1)).
    apply (safe_deprotect (tau_code (Comp t1))). apply protected_tau. rewrite H1.
    clear H1.
    assert (deprotect (tau_code (Comp t2)) = tau_code (Comp t2)).
    apply (safe_deprotect (tau_code (Comp t2))). apply protected_tau. rewrite H1.
    clear H1.
    rewrite <- tau_comp_identity_wtf. rewrite IHt1. exact H.
    rewrite <- tau_comp_identity_wtf. rewrite IHt2. exact H0. reflexivity.

    intuition. simpl in H. contradiction H. trivial.
Qed.

(* 5.3 *)

Fixpoint stack_length (e: Environment) :=
    match e with
    | Nil => 0
    | Stack a suite => 1 + (stack_length suite)
    end
.

Inductive correct_stack_old : Stack_type -> Prop :=
    | nil_correct : correct_stack_old Nil
    | correct_trans : forall (c_0: Instruction),
        forall (e_0: Environment), forall (e: Environment),
        (C[stack_length e_0](tau_code(c_0))) ->
        correct_stack_old e_0 -> correct_stack_old e -> correct_stack_old (Stack (c_0, e_0) e)
.

Fixpoint correct_stack (s: Stack_type) :=
    match s with
    | Nil => True
    | Stack (i, sp) spp =>
        C[stack_length sp](tau_code i) /\ correct_stack sp /\ correct_stack spp
    end
.

Print correct_stack.

Definition correct_state : State -> Prop :=
    fun '(c, e, s) => correct_stack (Stack (c, e) s)
.

Notation "CoS( s )" := (correct_state s).

(* Ceci sert à définir le lemme `state_trans_aux` qui raisonen sur une option d'état.
En effet, pour simplifier ce lemme, on ne se donne pas de condition sur "est-ce que la fonction
`step_krivine` a renvoyé un état ou non". La distinction est faite dans le théorème après *)
Definition correct_option_state (t: StateOption) :=
    match t with
    | None => True
    | Some s => CoS(s)
    end
.

Notation "CoSo( s )" := (correct_option_state(s)).

(* Ceci a été un peu pénible à faire mais a finalement marché. *)
Lemma state_trans_aux : forall (s1: State),
    CoS(s1) -> CoSo(step_krivine s1)
.
Proof.
    move => s1 CoS_s1.
    destruct s1.
    destruct p.
    induction i.

    +   simpl. case_eq n.
        induction e.
        *   simpl. trivial.

        *   destruct p.
            simpl. simpl in CoS_s1.
            intuition.

        *   move => n0 prop.
            case_eq e.
            -   simpl. trivial.
            -   intuition.
                simpl. simpl in CoS_s1. intuition. unfold max_var_smaller_n.
                unfold max_var_smaller_n in H0. rewrite prop in H0. rewrite H in H0.
                simpl in H0. simpl. lia.
                rewrite H in H2.
                simpl in H2.
                intuition.

    +   simpl.
        case_eq s.
        -   simpl. intuition.

        -   intuition. simpl.
            simpl in CoS_s1.
            intuition.
            unfold max_var_smaller_n. unfold max_var_smaller_n in H0.
            rewrite (inutile_1 (stack_length e)).
            apply -> (aux_2_1 (tau_code i) (stack_length e) 0). exact H0.
            rewrite H in H3. simpl in H3.
            intuition.
            rewrite H in H3. simpl in H3.
            intuition.
            rewrite H in H3. simpl in H3.
            intuition.

    +   simpl. simpl in CoS_s1. intuition. unfold max_var_smaller_n in H.
        simpl in H.
        destruct H.
        exact H.
        simpl in H.
        destruct H.
        exact H0.
Qed.

(* Théorème de 5.3. Simple application du lemme précédent. *)
Theorem state_trans : forall (s1 s2: State),
    CoS(s1) -> step_krivine s1 = Some s2 -> CoS(s2)
.
Proof.
    move => s1 s2 CoS1 eq.
    assert (CoSo(step_krivine s1)).
    apply (state_trans_aux s1 CoS1).
    rewrite eq in H.
    simpl in H. exact H.
Qed.

(* 5.4 *)
(* Il nous manquait encore quelques lemmes sur la substitution parallèle *)
Lemma substitution_multiple_lambda_aux : forall (t: DeBruijn), forall (u: list DeBruijn),
    (forall (n: nat),
    substitution_multiple_aux (Lambda t) n u =
    Lambda (substitution_multiple_aux t (n + 1) u))
.
Proof.
    move => t u.
    induction u.
    move => n.
    simpl. reflexivity.
    simpl. simpl in IHu.
    move => n.
    assert ((substitution_multiple_aux (Lambda t) (n + 1) u) =
        Lambda (substitution_multiple_aux t (n + 1 + 1) u)).
    exact (IHu (n + 1)).
    rewrite H. simpl. reflexivity.
Qed.

Lemma substitution_multiple_lambda : forall (t: DeBruijn), forall (u: list DeBruijn),
    (forall (n: nat),
    substitution_multiple (Lambda t) n u =
    Lambda (substitution_multiple t (n + 1) u))
.
Proof.
    intuition.
    unfold substitution_multiple.
    exact (substitution_multiple_lambda_aux t u n).
Qed.

(* Lemme (pour une fois) pas si stupide que ça. La propriété n'était pas TOTALEMENT évidente
(note de la rédaction: en fait si)*)
Lemma stupide : forall (t1 t2: DeBruijn), forall (u: list DeBruijn), forall (n: nat),
    substitution_multiple_aux (Application t1 t2) n u =
    Application (substitution_multiple_aux t1 n u)
                (substitution_multiple_aux t2 n u)
.
Proof.
    move => t1 t2 u.
    induction u.
    simpl. move => n. reflexivity.
    move => n.
    simpl.
    rewrite (IHu (n + 1)).
    remember (substitution
    (Application (substitution_multiple_aux t1 (n + 1) u)
       (substitution_multiple_aux t2 (n + 1) u)) n a) as temp.
    unfold substitution in Heqtemp.
    fold substitution in Heqtemp. rewrite Heqtemp. reflexivity.
Qed.

(* La preuve n'est pas menée jusqu'au bout. On a abandonné après pas mal de (~1000 lignes en tout)
tentatives infructueuses. Je suppose que notre définition bizarre des termes nous a encore
joué un tour.

NB : on a modifié, en concertation avec plusieurs autress groupes, la signature du théorème.
En effet, il s'avère que, dans certains cas, il n'y a pas une relation de beta-réduction
entre les deux termes mais une relation d'égalité! Nous l'avons bien pris en compte
lors de l'écriture de la signature du théorème.

Pour avoir un échantillon des tentatives infructueuses, Cf tout en bas du fichier *)
Theorem transition_beta : forall (s1: State),
    CoS(s1) -> forall (s2: State), (step_krivine s1 = Some s2 ->
        (((tau s1) -b> (tau s2)) \/ ((tau s1) = (tau s2))))
.
Proof.
    move => s1 CoS1 s2 eqs2.
    destruct s1. destruct p.
    induction i.
    induction e.
    case_eq n.
    move => H.
    simpl in eqs2. rewrite H in eqs2.
    discriminate.
    intuition.
    simpl in eqs2. rewrite H in eqs2.
    discriminate.

    simpl.
    case_eq n.
    move => H.
    simpl in eqs2. rewrite H in eqs2.
    destruct p.
    assert ((i, s0, s) = s2).
    apply some_truc. exact eqs2.
    rewrite <- H0. simpl.
    right.
    case_eq s.
    intuition. unfold tau_aux.
    simpl.
    unfold tau_environment. unfold substitution_multiple. simpl.
    assert (substitution_multiple_aux (Var 0) 1 (tau_environment_aux e) = Var 0).
    apply (substitution_multiple_C_0 (Var 0) 1). unfold max_var_smaller_n. simpl. lia.
    simpl. intuition. lia.
    rewrite -> H2. simpl. unfold substitution_multiple. rewrite deprotect_involutive.
    reflexivity.

    intuition. simpl.
    assert ((tau_environment (Stack (i, s0) e) (Var 0)) =
        (tau_environment s0 (tau_code i))).
    unfold tau_environment. simpl.
    assert (substitution_multiple (Var 0) 1 (tau_environment_aux e) = Var 0).
    apply (substitution_multiple_C_0 (Var 0) 1). unfold max_var_smaller_n. simpl. lia.
    simpl. intuition. lia.
    rewrite H2. simpl. rewrite deprotect_involutive. reflexivity.
    rewrite H2. reflexivity.

    intuition.

    right.
    rewrite H in eqs2.
    destruct p. simpl in eqs2.
    assert ((Access n0, e, s) = s2).
    apply (some_truc). exact eqs2.
    rewrite <- H0. simpl. rewrite H in IHe.
    simpl in IHe. rewrite H in CoS1. simpl in CoS1. intuition.
    case_eq s.
    intuition.
    unfold tau_aux.
    simpl. unfold tau_environment.
    induction e.
    intuition.
    unfold correct_stack in H6. rewrite H7 in H5. rewrite H7 in H0.
    simpl in H1. contradict H1.
    assert ((~ (1 > S n0)) -> ~ C[ 1 ]( Var (S n0))).
    apply (Decidable.contrapositive (~ (1 > S n0))).
    unfold Decidable.decidable. lia.
    intuition. assert (~ (1 > S n0)). lia. intuition.

    destruct p.
    case_eq e.
    intuition.
    remember ((Var (S n0)) [0 <-- tau_environment_aux (Stack (i, s0) (Stack (i0, s1) Nil))]).
    admit.
    intuition.
    admit.
    intuition. unfold tau_aux.
    admit.

    left.
    assert (eqs2' := eqs2).
    simpl in eqs2.
    case_eq s.
    intuition.
    rewrite H in eqs2. discriminate.
    intuition. rewrite H in eqs2.
    assert ((i, Stack (a, b) e, s0) = s2).
    apply some_truc. exact eqs2.
    rewrite <- H0. rewrite <- H0 in IHi.
    unfold tau.
    unfold tau_aux.
    induction s0.
    simpl. unfold tau_environment.
    intuition.
    (*remember (tau_environment_aux (Stack (a, b) e)) as H'.*)

    rewrite (substitution_multiple_lambda (tau_code i) (tau_environment_aux e) 0).
    simpl.
    remember (tau_code a) [0 <-- tau_environment_aux b] as truc.
    assert ((substitution_multiple (tau_code i) 1 (tau_environment_aux e))
        = (tau_code i)[1 <-- (tau_environment_aux e)]).
    admit.
    remember (tau_environment_aux e).
    rewrite H1. rewrite deprotect_involutive.
    apply Evaluation.

    intuition.
    destruct p. intuition.

    (* Marche à peu près jusque-là*)
    admit.

    (* Push *)

    simpl.
    assert (eqs2' := eqs2).
    simpl in eqs2.
    assert ((i2, e, Stack (i1, e) s) = s2).
    apply some_truc. exact eqs2.
    rewrite <- H. unfold tau.
    simpl.
    case_eq s.
    intuition.
    right.
    unfold tau_aux.
    remember (tau_code (Push i1 i2)) as temp.
    unfold tau_code in Heqtemp. fold tau_code in Heqtemp.
    rewrite Heqtemp. unfold tau_environment.
    remember (((Application (tau_code i2) (tau_code i1)) [0 <-- tau_environment_aux e]))
        as temp2.
    unfold substitution_multiple in Heqtemp2.
    unfold substitution_multiple_aux in Heqtemp2.
    fold substitution_multiple_aux in Heqtemp2.
    rewrite Heqtemp2. unfold substitution_multiple.
    rewrite stupide.
    remember (deprotect
    (Application
       (substitution_multiple_aux (tau_code i2) 0 (tau_environment_aux e))
       (substitution_multiple_aux (tau_code i1) 0 (tau_environment_aux e))) )
       as temp3.
    unfold deprotect in Heqtemp3.
    fold deprotect in Heqtemp3.
    rewrite Heqtemp3. reflexivity.

    intuition.
    left.
    remember (tau_aux (Push i1 i2) e (Stack (a, b) s0)) as lol.
    unfold tau_aux in Heqlol.
    fold tau_aux in Heqlol.
    rewrite Heqlol.

    (* Fin? *)
    unfold substitution_multiple_aux.

    simpl.
    admit.
Admitted.

(* 5.5

On n'est pas arrivés jusque-là mais on a quelques idées.
Avec 5.3 et 5.4, on pourrait montrer sans trop de difficultés que la clôture transistive refléxive
associée à la transition d'états de Krivine correspond exactement à celle de la beta-reduction.
Avec un peu plus de boulot, on pourrait peut-être montrer que si un terme est correct,
alors la réduction est finie (ceci n'est qu'une hypothèse) et boucle ensuite sur le même terme.

*)

    (* Marche vaguement jusqu'ici *)

    (* Une partie des tentatives infructueuses pour la 5.4 *)
    (*
    simpl in CoS1. intuition.
    unfold max_var_smaller_n in H0.
    unfold max_var_smaller_n_depth in H0. destruct H0.
    fold max_var_smaller_n_depth in H0.
    fold max_var_smaller_n_depth in H1.
    simpl. intuition.
    assert ((tau (i1, e, s)) -b> (tau s2) \/ tau (i1, e, s) = tau s2).
    apply IHi1.
    simpl. intuition.
    assert ((tau (i2, e, s)) -b> (tau s2) \/ tau (i2, e, s) = tau s2).
    apply IHi2.
    simpl. intuition.

    rewrite substitution_multiple_C_2.
    simpl. intuition. admit.
    intuition. simpl.

    assert ((substitution (substitution_multiple (Var (S n0)) 2 (tau_environment_aux s1))
    1 (tau_code a) [0 <-- tau_environment_aux b])
        = (substitution_multiple (Var n0) 1 (tau_environment_aux s1))).

    apply aux_0.

    unfold tau_environment_aux.
    unfold substitution_multiple. simpl.
    rewrite (substitution_multiple_C_2).
        simpl. intuition.
    simpl. admit.
    simpl.
    case_eq e.
    intuition.
    rewrite H8 in H6. simpl in H6. rewrite H8 in H2.

    (*
    Application (tau_environment (Stack (i, s0) e) (Var 0)) (tau_aux a b s1) =
    Application (tau_environment s0 (tau_code i)) (tau_aux a b s1)
    *)

    assert ((tau_environment (Stack (i, s0) e) (Var 0)) =
        (tau_environment s0 (tau_code i))).
    unfold tau_environment.
    simpl. assert ((substitution_multiple (Var 0) 1 (tau_environment_aux e)) = Var 0).
    apply (substitution_multiple_C_0 (Var 0) 1). unfold max_var_smaller_n. simpl. lia.
    simpl. intuition. lia.

    rewrite H3. simpl. rewrite deprotect_involutive. reflexivity.

    (*
    Application (tau_environment (Stack (i, s0) e) (Var 0)) (tau_aux a b s1) =
    Application (tau_environment s0 (tau_code i)) (tau_aux a b s1)
    *)

    intuition.
    destruct s1. destruct p.
    induction i.
    induction e.
    induction s. simpl in H.
    intuition.
    assert (~C[0](Var n)).
    assert (~(0 > n)). lia.
    assert (~(0 > n) -> ~C[0](Var n)).
    apply (Decidable.contrapositive (~C[0](Var n))). intuition. simpl.
    intuition. exact (H4 H2).
    contradiction.

    simpl. destruct p. simpl in H. simpl in H0.
    case_eq n. intuition. rewrite H1 in H0. discriminate.
    intuition. rewrite H4 in H0. discriminate.

    induction s.
    simpl. simpl in H. destruct p.
    simpl in H0. simpl in IHe.
    case_eq n.
    intuition.
    rewrite H1 in H0.
    rewrite H1 in H5. rewrite H1 in H2.
    apply aux_0 in H2.
    unfold tau_environment. assert ((i, s, Nil) = s2). apply some_truc. exact H0.
    rewrite <- H7. unfold tau. unfold tau_aux.

    intro s1; case s1; clear s1.
    intro p; case p; clear p.
    move => i e s.
    intro s2; case s2; clear s2.
    intro p; case p; clear p.
    move => i0 e0 s0.
    intro C. intro H.

    inversion H.

    case_eq i.
    intuition. rewrite H0 in H1.
    induction n.
    simpl.

    destruct s1.
    destruct p.
    induction i.
    induction e.
    induction s.
    intuition. simpl. simpl in H0.
    case_eq n.
    intuition. rewrite H1 in H0. discriminate.
    intuition. rewrite H1 in H0. discriminate.
    intuition.
    simpl in H0.
    case_eq n.
    intuition. rewrite H1 in H0. discriminate.
    intuition. rewrite H1 in H0. discriminate.

    intuition. simpl in H0. case_eq n.
    intuition. rewrite H1 in H0. assert ((a, b, s) = s2). admit.
    rewrite <- H2.
    simpl. rewrite H1 in H. simpl in H.some_truc

    induction s1. destruct a.
    induction b.
    induction i.
    intuition.
    case_eq n.
    intuition.
    simpl in H0. rewrite H1 in H0. simpl.
    induction e.
    discriminate.
    simpl in IHe. destruct p.
    assert ((i, s, Nil) = s2). admit.
    rewrite <- H2. simpl. unfold tau_environment. simpl.

    assert ((substitution_multiple (Var 0) 1 (tau_environment_aux e)) = Var 0).
    apply (substitution_multiple_C_0 (Var 0) 1). unfold max_var_smaller_n. simpl. lia.
    unfold protected. intuition. lia.
    rewrite H3. simpl.
    assert (S((tau_code i) [0 <-- tau_environment_aux s])). apply deprotect_correction.

    assert (deprotect (tau_code i) [0 <-- tau_environment_aux s] =
    (tau_code i) [0 <-- tau_environment_aux s]). apply safe_deprotect.
    exact H4.
    rewrite H5. intuition.

    intuition. simpl.
    simpl in H0.
    rewrite H1 in H0.
    induction e. discriminate.
    destruct p. assert ((Access n0, e, Nil) = s2). admit.
    rewrite <- H2.
    case_eq e. intuition. rewrite H3 in IHe. simpl in IHe.
    simpl. unfold tau_environment. simpl. simpl in H. intuition.
    simpl.

    simpl in CoS_s1. simpl in step. simpl in IHe.
    intuition.
    case_eq n. intuition. rewrite H3 in step.
    rewrite H3 in H0. destruct p.
    unfold tau_environment. simpl. intuition.

    induction i.
    *   simpl.
        induction s. simpl.
        +   induction e.
            -   simpl in step.
                intuition. unfold tau_environment. simpl.
                case_eq n.
                intuition. rewrite H in step.
                discriminate.

                intuition. rewrite H in step. discriminate.
            -   case_eq n.
                intuition. rewrite H in CoS_s1. simpl in CoS_s1.
                rewrite H in step. simpl in step. destruct p.
                rewrite H in IHe. simpl in IHe. intuition.
*)