(** * Coinductive nats (conats) algebraic CPO. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
  Basics
  Equivalence
  Lia
  Morphisms
  Equality
  List
  Nat
.
Local Open Scope program_scope.
Local Open Scope equiv_scope.
Import ListNotations.

From Coq Require Import
  Reals
  Raxioms
  Rpower
  FunctionalExtensionality
  ClassicalChoice
  IndefiniteDescription
.

From algco Require Import aCPO axioms cpo misc order tactics.

Local Open Scope order_scope.

Create HintDb conat.

CoInductive conat : Type :=
| cozero : conat
| cosucc : conat -> conat.

CoFixpoint omega : conat := cosucc omega.

Definition unf (n : conat) :=
  match n with
  | cozero => cozero
  | cosucc m => cosucc m
  end.

Lemma unf_eq (n : conat) : n = unf n.
Proof. destruct n; auto. Qed.

CoInductive conat_le : conat -> conat -> Prop :=
| conat_le_zero : forall n, conat_le cozero n
| conat_le_succ : forall n m,
    conat_le n m ->
    conat_le (cosucc n) (cosucc m).
#[global] Hint Constructors conat_le : conat.

#[global]
  Instance Reflexive_conat_le : Reflexive conat_le.
Proof. cofix CH; intros []; constructor; eauto. Qed.

#[global]
  Instance Transitive_conat_le : Transitive conat_le.
Proof.
  cofix CH; intros x y z Hxy Hyz; inv Hxy.
  - constructor.
  - inv Hyz; constructor; eauto.
Qed.

#[global]
  Instance PreOrder_conat_le : PreOrder conat_le.
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_conat : OType conat :=
  { leq := conat_le }.

#[global]
  Program
  Instance PType_conat : PType conat :=
  { bot := cozero }.
Next Obligation. constructor. Qed.

Lemma cozero_le (n : conat) :
  cozero ⊑ n.
Proof. constructor. Qed.
#[global] Hint Resolve cozero_le : conat.

Lemma le_omega (n : conat) :
  n ⊑ omega.
Proof.
  revert n; cofix CH; intro n.
  destruct n.
  { constructor. }
  rewrite (@unf_eq omega); constructor; apply CH.
Qed.
#[global] Hint Resolve le_omega : conat.

Fixpoint nat_inj (n : nat) : conat :=
  match n with
  | O => cozero
  | S n' => cosucc (nat_inj n')
  end.

Definition conat' : Type := nat + unit.

Inductive finite : nat -> conat -> Prop :=
| finite_zero : finite O cozero
| finite_succ : forall n m,
    finite n m ->
    finite (S n) (cosucc m).

Definition conat_to_conat' (n : conat) : conat' :=
  match classicT (exists i, finite i n) with
  | left pf => inl (proj1_sig (constructive_indefinite_description _ pf))
  | right _ => inr tt
  end.

Definition conat'_to_conat (n : conat') : conat :=
  match n with
  | inl n' => nat_inj n'
  | inr _ => omega
  end.

CoInductive conat_eq : conat -> conat -> Prop :=
| conat_eq_zero : conat_eq cozero cozero
| conat_eq_succ : forall n m,
    conat_eq n m ->
    conat_eq (cosucc n) (cosucc m).

Lemma finite_nat_inv i j n :
  finite i n ->
  finite j n ->
  i = j.
Proof.
  revert j n; induction i; intros j n Hi Hj.
  - inv Hi; inv Hj; auto.
  - inv Hi; inv Hj; erewrite IHi; eauto.
Qed.

Lemma conat_eq_finite i n m :
  conat_eq n m ->
  finite i n ->
  finite i m.
Proof.
  revert n m; induction i;
    intros n m Hnm Hn; inv Hn; inv Hnm; constructor; eauto.
Qed.

#[global]
 Instance Symmetric_conat_eq : Symmetric conat_eq.
Proof. cofix CH; intros n m []; constructor; auto. Qed.

Lemma conat_eq_leq n m :
  conat_eq n m ->
  n ⊑ m.
Proof.
  revert n m; cofix CH; intros n m Hnm.
  inv Hnm; constructor.
  apply CH; auto.
Qed.

Lemma conat_eq_equiv n m :
  conat_eq n m <-> n === m.
Proof.
  split.
  - intro Hnm; split.
    + apply conat_eq_leq; auto.
    + apply conat_eq_leq; symmetry; auto.
  - revert n m; cofix CH; intros n m [Hnm Hmn].
    inv Hnm; inv Hmn; constructor.
    apply CH; split; auto.
Qed.

Lemma conat_eq_conat_to_conat' n m :
  conat_eq n m ->
  conat_to_conat' n = conat_to_conat' m.
Proof.
  intros Hnm.
  unfold conat_to_conat'.
  destr.
  - destr.
    + f_equal.
      compute.
      destr.
      destr.
      destruct e as [i Hi].
      destruct e0 as [j Hj].
      eapply conat_eq_finite in Hnm; eauto.
      eapply finite_nat_inv; eauto.
    + exfalso; apply n0.
      destruct e as [i Hi].
      exists i; eapply conat_eq_finite; eauto.
  - destr; auto.
    exfalso; apply n0.
    destruct e as [i Hi].
    exists i; eapply conat_eq_finite; eauto.
    symmetry; auto.
Qed.

(* Extensionality axiom for conats. *)
(* Axiom conat_ext : forall (n m : conat), conat_eq n m -> n = m. *)

Axiom conat_eq_axiom : forall n, conat'_to_conat (conat_to_conat' n) = n.

(** The axiom implies conat extensionality... *)
Lemma conat_ext :
  forall n m, conat_eq n m -> n = m.
Proof.
  intros n m Hnm.
  rewrite <- conat_eq_axiom.
  rewrite <- (@conat_eq_axiom m).
  erewrite conat_eq_conat_to_conat'; auto.
Qed.

Lemma conat_eq_refl (n : conat) :
  conat_eq n n.
Proof. revert n; cofix CH; intros []; constructor; eauto. Qed.

#[global]
  Instance Reflexive_conat_eq : Reflexive conat_eq.
Proof. intro; apply conat_eq_refl. Qed.

Lemma conat_eq_equ (a b : conat) :
  conat_eq a b -> a === b.
Proof.
  intro Hab; split; revert Hab; revert a b; cofix CH;
    intros a b Hab; inv Hab; constructor; apply CH; auto.
Qed.

Lemma equ_conat_eq (a b : conat) :
  a === b -> conat_eq a b.
Proof.
  revert a b; cofix CH; intros a b [Hab Hba].
  inv Hab; inv Hba; constructor; apply CH; split; auto.
Qed.

#[global]
  Instance ExtType_conat : ExtType conat.
Proof. constructor; intros a b Hab; apply conat_ext, equ_conat_eq; auto. Qed.

Fixpoint conat_prefix (i : nat) (n : conat) : nat :=
  match i with
  | O => O
  | S i' => match n with
           | cozero => O
           | cosucc n' => S (conat_prefix i' n')
           end
  end.

Fixpoint coconat_prefix (i : nat) (n : conat) : conat :=
  match i with
  | O => cozero
  | S i' => match n with
           | cozero => cozero
           | cosucc n' => cosucc (coconat_prefix i' n')
           end
  end.

#[global]
  Instance Proper_conat_le : Proper (equ ==> equ ==> flip impl) conat_le.
Proof.
  intros a b [Hab Hba] c d [Hcd Hdc] Hle.
  etransitivity; eauto; etransitivity; eauto.
Qed.

#[global]
  Instance Proper_conat_le'
  : Proper (conat_eq ==> conat_eq ==> flip impl) conat_le.
Proof.
  intros a b Hab c d Hcd Hle.
  apply conat_eq_equ in Hab; destruct Hab.
  apply conat_eq_equ in Hcd; destruct Hcd.
  etransitivity; eauto; etransitivity; eauto.
Qed.

Lemma continuous_cosucc : continuous cosucc.
Proof.
  intros ch Hch s Hs; split.
  - intro i; constructor; apply Hs.
  - intros x Hx.
    destruct x; try solve [specialize (Hx (S O)); inv Hx].
    pose proof Hx as Hx'.
    specialize (Hx' (S O)).
    inv Hx'.
    constructor; apply Hs.
    intro i; specialize (Hx i); inv Hx; auto.
Qed.
#[global] Hint Resolve continuous_cosucc : conat.

Lemma O_le (n : nat) :
  O ⊑ n.
Proof. simpl; lia. Qed.
#[global] Hint Resolve O_le : conat.

Lemma le_succ (n m : nat) :
  n ⊑ m -> S n ⊑ S m.
Proof. simpl; lia. Qed.

Lemma conat_prefix_monotone (i : nat) :
  monotone (conat_prefix i).
Proof.
  induction i; intros a b Hab; simpl; try constructor.
  destruct a; inv Hab; try lia.
  apply le_succ; auto.
Qed.

Lemma conat_prefix_monotone' (n : conat) :
  monotone (fun i => conat_prefix i n).
Proof.
  intro i; revert n; induction i; intros n j Hij; simpl.
  - lia.
  - destruct n.
    + lia.
    + destruct j; simpl.
      * inv Hij.
      * apply le_succ; apply IHi; inv Hij.
        { reflexivity. }
        simpl; lia.
Qed.

Lemma chain_conat_prefix (n : conat) :
  chain (fun i : nat => conat_prefix i n).
Proof.
  apply monotone_chain.
  - apply conat_prefix_monotone'.
  - intro i; simpl; lia.
Qed.

Lemma supremum_cozero (ch : nat -> conat) :
  supremum cozero ch ->
  ch = const cozero.
Proof.
  intros [Hub Hlub]; ext i; unfold const.
  specialize (Hub i); inv Hub; reflexivity.
Qed.

Definition not_cozero (n : conat) : Prop :=
  match n with
  | cozero => False
  | _ => True
  end.

Definition not_O (n : nat) : Prop :=
  match n with
  | O => False
  | _ => True
  end.

Lemma not_cozero_dec (n : conat) : { not_cozero n } + { ~ not_cozero n }.
Proof.
  destruct n.
  - right; intro HC; inv HC.
  - left; constructor.
Qed.

Lemma not_O_dec (n : nat) : { not_O n } + { ~ not_O n }.
Proof.
  destruct n.
  - right; intro HC; inv HC.
  - left; constructor.
Qed.

Definition copred (n : conat) : conat :=
  match n with
  | cozero => cozero
  | cosucc n' => n'
  end.

(** The supremum of a chain of conats. Uses strong LPO. *)
CoFixpoint conat_sup (ch : nat -> conat) : conat :=
  match LPO_option (fun i => not_cozero_dec (ch i)) with
  | Some i => match ch i with
             | cozero => cozero
             | cosucc n => cosucc (conat_sup (copred ∘ ch))
             end
  | None => cozero
  end.

Lemma chain_copred (ch : nat -> conat) :
  chain ch ->
  chain (copred ∘ ch).
Proof.
  intros Hch i; unfold compose; simpl.
  destruct (ch i) eqn:Hchi; simpl; try constructor.
  - specialize (Hch i); rewrite Hchi in Hch; inv Hch; simpl; auto.
Qed.

#[global]
  Instance monotone_copred : Proper (leq ==> leq) copred.
Proof.
  intro a; revert a; cofix CH; intros x b Hab; inv Hab; auto; constructor.
Qed.

#[global]
  Instance monotone_pred : Proper (leq ==> leq) pred.
Proof.
  intro a; induction a; intros b Hab; inv Hab; simpl; auto; lia.
Qed.

Lemma directed_copred (ch : nat -> conat) :
  directed ch ->
  directed (copred ∘ ch).
Proof.
  intros Hch i j; unfold compose; simpl.
  specialize (Hch i j); destruct Hch as [k [H0 H1]].
  exists k; split; apply monotone_copred; auto.
Qed.

Lemma directed_pred (ch : nat -> nat) :
  directed ch ->
  directed (pred ∘ ch).
Proof.
  intros Hch i j; unfold compose; simpl.
  specialize (Hch i j); destruct Hch as [k [H0 H1]].
  exists k; split; apply monotone_pred; auto.
Qed.

Lemma chain_pred (ch : nat -> nat) :
  chain ch ->
  chain (pred ∘ ch).
Proof.
  intros Hch i; unfold compose; simpl.
  destruct (ch i) eqn:Hchi; simpl; try lia.
  - specialize (Hch i); rewrite Hchi in Hch; inv Hch; simpl; lia.
Qed.

Lemma conat_sup_ub (ch : nat -> conat) :
  directed ch ->
  upper_bound (conat_sup ch) ch.
Proof.
  revert ch.
  cofix CH; intros ch Hch i.
  simpl.
  replace (conat_sup ch) with (unf (conat_sup ch)).
  2: { rewrite <- unf_eq; reflexivity. }
  simpl.
  destruct (LPO_option (fun n : nat => not_cozero_dec (ch n))) eqn:Ho.
  - apply LPO_option_some in Ho.
    destruct (ch n) eqn:Hchn.
    + inv Ho.
    + clear Ho.
      destruct (ch i) eqn:Hchi.
      * constructor.
      * constructor.
        replace c0 with ((copred ∘ ch) i).
        2: { unfold compose; rewrite Hchi; reflexivity. }
        apply CH, directed_copred; auto.
  - apply LPO_option_none with (n:=i) in Ho.
    destruct (ch i); try constructor; exfalso; apply Ho; constructor.
Qed.

Lemma upper_bound_copred_succ (n : conat) (ch : nat -> conat) :
  upper_bound (cosucc n) ch ->
  upper_bound n (copred ∘ ch).
Proof.
  intros Hub i; specialize (Hub i); unfold compose.
  destruct (ch i) eqn:Hchi.
  - constructor.
  - inv Hub; auto.
Qed.

Lemma conat_sup_const (l : conat) :
  conat_eq (conat_sup (fun _ : nat => l)) l.
Proof.
  revert l; cofix CH; intro l.
  rewrite unf_eq; simpl.
  destruct (LPO_option (fun _ : nat => not_cozero_dec l)) eqn:H.
  - apply LPO_option_some in H.
    destruct l; constructor; unfold compose; apply CH.
  - apply LPO_option_none with (n:=O) in H.
    destruct l; try constructor; exfalso; apply H; constructor.
Qed.

Lemma conat_sup_lub (ch : nat -> conat) (ub : conat) :
  directed ch ->
  upper_bound ub ch ->
  conat_sup ch ⊑ ub.
Proof.
  revert ch ub.
  cofix CH; intros ch ub Hch Hub.
  destruct ub.
  - replace ch with (fun _ : nat => cozero).
    + rewrite conat_sup_const; reflexivity.
    + ext i; specialize (Hub i); destruct (ch i); auto; inv Hub.
  - rewrite unf_eq; simpl.
    destruct (LPO_option (fun n : nat => not_cozero_dec (ch n))) eqn:Ho.
    2: { constructor. }
    destruct (ch n) eqn:Hchn.
    + constructor.
    + pose proof Hub as Hub'.
      specialize (Hub n); rewrite Hchn in Hub; inv Hub.
      constructor; apply CH; auto.
      * apply directed_copred; auto.
      * eapply upper_bound_copred_succ; eauto.
Qed.

Lemma conat_sup_supremum (ch : nat -> conat) :
  directed ch ->
  supremum (conat_sup ch) ch.
Proof.
  intro Hch; split.
  - apply conat_sup_ub; auto.
  - intros; apply conat_sup_lub; auto.
Qed.

#[global]
  Instance CPO_conat : CPO conat.
Proof.
  constructor; intros ch Hch.
  exists (conat_sup ch); apply conat_sup_supremum; auto.
Qed.
#[global] Hint Resolve CPO_conat : conat.

Lemma nat_inj_conat_prefix_coconat_prefix (n : conat) (i : nat) :
  nat_inj (conat_prefix i n) = coconat_prefix i n.
Proof.
  revert n; induction i; intro n; simpl; auto.
  destruct n; simpl; auto; rewrite IHi; auto.
Qed.

Lemma equ_nat (a b : nat) :
  a === b -> a = b.
Proof. unfold equiv, equ; simpl; lia. Qed.

Lemma supremum_pred_S (n : nat) (ch : nat -> nat) :
  supremum (S n) ch ->
  supremum n (pred ∘ ch).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); unfold compose.
    inv Hub; simpl; auto; lia.
  - unfold compose; intros y Hy.
    unfold upper_bound in Hy.
    simpl in Hy.
    assert (H: upper_bound (S y) ch).
    { intro i.
      specialize (Hy i); simpl in Hy.
      destruct (ch i) eqn:Hchi.
      - constructor; lia.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub.
        apply le_succ; auto; lia. }
    apply Hlub in H; inv H; auto; simpl; lia.
Qed.

Lemma supremum_S' (n : nat) (ch : nat -> nat) :
  supremum (S n) ch ->
  exists i n', ch i = S n' /\ n' ⊑ n.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_O_dec (ch n))).
  - destruct e as [m H].
    specialize (Hub m).
    destruct (ch m) eqn:Hchm.
    + inv H.
    + exists m, n0; split; auto; simpl in *; lia.
  - assert (H: upper_bound O ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + exfalso; apply n0; exists i; rewrite Hchi; constructor. }
    apply Hlub in H; inv H.
Qed.

Lemma supremum_cosucc' (n : conat) (ch : nat -> conat) :
  supremum (cosucc n) ch ->
  exists i n', ch i = cosucc n' /\ n' ⊑ n.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_cozero_dec (ch n))).
  - destruct e as [m H].
    specialize (Hub m).
    inv Hub.
    + rewrite <- H1 in H; inv H.
    + exists m, n0; auto.
  - assert (H: upper_bound cozero ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + exfalso; apply n0; exists i; rewrite Hchi; constructor. }
    apply Hlub in H; inv H.
Qed.

Lemma nat_compact (n : nat) (ch : nat -> nat) :
  directed ch ->
  supremum n ch ->
  exists i, ch i = n.
Proof.
  revert ch; induction n; intros ch Hch Hn.
  - exists O; apply equ_nat; split.
    + apply Hn.
    + simpl; lia.
  - pose proof Hn as Hn'.
    apply supremum_pred_S in Hn.
    apply IHn in Hn; clear IHn.
    2: { apply directed_pred; auto. }
    destruct Hn as [j Hj].
    unfold compose in Hj.
    unfold pred in Hj.
    destruct (ch j) eqn:Hchj; subst.
    + apply supremum_S' in Hn'.
      destruct Hn' as [i [n' [Hi Hn']]]; inv Hn'; exists i; auto.
    + destruct Hn' as [H0 H1]; specialize (H0 j).
      rewrite Hchj in H0; inv H0; exists j; auto.
Qed.

Lemma nat_eq_conat_eq (a b : conat) :
  (forall i, conat_prefix i a = conat_prefix i b) ->
  a = b.
Proof.
  intro H; apply conat_ext.
  revert a b H; cofix CH; intros a b H.
  destruct a.
  - destruct b.
    + constructor.
    + specialize (H (S O)); inv H.
  - destruct b.
    + specialize (H (S O)); inv H.
    + pose proof H as H'.
      specialize (H' (S O)); inv H'.
      constructor; apply CH; intro i; specialize (H (S i)); inv H; auto.
Qed.

Lemma nat_le_conat_le (a b : nat) :
  a ⊑ b ->
  nat_inj a ⊑ nat_inj b.
Proof.
  revert b; induction a; simpl; intros b Hab.
  - constructor.
  - destruct b; inv Hab; constructor; apply IHa; auto; simpl; lia.
Qed.

#[global]
  Instance monotone_nat_inj : Proper (leq ==> leq) nat_inj.
Proof. intros a b Hab; apply nat_le_conat_le; auto. Qed.

Lemma conat_le_nat_le (a b : nat) :
  nat_inj a ⊑ nat_inj b ->
  a ⊑ b.
Proof.
  revert b; induction a; simpl; intros b Hab.
  - lia.
  - destruct b; inv Hab; apply IHa in H1; simpl in *; lia.
Qed.

Lemma supremum_copred_succ (n : conat) (ch : nat -> conat) :
  supremum (cosucc n) ch ->
  supremum n (copred ∘ ch).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); unfold compose.
    inv Hub; simpl; auto; constructor.
  - unfold compose; intros y Hy.
    unfold upper_bound in Hy.
    simpl in Hy.
    assert (H: upper_bound (cosucc y) ch).
    { intro i.
      specialize (Hy i); simpl in Hy.
      destruct (ch i) eqn:Hchi.
      - constructor.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub; inv Hub.
        constructor; auto. }
    apply Hlub in H; inv H; auto.
Qed.

Lemma conat_prefix_continuous (n : nat) :
  continuous (conat_prefix n).
Proof.
  induction n; intros ch Hch x Hx; unfold compose; simpl.
  { apply supremum_const. }
  destruct x.
  - apply supremum_cozero in Hx.
    apply supremum_const'.
    apply equ_arrow; intro i; rewrite Hx; reflexivity.
  - assert (Hc: supremum x (copred ∘ ch)).
    { eapply supremum_copred_succ; eauto. }
    split.
    + intro i; destruct (ch i) eqn:Hchi; simpl.
      * lia.
      * destruct Hx as [Hub Hlub].
        specialize (Hub i).
        rewrite Hchi in Hub.
        inv Hub.
        apply le_succ.
        apply conat_prefix_monotone; auto.
    + intros ub Hub; destruct ub.
      * assert (H: forall i, ch i = cozero).
        { intro i; specialize (Hub i); simpl in Hub.
          destruct (ch i); auto; inv Hub. }
        assert (supremum cozero ch).
        { apply supremum_const'; apply equ_arrow; intro i.
          unfold const; rewrite H; reflexivity. }
        eapply supremum_unique in Hx; eauto.
        apply equ_conat_eq in Hx; inv Hx.
      * pose proof Hx as Hx'.
        apply supremum_cosucc' in Hx'.
        destruct Hx' as [i [l' [Hx' Hx'']]].
        pose proof Hub as Hub'.
        specialize (Hub' i).
        simpl in Hub'.
        rewrite Hx' in Hub'.
        clear Hx' i.
        apply le_succ.
        eapply IHn.
        2: { eauto. }
        { apply directed_copred; auto. }
        intro i; specialize (Hub i); simpl in Hub.
        unfold compose.
        destruct (ch i) eqn:Hchi; simpl.
        { destruct n; simpl; lia. }
        { lia. }
Qed.

Lemma coconat_prefix_le (n : conat) (i : nat) :
  coconat_prefix i n ⊑ n.
Proof.
  revert n; induction i; intro n; simpl; try constructor.
  destruct n; constructor; apply IHi.
Qed.

Lemma coconat_prefix_supremum (n : conat) :
  supremum n (fun i => coconat_prefix i n).
Proof.
  split.
  - intro i. apply coconat_prefix_le.
  - revert n; cofix CH; intros n ub Hub.
    destruct ub.
    + specialize (Hub (S O)).
      destruct n; inv Hub; constructor.
    + destruct n.
      * constructor.
      * pose proof Hub as Hub'.
        specialize (Hub' (S O)).
        inv Hub'.
        constructor; apply CH.
        intro i.
        specialize (Hub (S i)); simpl in Hub.
        inv Hub; auto.
Qed.

#[global]
  Instance Compact_nat : Compact nat.
Proof.
  constructor; intros a f Hf Ha.
  apply nat_compact in Ha; auto.
  destruct Ha as [i Ha]; subst; exists i; reflexivity.
Qed.

#[global]
  Instance Dense_conat : Dense conat nat :=
  { incl := nat_inj
  ; ideal := flip conat_prefix }.

#[global]
  Instance aCPO_conat : aCPO conat nat.
Proof.
  constructor.
  - intros a b; split.
    + apply nat_le_conat_le.
    + apply conat_le_nat_le.
  - apply chain_conat_prefix.
  - intros a b Hab i; apply conat_prefix_monotone; auto.
  - apply conat_prefix_continuous.
  - intro a; simpl; unfold compose, flip.
    replace (fun i => nat_inj (conat_prefix i a)) with (fun i => coconat_prefix i a).
    + apply coconat_prefix_supremum.
    + ext i; rewrite nat_inj_conat_prefix_coconat_prefix; reflexivity.
Qed.

Lemma neq_nat_inj_omega (n : conat) :
  (forall m, n <> nat_inj m) ->
  n = omega.
Proof.
  intro H.
  apply ext; split.
  { apply le_omega. }
  revert n H; cofix CH; intros n H.
  destruct n.
  { exfalso; specialize (H O); apply H; reflexivity. }
  rewrite unf_eq; simpl.
  constructor.
  apply CH.
  intros m HC.
  specialize (H (S m)).
  apply H; simpl.
  rewrite HC; reflexivity.
Qed.

Lemma conat_finite_or_omega (n : conat) :
  (exists m, n = nat_inj m) \/ n = omega.
Proof.
  destruct (classic (exists m : nat, n = nat_inj m)); auto.
  right; apply neq_nat_inj_omega.
  intros m HC; subst; apply H; exists m; reflexivity.
Qed.

Fixpoint nat_iter {A} (z : A) (f : A -> A) (n : nat) : A :=
  match n with
  | O => z
  | S n' => f (nat_iter z f n')
  end.

#[global]
  Instance monotone_nat_iter {A} `{OType A} (z : A) (f : A -> A)
  {Hz : forall n, z ⊑ nat_iter z f n}
  {Hf: Proper (leq ==> leq) f}
  : Proper (leq ==> leq) (nat_iter z f).
Proof.
  intro n; revert Hz Hf; revert z f; induction n;
    intros z f Hz Hf m Hnm; simpl; auto.
  - destruct m; simpl in *; try lia.
    apply Hf.
    apply IHn; auto; lia.
Qed.
#[global] Hint Resolve monotone_nat_iter : conat.

#[global]
 Instance antimonotone_nat_iter {A} `{OType A} (z : A) (f : A -> A)
 {Hz : forall n, nat_iter z f n ⊑ z}
 {Hf: Proper (leq ==> leq) f}
  : Proper (leq ==> flip leq) (nat_iter z f).
Proof.
  unfold flip.
  intro n; revert Hz Hf; revert z f; induction n;
    intros z f Hz Hf m Hnm; simpl; auto.
  - destruct m; simpl in *; try lia.
    apply Hf, IHn; auto; lia.
Qed.
#[global] Hint Resolve antimonotone_nat_iter : conat.

Definition coiter {A} `{PType A} (f : A -> A) : conat -> A :=
  co (nat_iter ⊥ f).

Definition coopiter {A} `{TType A} (z : A) (f : A -> A) : conat -> A :=
  coop (nat_iter ⊤ f).

(** Computation lemmas for coiters. *)

Lemma co_iter_zero {A} `{CPO A} (z : A) (f : A -> A) :
  co (nat_iter z f) cozero === z.
Proof.
  apply supremum_sup, supremum_const', equ_arrow; intros []; reflexivity.
Qed.

Lemma co_iter_succ {A} `{CPO A} (z : A) (f : A -> A) (n : conat) :
  z ⊑ f z ->
  ( forall n, z ⊑ nat_iter z f n) ->
  continuous f ->
  co (nat_iter z f) (cosucc n) === f (co (nat_iter z f) n).
Proof.
  intros Hz Hfz Hf.
  apply supremum_sup.
  apply shift_supremum'' with (f := fun i => f (nat_iter z f (ideal n i))); auto.
  { apply Hf.
    { apply monotone_directed; auto with conat order.
      apply chain_directed, chain_ideal. }
    { apply sup_spec.
      { apply monotone_directed; auto with conat order.
        apply chain_directed, chain_ideal. } } }
  apply equ_arrow; intro i; reflexivity.
Qed.

Lemma co_iter_zero' {A} {o : OType A} `{@ExtType A o} `{@CPO A o}
  (z : A) (f : A -> A) :
  co (nat_iter z f) cozero = z.
Proof. apply ext, co_iter_zero. Qed.

Lemma co_iter_succ' {A} {o : OType A} `{@ExtType A o} `{@CPO A o}
  (z : A) (f : A -> A) (n : conat) :
  z ⊑ f z ->
  ( forall n, z ⊑ nat_iter z f n) ->
  continuous f ->
  co (nat_iter z f) (cosucc n) = f (co (nat_iter z f) n).
Proof. intros Hz Hfz Hf; apply ext, co_iter_succ; auto. Qed.

Lemma coiter_zero {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA}
  (f : A -> A) :
  coiter f cozero === ⊥.
Proof. apply co_iter_zero. Qed.

Lemma coiter_succ {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA}
  (f : A -> A) (n : conat) :
  continuous f ->
  coiter f (cosucc n) === f (coiter f n).
Proof.
  intro Hf; apply co_iter_succ; auto.
  - apply bot_le.
  - intro; apply bot_le.
Qed.

Lemma coiter_succ' {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA} `{@ExtType _ oA}
  (f : A -> A) (n : conat) :
  continuous f ->
  coiter f (cosucc n) = f (coiter f n).
Proof. intro Hf; apply ext, coiter_succ; auto. Qed.

Lemma coiter_zero' {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA} `{@ExtType _ oA}
  (f : A -> A) :
  coiter f cozero = ⊥.
Proof. apply ext, coiter_zero. Qed.

CoInductive infinite : conat -> Prop :=
| infinite_succ : forall n, infinite n -> infinite (cosucc n).

Lemma infinite_iff_omega (n : conat) :
  infinite n <-> n = omega.
Proof.
  split.
  - intro Hn.
    destruct (@conat_finite_or_omega n); auto.
    exfalso; destruct H as [m Hm]; subst.
    revert Hn; induction m; intro HC; inv HC; auto.
  - intros ->; cofix CH; rewrite unf_eq; constructor; auto.
Qed.

Extract Constant coiter => "
  \ o p f n ->
    case n of
      Cozero -> bot o p
      Cosucc n' -> f (coiter o p f n')
".

Lemma conat_prefix_omega (i : nat) :
  conat_prefix i omega = i.
Proof. induction i; simpl; auto. Qed.

Lemma not_finite_omega n :
  ~ finite n omega.
Proof.
  induction n; intro HC.
  - inv HC.
    rewrite (@unf_eq omega) in H.
    inv H.
  - rewrite unf_eq in HC.
    inv HC.
    congruence.
Qed.

Lemma finite_inj_inv n m :
  finite n (nat_inj m) ->
  n = m.
Proof. revert n; induction m; intros n Hnm; inv Hnm; auto. Qed.

Lemma finite_inj n :
  finite n (nat_inj n).
Proof. induction n; constructor; auto. Qed.

Lemma conat_to_conat'_to_conat (n : conat') :
  conat_to_conat' (conat'_to_conat n) = n.
Proof.
  destruct n; simpl.
  - unfold conat_to_conat'.
    destr.
    + destruct e as [i Hi].
      f_equal.
      compute.
      destr.
      apply finite_inj_inv in f; auto.
    + exfalso; apply n0; exists n.
      apply finite_inj.
  - unfold conat_to_conat'.
    destr.
    + destruct e as [i HC].
      exfalso; eapply not_finite_omega; eauto.
    + destruct u; auto.
Qed.

#[global]
 Instance Proper_conat_eq : Proper (conat_eq ==> conat_eq ==> flip impl) conat_eq.
Proof.
  cofix CH; intros a b Hab c d Hcd Hbd.
  destruct Hab.
  - inv Hbd; symmetry; auto.
  - inv Hbd; inv Hcd.
    constructor; eapply CH; eauto.
Qed.

#[global]
 Instance Proper_cosucc : Proper (conat_eq ==> conat_eq) cosucc.
Proof. intros n m Hnm; constructor; auto. Qed.

Definition nat_conat_le : nat -> conat -> Prop :=
  nat_iter (const True) (fun f m => match m with
                              | cozero => False
                              | cosucc m' => f m'
                              end).

#[global]
 Instance antimonotone_nat_conat_le : Proper (leq ==> flip leq) nat_conat_le.
Proof.
  apply antimonotone_nat_iter.
  - intros i n H; apply I.
  - intros f g Hfg [] Hn; auto; apply Hfg; auto.
Qed.
#[global] Hint Resolve antimonotone_nat_conat_le : conat.

Definition conat_le' : conat -> conat -> Prop :=
  coop nat_conat_le.

Lemma conat_le_conat_le' (n m : conat) :
  n ⊑ m <-> conat_le' n m.
Proof with auto with conat order.
  split.
  - intro Hnm.
    apply coop_intro2...
    intro i; simpl; unfold flip.
    revert Hnm; revert n m.
    induction i; intros n m Hnm; simpl.
    + constructor.
    + destruct n.
      * constructor.
      * inv Hnm; apply IHi; auto.
  - revert n m; cofix CH; intros n m Hnm.
    destruct n.
    + constructor.
    + destruct m.
      * apply coop_elim2 with (i := S O) in Hnm...
        inv Hnm.
      * constructor; apply CH.
        apply coop_intro2...
        intro i; apply coop_elim2 with (i := S i) in Hnm...
Qed.

(* Definition coplus (n : conat) : conat -> conat := *)
(*   (* coiter (compose cosucc) n. *) *)
(*   co (nat_iter id (compose cosucc)) n. *)

(* Lemma coplus_zero_l (n : conat) : *)
(*   coplus cozero n = n. *)
(* Proof. *)
(*   unfold coplus; simpl. *)
(*   rewrite co_iter_zero'; auto. *)
(* Qed. *)

(* (* Lemma coplus_zero_r (n : conat) : *) *)
(* (*   coplus n cozero = n. *) *)
(* (* Proof. *) *)

(* (*   unfold coplus; simpl. *) *)
(* (*   rewrite co_iter_zero'; auto. *) *)
(* (* Qed. *) *)

Lemma succ_conat_le (n : conat) :
  n ⊑ cosucc n.
Proof.
  revert n; cofix CH; intros [].
  { constructor. }
  constructor; apply CH.
Qed.

(* Lemma ikdfg (n : nat) (m : conat) : *)
(*   m ⊑ nat_iter (fun x0 : conat => x0) (compose cosucc) n m. *)
(* Proof. *)
(*   revert m; induction n; intro m; simpl. *)
(*   { reflexivity. } *)
(*   (* unfold compose in *. *) *)
(*   destruct m; constructor. *)
(*   etransitivity. *)
(*   { apply IHn. } *)
(*   admit. *)
(* Admitted. *)

(* Lemma coplus_succ (n m : conat) : *)
(*   coplus (cosucc n) m = cosucc (coplus n m). *)
(* Proof. *)
(*   unfold coplus; simpl. *)
(*   rewrite co_iter_succ'; auto. *)
(*   { intro x; unfold id, compose. *)
(*     apply succ_conat_le. } *)
(*   { intros x y; unfold id. simpl. *)
(*     apply ikdfg. } *)
(*   intros ch Hch f Hf. *)
(*   apply supremum_apply. *)
(*   intro x; unfold compose. *)
(*   apply continuous_cosucc. *)
(*   { intros i j. *)
(*     specialize (Hch i j). *)
(*     destruct Hch as [k [Hik Hjk]]. *)
(*     exists k; split; auto. } *)
(*   apply apply_supremum; auto. *)
(* Qed. *)

(* Lemma coplus_comm_leq (n m : conat) : *)
(*   coplus n m ⊑ coplus m n. *)
(* Proof with auto with conat order. *)
(*   apply conat_le_conat_le'. *)
(*   apply coop_intro2... *)
(*   intro i; simpl; unfold flip. *)
(*   revert n m; induction i; intros n m; simpl. *)
(*   { constructor. } *)
(*   destruct n. *)
(*   { rewrite coplus_zero_l. *)

(* Lemma coplus_comm (n m : conat) : *)
(*   coplus n m = coplus m n. *)
(* Proof. *)
(*   apply ext. *)
(*   split. *)

CoFixpoint coplus (n m : conat) : conat :=
  match n with
  | cozero => m
  | cosucc n' => cosucc (coplus n' m)
  end.

(* Lemma plus_0_r (n : nat) : *)
(*   n = n + 0. *)
(* Proof. induction n; simpl; auto. Qed. *)

(* Lemma S_plus (n m : nat) : *)
(*   S (n + m) = n + S m. *)
(* Proof. revert m; induction n; intro m; simpl; auto. Qed. *)

(* Lemma plus_comm (n m : nat) : *)
(*   n + m = m + n. *)
(* Proof. *)
(*   revert m; induction n; intros m; simpl. *)
(*   - apply plus_0_r. *)
(*   - rewrite IHn. *)
(*     apply S_plus. *)
(* Qed. *)

Lemma coplus_zero_l (n : conat) :
  coplus cozero n = n.
Proof.
  rewrite (@unf_eq (coplus _ _)); simpl.
  destruct n; reflexivity.
Qed.

Lemma coplus_zero_r (n : conat) :
  coplus n cozero = n.
Proof.
  apply conat_ext.
  revert n; cofix CH; intros [].
  - rewrite unf_eq; reflexivity.
  - rewrite (@unf_eq (coplus _ _)); constructor; apply CH.
Qed.

Lemma coplus_succ (n m : conat) :
  coplus (cosucc n) m = cosucc (coplus n m).
Proof. rewrite (@unf_eq (coplus _ _)); auto. Qed.

Lemma cosucc_coplus (n m : conat) :
  cosucc (coplus n m) = coplus n (cosucc m).
Proof.
  apply conat_ext.
  revert n m; cofix CH; intros [|n'] m.
  - rewrite (@unf_eq (coplus cozero _)); simpl.
    rewrite (@unf_eq (coplus cozero _)); simpl.
    destruct m; reflexivity.
  - rewrite (@unf_eq (coplus _ _)); simpl.
    rewrite (@unf_eq (coplus (cosucc _) _)); simpl.
    constructor.
    apply CH.
Qed.

Lemma coplus_comm (n m : conat) :
  coplus n m = coplus m n.
Proof.
  apply conat_ext.
  revert n m; cofix CH; intros n m.
  destruct n as [|n'].
  - rewrite unf_eq; simpl.
    rewrite <- coplus_zero_r.
    destruct m; reflexivity.
  - rewrite unf_eq; simpl.
    destruct m as [|m'].
    + rewrite coplus_zero_r.
      rewrite (@unf_eq (coplus _ _)); reflexivity.
    + rewrite (@unf_eq (coplus (cosucc _) _)); simpl.
      constructor.
      rewrite <- cosucc_coplus.
      rewrite <- cosucc_coplus.
      constructor.
      apply CH.
Qed.

(* Definition nmult : nat -> conat -> conat := *)
(*   nat_iter (const cozero) (fun f m => coplus m (f m)). *)

(* Definition nmult' (n : conat) : nat -> conat := *)
(*   nat_iter cozero (fun m => coplus n m). *)

(* Lemma nmult_nmult' n m : *)
(*   nmult n m = nmult' m n. *)
(* Proof. *)
(*   unfold nmult, nmult'. *)
(*   revert m; induction n; intro m; simpl; auto. *)
(*   rewrite IHn; auto. *)
(* Qed. *)

(* Lemma le_coplus (n m : conat) : *)
(*   n ⊑ coplus n m. *)
(* Proof. *)
(*   revert n m; cofix CH; intros [|n'] m. *)
(*   - constructor. *)
(*   - rewrite (@unf_eq (coplus _ _)); simpl. *)
(*     constructor. *)
(*     apply CH. *)
(* Qed. *)

(* #[global] *)
(*   Instance monotone_coplus (n : conat) : Proper (leq ==> leq) (coplus n). *)
(* Proof. *)
(*   revert n; cofix CH; intros n a b Hab. *)
(*   destruct b as [|b']. *)
(*   - inv Hab; rewrite <- coplus_zero_r; reflexivity. *)
(*   - destruct a as [|a']. *)
(*     + rewrite coplus_zero_r. *)
(*       apply le_coplus. *)
(*     + inv Hab. *)
(*       rewrite <- 2!cosucc_coplus. *)
(*       constructor. *)
(*       apply CH; auto. *)
(* Qed. *)

(* #[global] *)
(*  Instance monotone_nmult : Proper (leq ==> leq) nmult. *)
(* Proof. *)
(*   apply monotone_nat_iter. *)
(*   - intros; constructor. *)
(*   - intros f g Hfg n; apply monotone_coplus; auto. *)
(* Qed. *)

(* #[global] *)
(*  Instance monotone_nmult' (n : conat) : Proper (leq ==> leq) (nmult' n). *)
(* Proof. *)
(*   apply monotone_nat_iter. *)
(*   - intros; constructor. *)
(*   - intros a b Hab; apply monotone_coplus; auto. *)
(* Qed. *)

(* Definition comult : conat -> conat -> conat := *)
(*   co nmult. *)

(* Definition comult' (n : conat) : conat -> conat := *)
(*   co (nmult' n). *)

(* Lemma comult'_zero_l (n : conat) : *)
(*   comult' cozero n = cozero. *)
(* Proof. Admitted. *)

(* Lemma comult'_zero_r (n : conat) : *)
(*   comult' n cozero = cozero. *)
(* Proof. Admitted. *)

(* Lemma comult'_succ (n m : conat) : *)
(*   comult' n (cosucc m) = coplus n (comult' n m). *)
(* Proof. Admitted. *)

(* Lemma coplus_inj a b : *)
(*   coplus (nat_inj a) (nat_inj b) = nat_inj (a + b). *)
(* Proof. *)
(*   revert b; induction a; intro b; simpl. *)
(*   - rewrite coplus_zero_l; auto. *)
(*   - rewrite coplus_succ, IHa; auto. *)
(* Qed. *)

(* Lemma comult'_inj a b : *)
(*   comult' (nat_inj a) (nat_inj b) = nat_inj (a * b). *)
(* Proof. *)
(*   revert a; induction b; intro a; simpl. *)
(*   - rewrite comult'_zero_r, Nat.mul_0_r; auto. *)
(*   - rewrite <- mult_n_Sm. *)
(*     rewrite <- coplus_inj. *)
(*     rewrite comult'_succ. *)
(*     rewrite coplus_comm. *)
(*     rewrite IHb; auto. *)
(* Qed. *)

(* Lemma comult'_comm (n m : conat) : *)
(*   comult' n m = comult' m n. *)
(* Proof. *)
(*   destruct (@conat_finite_or_omega n); subst. *)
(*   - destruct H as [a ?]; subst. *)
(*     destruct (@conat_finite_or_omega m); subst. *)
(*     + destruct H as [b ?]; subst. *)
(*       rewrite 2!comult'_inj; f_equal; lia. *)
(*     + admit. *)
(*   - admit. *)
(* Admitted. *)

(* Lemma comult_comult' (n m : conat) : *)
(*   comult n m = comult' m n. *)
(* Proof. *)
(*   unfold comult, comult'. *)
(*   unfold co. *)
(*   unfold compose. *)
(*   apply ext. *)
(*   rewrite sup_apply. *)
(*   2: { admit. } *)
(*   apply eq_equ. *)
(*   f_equal; ext i. *)
(*   apply nmult_nmult'. *)
(* Admitted. *)

(* Lemma comult'_comm (n m : conat) : *)
(*   comult' n m = comult' m n. *)
(* Proof. *)
(*   unfold comult'. *)
(*   unfold co. *)
(*   f_equal. *)
(*   ext i. *)
(*   simpl; unfold compose, flip. *)
(*   revert n m; induction i; intros n m; simpl; auto. *)
(*   destruct m as [|m']. *)
(*   - unfold nmult'. simpl. *)
(*     destruct n as [|n']; simpl; auto. *)
(*     rewrite coplus_zero_l. *)
(*     admit. *)
(*   - unfold nmult'. simpl. *)

(* Lemma comult_zero_l (n : conat) : *)
(*   comult cozero n = cozero. *)
(* Proof. unfold comult; rewrite coiter_zero'; auto. Qed. *)

(* Lemma comult_zero_r (n : conat) : *)
(*   comult n cozero = cozero. *)
(* Proof. Admitted. *)

(* Lemma comult_succ (n m : conat) : *)
(*   comult (cosucc n) m = coplus m (comult n m). *)
(* Proof. *)
(*   unfold comult. *)
(*   rewrite coiter_succ'; auto. *)
(*   admit. *)
(* Admitted. *)

(* Lemma nat_conat_le_trans n m p : *)
(*   n ⊑ m -> *)
(*   nat_conat_le m p -> *)
(*   nat_conat_le n p. *)
(* Admitted. *)

(* Lemma nat_conat_le_prefix i n : *)
(*   nat_conat_le (conat_prefix i n) n. *)
(* Admitted. *)

(* Lemma comult_comm_leq (n m : conat) : *)
(*   comult n m ⊑ comult m n. *)
(* Proof with auto with conat order. *)
(*   apply conat_le_conat_le'. *)
(*   apply coop_intro2... *)
(*   intro i; simpl; unfold flip. *)
(*   revert n m; induction i; intros n m; simpl. *)
(*   { constructor. } *)
(*   destruct n as [|n']. *)
(*   - rewrite comult_zero_l; constructor. *)
(*   - rewrite comult_succ. *)
(*     destruct m as [|m']; simpl. *)
(*     + rewrite comult_zero_r; constructor. *)
(*     + rewrite comult_succ. *)
(*       rewrite (@unf_eq (coplus (cosucc _) _)); simpl. *)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult lv0 (mult lv1 lv2)) (mult lv1 (mult lv2 lv0))).
Admitted.
QuickChick conj15eqsynthconj6.


Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FragmentFacts.
Require Import Undecidability.FOL.Deduction.FragmentND.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Vector Lia.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Set Default Proof Using "Type".

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section Soundness.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Lemma soundness {ff : falsity_flag} A phi :
    A ⊢I phi -> valid_ctx A phi.
  Proof.
    remember intu as p.
    induction 1; intros D I rho HA; comp.
    - intros Hphi. apply IHprv; trivial. intros ? []; subst. assumption. now apply HA.
    - now apply IHprv1, IHprv2.
    - intros d. apply IHprv; trivial. intros psi [psi'[<- H' % HA]] % in_map_iff.
      eapply sat_comp. now comp.
    - eapply sat_comp, sat_ext. 2: apply (IHprv Heqp D I rho HA (eval rho t)). now intros [].
    - apply (IHprv Heqp) in HA. firstorder.
    - firstorder.
    - discriminate.
  Qed.

  Lemma soundness' {ff : falsity_flag} phi :
    [] ⊢I phi -> valid phi.
  Proof.
    intros H % soundness. firstorder.
  Qed.

  Lemma intuitionistic_is_classical {ff:falsity_flag} A phi :
    A ⊢I phi -> A ⊢C phi.
  Proof.
  induction 1; comp.
  - now apply II, IHprv.
  - now eapply IE, IHprv2.
  - now eapply AllI, IHprv.
  - now eapply AllE, IHprv.
  - now eapply Exp, IHprv.
  - now eapply Ctx, H.
  - apply Pc.
  Qed.

  Lemma classical_soundness (LEM:forall P:Prop, P \/ ~P) {ff : falsity_flag} A phi :
    A ⊢C phi -> valid_ctx A phi.
  Proof.
    induction 1; intros D I rho HA; cbn.
    - intros Hphi. apply IHprv; trivial. intros ? []; subst. assumption. now apply HA.
    - now apply IHprv1, IHprv2.
    - intros d. apply IHprv; trivial. intros psi [psi'[<- H' % HA]] % in_map_iff.
      eapply sat_comp. now comp.
    - eapply sat_comp, sat_ext. 2: apply (IHprv D I rho HA (eval rho t)). now intros [].
    - apply (IHprv) in HA. firstorder.
    - firstorder.
    - intros H.
      destruct (LEM (rho ⊨ phi)) as [Ht|Hf]. 1:easy.
      destruct (LEM (rho ⊨ psi)) as [Ht2|Hf2]; tauto.
  Qed.

  Lemma sound_for_classical_model {p:peirce} {ff : falsity_flag} A phi (D : Type) (I : interp D) (rho : env D) :
    classical I -> A ⊢ phi -> rho ⊫ A -> rho ⊨ phi.
  Proof.
    intros LEM HD. revert LEM rho. induction HD; cbn; intros LEM rho HA.
    - intros Hphi. apply IHHD. 1:easy. intros a [<-|Ha]; try easy. now apply HA.
    - now apply IHHD1, IHHD2.
    - intros d. apply IHHD; trivial. intros psi [psi'[<- H' % HA]] % in_map_iff.
      eapply sat_comp. now comp.
    - eapply sat_comp, sat_ext. 2: apply (IHHD LEM rho HA (eval rho t)). now intros [].
    - apply (IHHD) in HA; cbn in *; eauto.
    - apply HA, H.
    - intros H. unfold classical in LEM. cbn in LEM. eapply LEM. exact H.
  Qed.

End Soundness.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.ModalLogic.
Require Import Logic.ModalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.
Import SeparationLogicNotation.

Class SeparationTransparentModality1 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} (Gamma: Provable L) := {
  sepcon_boxp: forall x y, |-- boxp x * boxp y --> boxp (x * y)
}.

Class SeparationTransparentModality2 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} (Gamma: Provable L) := {
  boxp_sepcon: forall x y, |-- boxp (x * y) --> boxp x * boxp y
}.

Class SeparationTransparentModality3 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) := {
  wand_boxp: forall x y, |-- (boxp x -* boxp y) --> boxp (x -* y)
}.

Class SeparationTransparentModality4 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) := {
  boxp_wand: forall x y, |-- boxp (x -* y) --> (boxp x -* boxp y)
}.

Instance SeparationTransparentModality14 (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sepconAX: SepconAxiomatization L Gamma} {wandAX: WandAxiomatization L Gamma} {sm1Gamma: SeparationTransparentModality1 L Gamma}:
  SeparationTransparentModality4 L Gamma.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_boxp.
  rewrite provable_wand_sepcon_modus_ponens1.
  apply provable_impp_refl.
Qed.

Instance SeparationTransparentModality41 (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sepconAX: SepconAxiomatization L Gamma} {wandAX: WandAxiomatization L Gamma} {sm4Gamma: SeparationTransparentModality4 L Gamma}:
  SeparationTransparentModality1 L Gamma.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
  rewrite <- boxp_wand.
  eapply modus_ponens; [apply axiom_K |].
  apply rule_N.
  apply wand_sepcon_adjoint.
  apply provable_impp_refl.
Qed.


(**This document illustrate the space which we work in and the hypo we
     have already taken to construct this space**)
From CReal.MetricSpace Require Export M_pack.
From CReal.MetricSpace Require Export M_new.
Section BaseSpace.
Existing Instance EquR_trans.
Existing Instance leC_rewrite.
Variables X : Type.
Variables eqX : relation X.
Variables HE : Equivalence eqX.
Variables leX : relation X.
Variables pofX : Pre_Order_Field eqX leX.
Variables plusX : X -> X -> X.
Variables zeroX : X.
Variables pfX : Plus_Field eqX leX plusX zeroX.
Variables distX : X -> X -> X.
Variables MX : Metric eqX eqX _ _ _ pfX distX.

Definition ltX : X -> X -> Prop :=@lt X eqX leX pofX.

Variables Dp : Density eqX pfX.
Variables HPD : forall a b c : X, eqX (distX (plusX a b) (plusX a c)) (distX b c).

Variables A : Type.
Variables eqA : relation A.
Variables HEA : Equivalence eqA.
Variables dist : A -> A -> X.

Variables M : Metric eqX eqA leX plusX _ pfX dist.

Definition CX : Type := Cauchilize eqX eqX _ _ _ _.
Definition CA : Type := Cauchilize eqX eqA _ _ _ _.
Definition equCX : CX -> CX -> Prop :=@equC X X eqX eqX leX plusX zeroX distX pfX MX.
Definition leCX :=@leC X eqX leX plusX _ _ pfX MX HE.

Variables PB : PropBucket.
Definition pofCX :Pre_Order_Field equCX leCX :=@preOrder_trans X eqX leX plusX _ HE pfX _ MX Dp PB.

Definition plusCX :CX -> CX -> CX := M_new.plusCX X eqX HE leX plusX zeroX distX pfX MX Dp HPD .

Definition zeroCX :CX := M_new.zeroX X eqX HE leX plusX zeroX distX pfX MX.

Variables HIN : (forall a b : X, eqX (distX a b) (distX (inv a) (inv b))).
Definition pfCX : Plus_Field equCX leCX plusCX zeroCX  :=@pf_trans X eqX HE leX plusX zeroX distX pfX MX Dp HPD PB HIN.

Definition equCA : CA -> CA -> Prop := @equC A X eqX eqA leX plusX zeroX dist pfX M.

Variable HDD_pre : forall (x : X), eqX (distX zeroX x) x.
Theorem HDD_l : forall (a b c : A), leX (distX (dist a b) (dist a c)) (dist b c).
Proof.
  intros. Admitted. (**TODO**)

Variables HDD : forall (a b c : A), eqX (distX (dist a b) (dist a c)) (dist b c).
Variables HDDX : forall (a b c : X), eqX (distX (distX a b) (distX a c)) (distX b c).

Notation "a + b" := (plusX a b)
    (at level 50, left associativity).
Notation "a <= b" := (leX a b)
    (at level 70, no associativity).
Notation "a >= b" := (leX b a)
    (at level 70, no associativity).
Theorem dist_eq : forall (a b : A), eqX (distX zeroX (dist a b)) (dist a b).
Proof.
    intros. assert(eqX zeroX (dist a a)). pose proof (mre a a) as [Hex1 ?]. symmetry.
    apply Hex1. reflexivity. rewrite H. rewrite HDD. reflexivity.
Qed.
Theorem distX_eq : forall (a b : X), eqX (distX zeroX (distX a b)) (distX a b).
Proof.
    intros. assert(eqX zeroX (distX a a)). pose proof (mre a a) as [Hex1 ?]. symmetry.
    apply Hex1. reflexivity. rewrite H. rewrite HDDX. reflexivity.
Qed.
Definition leseq (a b : CX) : Prop.
destruct a, b. apply(forall (x y : X) (n : nat), Cseq n x -> Cseq0 n y -> leX x y).
Defined.
Theorem le_leC : forall (a b : CX), leseq a b -> leCX a b.
Proof.
    intros. destruct(classic (equCX a b)).
    -rewrite H0. destruct b. simpl. left. intros. exists 0. intros. assert(eqX a1 a2).
     apply HCseq3 with (m := n);auto. rewrite H6. pose proof (mre a2 a2) as [Hex ?].
     rewrite Hex;auto. reflexivity.
   -destruct a. destruct b. simpl. simpl in H0. simpl in H. right.
    apply not_all_ex_not in H0. destruct H0 as [eps]. apply not_all_ex_not in H0.
    destruct H0 as [H3].
    destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
    destruct (division_of_eps _ _ _ _ _ _ eps1) as [epsex1 [epsex2[Hex1[Hex2 Hexeq]]]];auto.
    destruct H1. destruct H2. destruct HCA with (eps := epsex1) as [N1];auto.
    destruct HCA0 with (eps := epsex2) as [N2];auto. destruct (always_greater N1 N2) as [G].
    destruct H4. exists G. intros. apply not_ex_all_not with (n := n) in H0.
    apply not_all_ex_not in H0 as [N]. apply not_all_ex_not in H0 as [H9].
    apply not_all_ex_not in H0 as [a1pin]. apply not_all_ex_not in H0 as [a2pin].
    apply not_all_ex_not in H0 as [H10]. apply not_all_ex_not in H0 as [H11]. apply lt_not in H0.
    destruct H1 with (m := n) (n := N) (a := a1) (b := a1pin);split;auto.
    apply (lt_trans _ G _);auto. apply (lt_trans _ G _);[auto |apply (lt_trans _ n _);auto].
    apply H with (n := n);auto.
    destruct H2 with (m := n) (n := N) (a := a2) (b := a2pin). split.
    apply (lt_trans _ G _);auto. apply (lt_trans _ G _);[auto|apply (lt_trans _ n _); auto].
    split;auto. assert(epsex1 > distX a1 a1pin). apply lt_intro;auto.
    assert(epsex2 > distX a2 a2pin). apply lt_intro;auto.
    pose proof (lt_two_plus_two X eqX _ _ plusX zeroX).
    assert(epsex1 + epsex2> distX a1 a1pin + distX a2 a2pin).
    destruct (H14 (distX a1 a1pin) (distX a2 a2pin) (epsex1) (epsex2));apply lt_intro;auto.
    rewrite Hexeq in H15. unfold not. intros. rewrite H16 in H15. rewrite msy in H15.
    assert(distX a1pin a2 + distX a2 a2pin >= distX a1pin a2pin). apply mtr.
    assert(eps1 > distX a1pin a2pin).
    destruct (le_lt_eq _ _ _ (distX a1pin a2pin) (distX a1pin a2 + distX a2 a2pin)).
    apply H18 in H17. destruct H17. apply lttr with (y := distX a1pin a2 + distX a2 a2pin);auto.
    rewrite H17. auto. assert(distX a1pin a2pin < eps).
    assert(eps1 < eps). pose proof (lt_div X eqX _ leX plusX zeroX).
    destruct H19 with (a:=eps1) (b := eps2) (c := eps);auto. apply lt_intro;auto.
    apply lttr with (y := eps1);auto. pose proof (lt_not X eqX _ leX).
    destruct H20 with (x := distX a1pin a2pin) (y := eps). apply H22 in H0. unfold not in H0.
    apply H0. auto. auto.
Qed.

Theorem ms_trans : Metric equCX equCA leCX plusCX zeroCX pfCX
        (@distC _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HDD).
Proof.
    split.
    -intros. destruct(classic (equCA p1 p2)).
      +destruct p1. destruct p2. simpl. left. intros. simpl in H.
         destruct H with (eps := eps) as [N];auto. exists N. intros.
         destruct H6. rewrite He. assert(eqX zeroX a1). destruct H5;[reflexivity | auto].
         rewrite <-H6. pose proof orderPres2. pose proof mle.
         destruct (@le_lt_eq X eqX leX pofX zeroX (dist a b)). apply H9 in H8. destruct H8.
         assert(distX zeroX (dist a b) < distX zeroX eps). assert(eps > dist a b).
         destruct H3 with (n := n) (a1 := a) (a2 := b);auto. apply lt_intro;auto.
         destruct H7 with (a := zeroX) (b := dist a b) (c := eps);auto.
         { apply lt_intro;destruct H8;auto. }
         { apply lt_intro;destruct H11;auto. }
         { apply lt_intro;auto. }
         { rewrite dist_eq. apply H3 with (n := n);auto. }
        rewrite <- H8. pose proof (mre zeroX zeroX) as [Hex1 Hex2];rewrite Hex1.
        auto. reflexivity.
      +destruct p1. destruct p2. simpl. right. simpl in H. apply not_all_ex_not in H.
        destruct H as [eps]. apply not_all_ex_not in H. destruct H as [H2].
        destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1[eps2 [Heps1 [Heps2 Heq]]]];auto.
        destruct(division_of_eps _ _ _ _ _ _ eps1) as [epsex1[epsex2 [Hepsex1 [Hepsex2 Hexeq]]]];auto.
        destruct H0. destruct HCA with (eps := epsex1) as [N1];auto.
        destruct H1. destruct HCA0 with (eps := epsex2) as [N2];auto.
        destruct (always_greater N1 N2) as [G1]. destruct H3. exists G1.
        intros. apply not_ex_all_not with (n := n) in H. apply not_all_ex_not in H.
        destruct H as [N3]. apply not_all_ex_not in H. destruct H as [H8].
        apply not_all_ex_not in H. destruct H7. rewrite He. destruct H as [apin].
        apply not_all_ex_not in H. destruct H as [bpin]. apply not_all_ex_not in H. destruct H as [H7].
        apply not_all_ex_not in H. destruct H as [H9]. apply lt_not in H. assert(eqX a1 zeroX).
        destruct H6. reflexivity. symmetry. auto. rewrite H10. assert(~eqA a b). unfold not. intros.
        destruct H0 with (m := n) (a := a) (n := N3) (b := apin). split;apply (lt_trans _ G1 _);auto.
        apply (lt_trans _ n _);auto. split;auto. destruct H1 with (m := n) (a := b) (n := N3) (b := bpin).
        split;apply(lt_trans _ G1 _);auto. apply (lt_trans _ n _);auto. split;auto.
        assert(epsex1 > dist a apin). apply lt_intro;auto. assert(epsex2 > dist b bpin).
        apply lt_intro;auto. rewrite H11 in H12. rewrite msy in H12.
        assert(dist apin b + dist b bpin >= dist apin bpin). apply mtr.
        assert(dist apin b + dist b bpin < epsex1 + epsex2).
        pose proof (lt_two_plus_two _ eqX _ leX plusX zeroX  (dist apin b) (dist b bpin) (epsex1) (epsex2)) as [H15];auto. apply lt_intro;destruct H12;auto. apply lt_intro;destruct H13;auto.
        apply lt_intro;auto. rewrite Hexeq in H15. assert(eps1 < eps).
        pose proof (lt_div X eqX _ leX plusX zeroX eps1 eps2 eps) as [H16]. auto. auto. auto.
        apply lt_intro;auto. assert(dist apin b + dist b bpin < eps). apply lttr with (y := eps1);auto.
        assert(eps > dist apin bpin).
        destruct (le_lt_eq _ _ _(dist apin bpin)  (dist apin b + dist b bpin) ). apply H18 in H14.
        destruct H14. apply lttr with (y := dist apin b + dist b bpin);auto. rewrite H14;auto.
        assert(~eps > dist apin bpin). apply lt_not;auto. unfold not in H19. apply H19. auto.
        assert(dist a b >= zeroX). apply mle. assert(~(eqX (dist a b) zeroX)).
        unfold not. intros. apply mre in H13. unfold not in H11. apply H11. auto.
        apply lt_intro; auto. unfold not. intros. unfold not in H13. apply H13. symmetry;auto.
        auto.
     -intros. destruct p1. destruct p2. simpl. intros. exists 0. intros. destruct H3.
      destruct H4. rewrite He. rewrite He0. assert(eqA a b0). destruct H.
      apply HCseq3 with (m:= n);auto. assert(eqA b a0). destruct H0.
      apply HCseq3 with (m:=n);auto. rewrite H3. rewrite H4. rewrite (msy b0 a0).
      pose proof (mre (dist a0 b0) (dist a0 b0)) as [Hex1 ?];rewrite Hex1;auto;reflexivity.
     -intros. split.
        +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as [N];auto. exists N. intros. destruct H5. rewrite He.
        assert(eqX a2 zeroX). destruct H6. reflexivity. symmetry. auto. rewrite H5.
        rewrite msy. rewrite dist_eq. apply H3 with (n := n);auto.
      +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as[N];auto.
         exists N. intros. rewrite <-dist_eq. rewrite msy. apply H3 with (n := n);auto.
         apply dit with (a := a1) (b := a2);auto. reflexivity. apply sig.
     -intros. apply le_leC. destruct p1, p2, p3. simpl. intros. destruct H2. destruct H3. rewrite He.
       rewrite He0. destruct Ha0. rewrite He1. destruct Hb0. rewrite He2.
       assert(eqA a1 b1). destruct H0. apply HCseq3 with (m := n);auto. rewrite H2.
       assert(eqA a0 a). destruct H. apply HCseq3 with (m := n);auto. rewrite H3.
       assert(eqA b0 b). destruct H1. apply HCseq3 with (m := n);auto. rewrite H4.
       apply mtr.
     -intros. destruct p1,p2,p3,p4. simpl. intro. simpl in H0,H. intros.
      destruct(division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
      destruct H with (eps := eps1) as [N1];auto. destruct H0 with (eps := eps2) as [N2];auto.
      destruct (always_greater N1 N2) as [G]. exists G. intros. destruct H10. destruct H11.
      rewrite He. rewrite He0.
      assert(distX (dist a b) (dist a0 b0) <= distX (dist a b) (dist a b0) + distX (dist a b0) (dist a0 b0)).
      apply mtr. rewrite HDD, (msy a b0), (msy a0 b0), HDD in H10.
      assert(dist b b0 + dist a a0 < eps). rewrite <-Heq.
      pose proof (lt_two_plus_two X eqX _ leX plusX zeroX).
      destruct H11 with (a := dist b b0) (b := dist a a0) (c := eps2) (d := eps1).
      destruct H7 with (n := n) (a1 := b) (a2 := b0). destruct H8. apply (lt_trans _ G _);auto.
      auto. auto. apply lt_intro;auto. destruct H6 with (n := n) (a1 := a) (a2 := a0).
      destruct H8. apply (lt_trans _ G _);auto. auto. auto. apply lt_intro;auto.
      rewrite (pfc eps1 _). apply lt_intro;auto.
      destruct (le_lt_eq _ _ _ (distX (dist a b) (dist b0 a0)) (dist b b0 + dist a a0)).
      apply H12 in H10. destruct H10. apply lttr with (y := dist b b0 + dist a a0);auto.
      rewrite (msy a0 b0). apply lt_intro;destruct H10;auto. apply lt_intro;destruct H11;auto.
      rewrite (msy a0 b0), H10. apply lt_intro; destruct H11; auto.
Qed.

(**The proof of the next theorem is itself redundant and trivial since it can be yielded by taking A = X.**)
Theorem ms_trans_X : Metric equCX equCX leCX plusCX zeroCX pfCX
        (@distC _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HDDX).
Proof.
    split.
    -intros. destruct(classic (equCX p1 p2)).
      +destruct p1. destruct p2. simpl. left. intros. simpl in H.
         destruct H with (eps := eps) as [N];auto. exists N. intros.
         destruct H6. rewrite He. assert(eqX zeroX a1). destruct H5;[reflexivity | auto].
         rewrite <-H6. pose proof orderPres2. assert(distX a b >= zeroX) as H8. apply mle.
         destruct (@le_lt_eq X eqX leX pofX zeroX (distX a b)). apply H9 in H8. destruct H8.
         assert(distX zeroX (distX a b) < distX zeroX eps). assert(eps > distX a b).
         destruct H3 with (n := n) (a1 := a) (a2 := b);auto. apply lt_intro;auto.
         destruct H7 with (a := zeroX) (b := distX a b) (c := eps);auto.
         { apply lt_intro;destruct H8;auto. }
         { apply lt_intro;destruct H11;auto. }
         { apply lt_intro;auto. }
         { rewrite distX_eq. apply H3 with (n := n);auto. }
        rewrite <- H8. pose proof (mre zeroX zeroX) as [Hex1 Hex2];rewrite Hex1.
        auto. reflexivity.
      +destruct p1. destruct p2. simpl. right. simpl in H. apply not_all_ex_not in H.
        destruct H as [eps]. apply not_all_ex_not in H. destruct H as [H2].
        destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1[eps2 [Heps1 [Heps2 Heq]]]];auto.
        destruct(division_of_eps _ _ _ _ _ _ eps1) as [epsex1[epsex2 [Hepsex1 [Hepsex2 Hexeq]]]];auto.
        destruct H0. destruct HCA with (eps := epsex1) as [N1];auto.
        destruct H1. destruct HCA0 with (eps := epsex2) as [N2];auto.
        destruct (always_greater N1 N2) as [G1]. destruct H3. exists G1.
        intros. apply not_ex_all_not with (n := n) in H. apply not_all_ex_not in H.
        destruct H as [N3]. apply not_all_ex_not in H. destruct H as [H8].
        apply not_all_ex_not in H. destruct H7. rewrite He. destruct H as [apin].
        apply not_all_ex_not in H. destruct H as [bpin]. apply not_all_ex_not in H. destruct H as [H7].
        apply not_all_ex_not in H. destruct H as [H9]. apply lt_not in H. assert(eqX a1 zeroX).
        destruct H6. reflexivity. symmetry. auto. rewrite H10. assert(~eqX a b). unfold not. intros.
        destruct H0 with (m := n) (a := a) (n := N3) (b := apin). split;apply (lt_trans _ G1 _);auto.
        apply (lt_trans _ n _);auto. split;auto. destruct H1 with (m := n) (a := b) (n := N3) (b := bpin).
        split;apply(lt_trans _ G1 _);auto. apply (lt_trans _ n _);auto. split;auto.
        assert(epsex1 > distX a apin). apply lt_intro;auto. assert(epsex2 > distX b bpin).
        apply lt_intro;auto. rewrite H11 in H12. rewrite msy in H12.
        assert(distX apin b + distX b bpin >= distX apin bpin). apply mtr.
        assert(distX apin b + distX b bpin < epsex1 + epsex2).
        pose proof (lt_two_plus_two _ eqX _ leX plusX zeroX  (distX apin b) (distX b bpin) (epsex1) (epsex2)) as [H15];auto. apply lt_intro;destruct H12;auto. apply lt_intro;destruct H13;auto.
        apply lt_intro;auto. rewrite Hexeq in H15. assert(eps1 < eps).
        pose proof (lt_div X eqX _ leX plusX zeroX eps1 eps2 eps) as [H16]. auto. auto. auto.
        apply lt_intro;auto. assert(distX apin b + distX b bpin < eps). apply lttr with (y := eps1);auto.
        assert(eps > distX apin bpin).
        destruct (le_lt_eq _ _ _(distX apin bpin)  (distX apin b + distX b bpin) ). apply H18 in H14.
        destruct H14. apply lttr with (y := distX apin b + distX b bpin);auto. rewrite H14;auto.
        assert(~eps > distX apin bpin). apply lt_not;auto. unfold not in H19. apply H19. auto.
        assert(distX a b >= zeroX). apply mle. assert(~(eqX (distX a b) zeroX)).
        unfold not. intros. apply mre in H13. unfold not in H11. apply H11. auto.
        apply lt_intro; auto. unfold not. intros. unfold not in H13. apply H13. symmetry;auto.
        auto.
     -intros. destruct p1. destruct p2. simpl. intros. exists 0. intros. destruct H3.
      destruct H4. rewrite He. rewrite He0. assert(eqX a b0). destruct H.
      apply HCseq3 with (m:= n);auto. assert(eqX b a0). destruct H0.
      apply HCseq3 with (m:=n);auto. rewrite H3. rewrite H4. rewrite (msy b0 a0).
      pose proof (mre (distX a0 b0) (distX a0 b0)) as [Hex1 ?];rewrite Hex1;auto;reflexivity.
     -intros. split.
        +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as [N];auto. exists N. intros. destruct H5. rewrite He.
        assert(eqX a2 zeroX). destruct H6. reflexivity. symmetry. auto. rewrite H5.
        rewrite msy. rewrite distX_eq. apply H3 with (n := n);auto.
      +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as[N];auto.
         exists N. intros. rewrite <-distX_eq. rewrite msy. apply H3 with (n := n);auto.
         apply dit with (a := a1) (b := a2);auto. reflexivity. apply sig.
     -intros. apply le_leC. destruct p1, p2, p3. simpl. intros. destruct H2. destruct H3. rewrite He.
       rewrite He0. destruct Ha0. rewrite He1. destruct Hb0. rewrite He2.
       assert(eqX a1 b1). destruct H0. apply HCseq3 with (m := n);auto. rewrite H2.
       assert(eqX a0 a). destruct H. apply HCseq3 with (m := n);auto. rewrite H3.
       assert(eqX b0 b). destruct H1. apply HCseq3 with (m := n);auto. rewrite H4.
       apply mtr.
     -intros. destruct p1,p2,p3,p4. simpl. intro. simpl in H0,H. intros.
      destruct(division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
      destruct H with (eps := eps1) as [N1];auto. destruct H0 with (eps := eps2) as [N2];auto.
      destruct (always_greater N1 N2) as [G]. exists G. intros. destruct H10. destruct H11.
      rewrite He. rewrite He0.
      assert(distX (distX a b) (distX a0 b0) <= distX (distX a b) (distX a b0) + distX (distX a b0) (distX a0 b0)).
      apply mtr. rewrite HDDX, (msy a b0), (msy a0 b0), HDDX in H10.
      assert(distX b b0 + distX a a0 < eps). rewrite <-Heq.
      pose proof (lt_two_plus_two X eqX _ leX plusX zeroX).
      destruct H11 with (a := distX b b0) (b := distX a a0) (c := eps2) (d := eps1).
      destruct H7 with (n := n) (a1 := b) (a2 := b0). destruct H8. apply (lt_trans _ G _);auto.
      auto. auto. apply lt_intro;auto. destruct H6 with (n := n) (a1 := a) (a2 := a0).
      destruct H8. apply (lt_trans _ G _);auto. auto. auto. apply lt_intro;auto.
      rewrite (pfc eps1 _). apply lt_intro;auto.
      destruct (le_lt_eq _ _ _ (distX (distX a b) (distX b0 a0)) (distX b b0 + distX a a0)).
      apply H12 in H10. destruct H10. apply lttr with (y := distX b b0 + distX a a0);auto.
      rewrite (msy a0 b0). apply lt_intro;destruct H10;auto. apply lt_intro;destruct H11;auto.
      rewrite (msy a0 b0), H10. apply lt_intro; destruct H11; auto.
Qed.
End BaseSpace.


From st.STLCmuVS Require Import lang tactics lib.fixarrow.
From iris.base_logic.lib Require Export ghost_map.
From iris.proofmode Require Import tactics.
Require Export st.backtranslations.st_sem.list_gmap.

Section ghost.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuVS_lang Σ}.
  Context `{ghost_mapG_inst : !ghost_mapG Σ nat V}.

  Definition auth_list (γ : gname) (vs : list V) : iProp Σ :=
    ghost_map_auth γ 1 (list_gmap vs).

  Definition frag_elem (γ : gname) (i : nat) (v : V) : iProp Σ :=
    i ↪[ γ ] v. (* ghost_map_elem γ i (DfracOwn 1) v. *)

  Lemma ghost_empty :
    ⊢ |==> ∃ γ, auth_list γ [].
  Proof. by iApply ghost_map_alloc_empty. Qed.

  Lemma ghost_alloc γ vs v :
    auth_list γ vs -∗ |==> auth_list γ (vs ++ [v]) ∗ length vs ↪[ γ ] v.
  Proof.
    iIntros "Hvs".
    rewrite !/auth_list list_gmap_snoc.
    iApply (ghost_map_insert with "Hvs").
    rewrite -list_gmap_lookup. by apply lookup_ge_None.
  Qed.

  Lemma ghost_alloc_persist γ vs v :
    auth_list γ vs -∗ |==> auth_list γ (vs ++ [v]) ∗ length vs ↪[ γ ]□ v.
  Proof.
    iIntros "Hvs".
    rewrite !/auth_list list_gmap_snoc.
    iApply (ghost_map_insert_persist with "Hvs").
    rewrite -list_gmap_lookup. by apply lookup_ge_None.
  Qed.

  Lemma ghost_read γ vs i v :
    ⊢ auth_list γ vs -∗ i ↪[ γ ] v -∗ ⌜ vs !! i = Some v ⌝.
  Proof.
    iIntros "Hvs Hiv".
    rewrite /auth_list list_gmap_lookup.
    iApply (ghost_map_lookup with "Hvs Hiv").
  Qed.

  Lemma ghost_write γ vs v i v' :
    ⊢ auth_list γ vs -∗ i ↪[ γ ] v -∗ |==> auth_list γ (<[ i := v' ]> vs) ∗ i ↪[ γ ] v'.
  Proof.
    iIntros "Hvs Hiv".
    iDestruct (ghost_read with "Hvs Hiv") as %eq.
    rewrite !/auth_list (list_gmap_insert _ _ _ _ eq).
    iApply (ghost_map_update with "Hvs Hiv").
  Qed.

End ghost.


(* Author: Masaki Hara, 2014 *)
(* Linear Logic Toy for Coq *)
Require Import LWeight LType_base LGoal.

(*************************************************)
(*         Linear Universal Quantification       *)
(*************************************************)

Record LForallVal{E:LEnv} {T:Type} (A:T -> LType) := {
  lforallval : forall t : T, ltype (A t);
  lforallval_weight : LWeight;
  lforallval_weight_eqn t : lweight (lforallval t) = lforallval_weight
}.
Arguments LForallVal [E] [T] A%LL.
Arguments lforallval [E] [T] [A] _ _.
Arguments lforallval_weight [E] [T] [A] _.
Arguments lforallval_weight_eqn [E] [T] [A] _ _.
Coercion lforallval : LForallVal >-> Funclass.

Definition LForall{E:LEnv} {T:Type} (A:T -> LType) : LType := {|
  ltype := LForallVal A;
  lweight := @lforallval_weight _ _ _
|}.
Notation "'lforall' x .. y , p"
    := (LForall (fun x => .. (LForall (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'lforall'  '/  ' x  ..  y ,  '/  ' p ']'")
  : LL_scope.

Instance LForall_weight_delegate{E:LEnv} {T:Type} (A:T->LType)
    (f : ltype (LForall A)) (t : T)
    : LWeightCastSelf (lweight (f t)) (lweight f).
Proof.
  rewrite lforallval_weight_eqn.
  exists; reflexivity.
Defined.

Definition LForallIntroduction{E:LEnv} {T:Type} (A:T -> LType) {W:LWeight}
    : (forall t, LGoal (A t) W) -> LGoal (LForall A) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lforallval t := H0 t;
      lforallval_weight := W
    |} : ltype (LForall A)
  |}.
Grab Existential Variables.
  intros t; simpl.
  refine (lweight_eqn _).
Defined.

Definition LForallSpecialization{E:LEnv} {T:Type} {A:T -> LType} {B:LType}
    {W:LWeight} (t:T)
    : LGoal (A t -o B) W -> LGoal (LForall A -o B) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(a:ltype (LForall A)) =>
        lgoal_proof H0 (lforallval a t);
      lfun_weight := W
    |} : ltype (LForall A -o B)
  |}.
Grab Existential Variables.
  intros x; simpl; refine (lweight_eqn _).
Defined.

Instance lgoal_autoapply_forall{E:LEnv} {T:Type} {A:T->LType} {B:LType}
  {n:nat} {l:list (nat * LWeight)} {W:LWeight}
  {f:ltype (LForall A)}
  {Impls:list Type}
  {t:T}
  {H: LHintedApp n l Impls (LGoal B (W + lweight (f t))%LWeight)}
  : LHintedApp n l Impls (LGoal B (W + lweight f)%LWeight).
Proof.
  exists.
  destruct H as [H].
  revert H; apply implication_list_map; intros H.
  refine {|
    lgoal_proof := lgoal_proof H
  |}.
Defined.

Local Ltac introll_base x ::=
  introll_base_limpl x ||
  (apply LForallIntroduction; intros x) ||
  fail "Linear Introduction Failed".
Tactic Notation "specializell" "(" constr(x) constr(t) ")" :=
  revertll x; apply (LForallSpecialization t); introll x.

Local Open Scope LL_goal_scope.
Example LForallComm{E:LEnv} {S T:Type} (A:S -> T -> LType) :
  (ILL |- (lforall s t, A s t) -o (lforall t s, A s t)).
Proof.
  introsll x t s.
  (* specializell (x s). *)
  (* specializell (x t). *)
  applyll x.
Defined.
Local Close Scope LL_goal_scope.


Require Import all_ssreflect all_algebra presburger.
Require Extraction.

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

Load "../extraction_common_dffun.v".

Extraction Inline fst snd.

(* range *)

Extraction Inline
  range_eqType range_eqMixin range_subType range_choiceType range_countType
  range_finType range_finMixin.

(* automata *)

Extraction Inline
  automata.dfa_state automata.dfa_s automata.dfa_fin automata.dfa_trans
  automata.dfa_lang
  automata.nfa_state automata.nfa_s automata.nfa_fin automata.nfa_trans
  automata.nfa_to_dfa automata.dfa_compl automata.dfa_op
  leq_dfa eq_dfa nfa_of_exists.

(* Avoid extractor bugs: type mismatch, assertion failure, etc. *)

Extract Constant SetDef.pred_of_set =>
  "(Obj.magic (fun t a x -> tnth a (t.Finite.mixin.Finite.mixin_enc x)))".

(* matrix *)

Definition matrix_mult_test (n : nat) :=
  let mx := (\matrix_(i < n, j < n) (i%:Z + j%:Z))%R in
  (mx *m mx)%R.

Definition finfun_app_test (n : nat) :=
  let f := [ffun i : 'I_n => i] in
  \sum_i f i.

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

Extraction Language Ocaml.
Set Extraction Flag 8175.

Extraction "../../ocaml/matrix_after.ml" matrix_mult_test finfun_app_test.

Extraction "../../ocaml/presburger_after.ml"
           bool_finType finfun_finType exp_finIndexType f_divisible
           presburger_dec presburger_st_dec presburger_sat presburger_valid.


Require Import
  TList
  Lib
  Ltac
  Ty
  Exp
  Value
  Ren
  Sub
  Sem.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

(** Evaluation contexts *)

Section Step.

Import ListNotations.

Context {A : Type}.
Context `{HostExprs A}.

Open Scope Ty_scope.

Unset Elimination Schemes.

Inductive Redex {Γ} : ∀ {τ}, Exp Γ τ → Exp Γ τ → Prop :=
  | R_Beta {dom cod} (e : Exp (dom :: Γ) cod) v :
    ValueP v →
    Redex (APP (LAM e) v) (SubExp {|| v ||} e).

Derive Signature for Redex.

Scheme Redex_ind := Induction for Redex Sort Prop.

(* A context defines a hole which, after substitution, yields an expression of
   the index type. *)
Inductive Ctxt1 Γ : ∀ {τ τ'}, (Exp Γ τ' → Exp Γ τ) → Prop :=
  | C_AppL {dom cod} (x : Exp Γ dom) :
    Ctxt1 Γ (λ f : Exp Γ (dom ⟶ cod), APP f x)
  | C_AppR {dom cod} (f : Exp Γ (dom ⟶ cod)) :
    Ctxt1 Γ (λ x : Exp Γ dom, APP f x).

Derive Signature for Ctxt1.

Scheme Ctxt1_ind := Induction for Ctxt1 Sort Prop.

Arguments C_AppL {_ _ _} x.
Arguments C_AppR {_ _ _} f.

Inductive Ctxt Γ : nat → ∀ {τ τ'}, (Exp Γ τ' → Exp Γ τ) → Prop :=
  | Ctxt_nil {τ} : Ctxt Γ 0 (λ x : Exp Γ τ, x)
  | Ctxt_cons {n τ τ' τ''} {f : Exp Γ τ' → Exp Γ τ} {g : Exp Γ τ'' → Exp Γ τ'} :
    Ctxt1 Γ f → Ctxt Γ n g → Ctxt Γ (S n) (f ∘ g).

Derive Signature for Ctxt.

Scheme Ctxt_ind := Induction for Ctxt Sort Prop.

Arguments Ctxt_nil {_ _}.
Arguments Ctxt_cons {_ _ _ _ _ _ _} _ _.

Notation "⦉ e ; .. ; f ⦊" := (Ctxt_cons e .. (Ctxt_cons f Ctxt_nil) ..).

Notation "x ∷ xs" := (Ctxt_cons x xs) (at level 70).

(* [Ctxt] forms a category with objects = types and morphisms = contexts. *)

Definition Ctxt_id {Γ τ} : Ctxt Γ 0 id := @Ctxt_nil Γ τ.
Arguments Ctxt_id {Γ τ} /.

Equations Ctxt_comp {Γ τ τ' τ'' n m}
          {f : Exp Γ τ' → Exp Γ τ}
          {g : Exp Γ τ'' → Exp Γ τ'}
          (Cf : Ctxt Γ n f) (Cg : Ctxt Γ m g) : Ctxt Γ (n + m) (f ∘ g) :=
  Ctxt_comp Ctxt_nil gs := gs;
  Ctxt_comp (f ∷ fs) gs := f ∷ Ctxt_comp fs gs.

Theorem Ctxt_id_left {Γ τ τ' n} {f : Exp Γ τ' → Exp Γ τ} {C : Ctxt Γ n f} :
  Ctxt_comp Ctxt_id C = C.
Proof.
  simpl.
  pose proof (Ctxt_comp_equation_1 _ _ _ _ f C).
  unfold compose in H0.
  now apply H0.
Qed.

Theorem Ctxt_id_right {Γ τ τ' n} {f : Exp Γ τ' → Exp Γ τ} {C : Ctxt Γ n f} :
  Ctxt_comp C Ctxt_id ~= C.
Proof.
  simpl.
  dependent induction C; simp Ctxt_comp; auto.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ n 0 _ _ _ _ c C Ctxt_id).
  simpl in *.
  unfold compose in H0.
  rewrite H0; clear H0.
Abort.

Theorem Ctxt_comp_assoc {Γ τ τ' τ'' τ''' n m o}
        {f : Exp Γ τ' → Exp Γ τ}
        {g : Exp Γ τ'' → Exp Γ τ'}
        {h : Exp Γ τ''' → Exp Γ τ''}
        (Cf : Ctxt Γ n f) (Cg : Ctxt Γ m g) (Ch : Ctxt Γ o h) :
  Ctxt_comp Cf (Ctxt_comp Cg Ch) ~= Ctxt_comp (Ctxt_comp Cf Cg) Ch.
Proof.
  simpl.
  dependent induction Cf; simp Ctxt_comp; auto.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ n _ _ _ _ _ c Cf (Ctxt_comp Cg Ch)).
  simpl in *.
  rewrite H0; clear H0.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ n _ _ _ _ _ c Cf Cg).
  simpl in *.
  rewrite H0; clear H0.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ _ _ _ _ _ _ c (Ctxt_comp Cf Cg) Ch).
  simpl in *.
  rewrite H0; clear H0.
  Fail rewrite PeanoNat.Nat.add_assoc.
  Fail rewrite IHCf.
Abort.

(*
Equations Plug {Γ τ' τ} (e : Exp Γ τ') (c : Ctxt Γ τ' τ) : Exp Γ τ :=
  Plug e (C_Hole _ _)      := e;
  Plug e (C_App1 _ _ C e1) := APP (Plug e C) e1;
  Plug e (C_App2 _ _ e1 C) := APP e1 (Plug e C).
*)

(*
Unset Elimination Schemes.

Inductive Plug {Γ τ'} (e : Exp Γ τ') : ∀ {τ}, Ctxt Γ τ' τ → Exp Γ τ → Prop :=
  | Plug_Hole : Plug e (C_Hole _ _) e

  (* | Plug_If1 {Γ τ} (C : Ctxt Γ TyBool) (e e' : Exp Γ TyBool) (e1 e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If1 _ C e1 e2) e (If e' e1 e2) *)
  (* | Plug_If2 {Γ τ} (C : Ctxt Γ τ) (e e' : Exp Γ τ) e1 (e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If2 _ e1 C e2) e (If e1 e' e2) *)
  (* | Plug_If3 {Γ τ} (C : Ctxt Γ τ) (e e' : Exp Γ τ) e1 (e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If3 _ e1 e2 C) e (If e1 e2 e') *)

  | Plug_App1 {dom cod} {C : Ctxt Γ τ' (dom ⟶ cod)}
              {e' : Exp Γ (dom ⟶ cod)} {e1 : Exp Γ dom} :
    Plug e C e' →
    Plug e (C_App1 _ _ C e1) (APP e' e1)
  | Plug_App2 {dom cod} {C : Ctxt Γ τ' dom}
              {e' : Exp Γ dom} {e1 : Exp Γ (dom ⟶ cod)} :
    ValueP e1 →
    Plug e C e' →
    Plug e (C_App2 _ _ e1 C) (APP e1 e').

Derive Signature for Plug.

Set Elimination Schemes.

Scheme Plug_ind := Induction for Plug Sort Prop.

(* [Plug] forms a category with objects = expressions and morphisms = plugs
   over existential contexts. *)

Definition Plug_id {Γ τ} {x : Exp Γ τ} : Plug x (C_Hole Γ τ) x := Plug_Hole _.
Arguments Plug_id {_ _ _} /.

Equations Plug_comp {Γ τ τ' τ''}
          {x : Exp Γ τ''} {y : Exp Γ τ'} {z : Exp Γ τ}
          {C : Ctxt Γ τ' τ} {C' : Ctxt Γ τ'' τ'}
          (P : Plug x C' y) (P' : Plug y C z) : Plug x (Ctxt_comp C C') z :=
  Plug_comp p (Plug_Hole _)    := p;
  Plug_comp p (Plug_App1 _ p')   := Plug_App1 _ (Plug_comp p p');
  Plug_comp p (Plug_App2 _ H p') := Plug_App2 _ H (Plug_comp p p').

(* This should be provable, but the dependent types get in the way. *)
Theorem Plug_id_left {Γ τ τ'} {C : Ctxt Γ τ' τ} {x : Exp Γ τ'} {y : Exp Γ τ}
        (P : Plug x C y) :
  Plug_comp Plug_id P ~= P.
Proof.
  dependent induction P; auto.
  - rewrite (Plug_comp_equation_2 _ _ _ _ _ _ _ _ _ _ _ Plug_id P).
    unfold Ctxt_comp_obligations_obligation_1.
    pose proof (@Ctxt_id_right _ _ _ C).
    simpl in *.
    Fail rewrite H0 in IHP.
    Fail now rewrite IHP.
Abort.
(*
  - rewrite (Plug_comp_equation_3 _ _ _ _ _ _ _ _ _ _ _ Plug_id _ P).
    pose proof (@Ctxt_id_right _ _ _ C).
    simpl in *.
    Fail now rewrite IHP.
*)
*)

Reserved Notation " t '--->' t' " (at level 40).

Inductive Step {Γ τ} : Exp Γ τ → Exp Γ τ → Prop :=
  | StepRule {n τ' C} {e1 e2 : Exp Γ τ'} :
    Ctxt Γ n C →
    Redex e1 e2 →
    C e1 ---> C e2

  | StepError {n τ'} {C : Exp Γ τ' → Exp Γ τ} {m : Err} :
    Ctxt Γ (S n) C →
    C (Error m) ---> Error m

  where " t '--->' t' " := (Step t t').

Derive Signature for Step.

(* #[local] Hint Constructors ValueP Plug Redex Step : core. *)
#[local] Hint Constructors ValueP Redex Ctxt1 Ctxt Step : core.

Ltac step :=
  first [ now eapply (StepRule Ctxt_nil); eauto
        | now eapply (StepError Ctxt_nil); eauto
        | now eapply (StepRule ⦉ C_AppL _ ⦊); eauto
        | now eapply (StepError ⦉ C_AppL _ ⦊); eauto
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepRule (C_AppL _ ∷ H)); eauto
              end
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepError (C_AppL _ ∷ H)); eauto
              end
        | now eapply (StepRule ⦉ C_AppR _ ⦊); eauto
        | now eapply (StepError ⦉ C_AppR _ ⦊); eauto
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepRule (C_AppR _ ∷ H)); eauto
              end
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepError (C_AppR _ ∷ H)); eauto
              end ].

Theorem strong_progress {τ} (e : Exp [] τ) :
  ValueP e ∨ ErrorP e ∨ ∃ e', e ---> e'.
Proof.
  dependent induction e.
  - now right; left.
  - now inv v.
  - now left; constructor.
  - reduce.
    right; right.
    destruct IHe1 as [V1|[E1|[e1' H1']]];
    destruct IHe2 as [V2|[E2|[e2' H2']]].
    + dependent elimination V1.
      now eexists; step.
    + dependent elimination V1.
      dependent elimination E2.
      now eexists; step.
    + dependent elimination H2'.
      * now eexists; step.
      * now eexists; step.
    + dependent elimination V2.
      dependent elimination E1.
      now eexists; step.
    + dependent elimination E1.
      now eexists; step.
    + dependent elimination E1.
      now eexists; step.
    + dependent elimination H1'.
      * now eexists; step.
      * now eexists; step.
    + dependent elimination H1'.
      * now eexists; step.
      * now eexists; step.
    + dependent elimination H1'.
      * dependent elimination H2'.
        ** now eexists; step.
        ** now eexists; step.
      * now eexists; step.
Qed.

Lemma Redex_ValueP {Γ τ} (e v : Exp Γ τ) :
  ValueP v → ¬ Redex v e.
Proof.
  repeat intro.
  dependent elimination H0.
  now inv H1.
Qed.

Lemma Plug_deterministic {Γ τ} :
  ∀  τ' n {Ce : Exp Γ τ' → Exp Γ τ} e1 e1',
    Ctxt Γ n Ce →
    Redex e1 e1' →
  ∀ τ'' m {Cf : Exp Γ τ'' → Exp Γ τ} f1 f1',
    Ctxt Γ m Cf →
    Redex f1 f1' →

    Ce e1 = Cf f1 →
      τ' = τ'' ∧ Ce ~= Cf ∧ e1 ~= f1.
Proof.
  intros.
  generalize dependent Cf.
  dependent induction H1; intros; subst.
  inv H3; auto.
  - exfalso.
    dependent elimination H0.
    dependent elimination H2.
    now inv H6.
  - exfalso.
    dependent elimination H0.
    dependent elimination H1.
    now inv H7.
  - dependent elimination H3.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv H2.
    + intuition.
      now destruct (IHPlug _ p); reduce.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv H2.
  - dependent elimination H3.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv H2.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv p.
    + intuition.
      now destruct (IHPlug _ p0); reduce.
Qed.

Lemma Plug_functional {Γ τ τ'} {C : Ctxt Γ τ' τ} e e1 :
  Plug e C e1
    → ∀ e2, Plug e C e2 → e1 = e2.
Proof.
  intros.
  dependent induction H0.
  - now inv H1.
  - dependent destruction H1.
    now f_equal; auto.
  - dependent destruction H1.
    now f_equal; auto.
Qed.
*)

Theorem Ctxt1_injective {Γ τ τ'} {C : Exp Γ τ' → Exp Γ τ} {e1 e2 : Exp Γ τ'} :
  Ctxt1 Γ C →
  C e1 = C e2 → e1 = e2.
Proof.
  intros.
  generalize dependent e2.
  generalize dependent e1.
  induction H0; simpl; intros; auto.
  - now inv H1.
  - now inv H1.
Qed.

Theorem Ctxt_injective {Γ τ τ' n} {C : Exp Γ τ' → Exp Γ τ} {e1 e2 : Exp Γ τ'} :
  Ctxt Γ n C →
  C e1 = C e2 → e1 = e2.
Proof.
  intros.
  generalize dependent e2.
  generalize dependent e1.
  induction H0; simpl; intros; auto.
  now eapply Ctxt1_injective in c; eauto.
Qed.

Lemma Redex_deterministic : ∀ Γ τ (e e' : Exp Γ τ),
  Redex e e' → ∀ e'', Redex e e'' → e' = e''.
Proof.
  intros.
  dependent elimination H0.
  dependent elimination H1.
  reflexivity.
Qed.

Lemma App_Lam_loop {Γ τ ty} {v : Exp Γ ty} {e : Exp (ty :: Γ) τ} :
  ¬ (SubExp {||v||} e = APP (LAM e) v).
Admitted.
(*
Proof.
  dependent induction e; repeat intro; inv H.
  - dependent induction v0; simp consSub in *.
    + simp SubVar in H1.
  (*     now induction v; inv H1; intuition. *)
  (*   + simp SubVar in H1. *)
  (*     rewrite SubVar_idSub in H1. *)
  (*     now induction v0; inv H1; intuition. *)
Admitted.
*)

(*
Lemma If_loop_true {Γ τ} b {x : Exp Γ τ} {y : Exp Γ τ} :
  ¬ (If b x y = x).
Proof.
  induction x; intro; inv H.
  now eapply IHx2; eauto.
Qed.

Lemma If_loop_false {Γ τ} b {x : Exp Γ τ} {y : Exp Γ τ} :
  ¬ (If b x y = y).
Proof.
  induction y; intro; inv H.
  now eapply IHy3; eauto.
Qed.

Lemma Seq_loop {Γ τ ty} {x : Exp Γ ty} {y : Exp Γ τ} :
  ¬ (Seq x y = y).
Proof.
  induction y; intro; inv H.
  now eapply IHy2; eauto.
Qed.
*)

(* A term never reduces to itself. *)
#[export]
Program Instance Step_Irreflexive {Γ τ} :
  Irreflexive (Step (Γ:=Γ) (τ:=τ)).
Next Obligation.
  dependent induction H0.
  - eapply Ctxt_injective in H0; eauto; subst.
    dependent destruction H1.
    now eapply App_Lam_loop; eauto.
  - inv H0.
    inv H3;
    now inv x.
Qed.

Corollary Step_productive {Γ τ} {x x' : Exp Γ τ} : x ---> x' → x ≠ x'.
Proof.
  repeat intro; subst.
  now eapply Step_Irreflexive; eauto.
Qed.

#[export]
Program Instance RenExp_Step {Γ Γ' τ} (σ : Ren Γ' Γ) :
  Proper (Step (Γ:=Γ) (τ:=τ) ==> Step) (RenExp σ).
Next Obligation.
  dependent elimination H0; simpl.
  - dependent induction r;
    induction c; simpl.
    + rewrite <- SubExp_ScR.
      simp ScR.
      rewrite <- RcS_idSub.
      pose proof (SubExp_RcS (Keep σ) (Push (RenExp σ v) idSub) e) as H1.
      simp RcS in H1.
      rewrite H1.
      apply (StepRule Ctxt_nil).
      repeat econstructor.
      now apply RenExp_ValueP.
    + specialize (IHc e).
      admit.
  - inv c0.
    admit.
Admitted.

#[export]
Program Instance SubExp_Step {Γ Γ' τ} (σ : Sub Γ' Γ) :
  Proper (Step (Γ:=Γ) (τ:=τ) ==> Step) (SubExp σ).
Next Obligation.
  intros.
Admitted.
(*
  induction H; simpl;
  try solve [ now constructor; intuition idtac
            | now constructor; intuition; apply SubExp_ValueP ].
  (* - now apply Reduce_preserves_substitution. *)
  (* - now apply CallHost_preserves_substitution. *)
  - rewrite <- SubExp_ScS.
    simpl ScS.
    rewrite ScS_idSub_left.
    pose proof (SubExp_ScS (Keepₛ σ) (Push (SubExp σ v) idSub) e) as H1.
    simpl in H1.
    simp SubVar in H1.
    unfold Dropₛ in H1.
    rewrite ScS_ScR in H1.
    rewrite RcS_skip1 in H1.
    rewrite ScS_idSub_right in H1.
    rewrite H1.
    constructor.
    now apply SubExp_ValueP.
Qed.
*)

Lemma pluggable {Γ τ τ' n} {e e' : Exp Γ τ'} {C : Exp Γ τ' → Exp Γ τ} :
  ¬ ErrorP e' →
  e ---> e' →
  Ctxt Γ n C →
  C e ---> C e'.
Proof.
  intros.
  dependent elimination H1.
  - exact (StepRule (Ctxt_comp H2 c) r).
  - exfalso.
    now apply H0.
Qed.

Lemma APP_LAM_R {Γ dom cod} {f : Exp Γ (dom ⟶ cod)} {x x' : Exp Γ dom} :
  ¬ ErrorP x' →
  x ---> x' →
  APP f x ---> APP f x'.
Proof.
  intros.
  now eapply (pluggable H0 H1 ⦉ C_AppR _ ⦊); eauto.
Qed.

End Step.

Arguments C_AppL [A]%type_scope [H Γ] [dom]%Ty_scope [cod]%Ty_scope x.
Arguments C_AppR : default implicits.

Arguments Ctxt_nil {A}%type_scope {H Γ} {τ}%Ty_scope.
Arguments Ctxt_cons : default implicits.

Notation "⦉ e ; .. ; f ⦊" := (Ctxt_cons e .. (Ctxt_cons f Ctxt_nil) ..).

Notation "x ∷ xs" := (Ctxt_cons x xs) (at level 70).

Notation " t '--->' t' " := (Step t t') (at level 40).


Require Import Utf8.
Require Import Coq.Program.Equality.

(** printing Γ %\ensuremath{\Gamma}% #Γ# *)
(** printing Γ' %\ensuremath{\Gamma}% #Γ'# *)
(** printing Γ'' %\ensuremath{\Gamma}% #Γ''# *)
(** printing τ %\ensuremath{\tau}% #τ# *)
(** printing σ %\ensuremath{\sigma}% #σ# *)
(** printing ⊓ %\ensuremath{\sqcap}% #∩# *)
(** printing ⋂ %\ensuremath{\bigcap}% #∩# *)

(** * DSL Primitives
   Heaps, refined references, stability, etc. *)

Axiom heap : Set.
Definition hpred (A:Set) := A -> heap -> Prop.
Definition hrel (A:Set) := A -> A -> heap -> heap -> Prop.
Definition subhrel {A} (G R:hrel A) := forall x x' h h', G x x' h h' -> R x x' h h'.
Definition hreflexive {A}(R:hrel A) := forall x h, R x x h h.

(** Predicate and Relation Combinators *)
Definition pred_and {A:Set} (P:hpred A) (Q:hpred A) : hpred A :=
  fun a => fun h =>
    P a h /\ Q a h.
Infix "⊓" := (pred_and) (at level 40).

Definition pred_or {A:Set} (P Q:hpred A) : hpred A :=
  fun a => fun h => P a h \/ Q a h.
Infix "⊔" := (pred_or) (at level 41).

Definition rel_and {A:Set} (R:hrel A) (S:hrel A) : hrel A :=
  fun a a' h h' =>
    R a a' h h' /\ S a a' h h'.
Infix "⋂" := (rel_and) (at level 40).

Definition rel_or {A:Set} (R S:hrel A) : hrel A :=
  fun a a' h h' => R a a' h h' \/ S a a' h h'.
Infix "⋃" := (rel_or) (at level 41).

Definition rel_sub_eq {A:Set} (R S:hrel A) : Prop :=
  forall a a' h h', R a a' h h' -> S a a' h h'.
Infix "⊆" := (rel_sub_eq) (at level 45).

Definition stable {A} (P:hpred A) (R:hrel A) :=
  forall x x' h h', P x h -> R x x' h h' -> P x' h'.

(** * References
    ref must be defined completely, otherwise Coq's positivity checks are extremely conservative *)
Inductive ref (A:Set) (P:hpred A) (R G:hrel A) : Set :=
  | ref_placeholder : nat -> ref A P R G.
(*  mkref {ptr:nat}.*)
Notation "ref{ τ | P }[ R , G ]" := (ref τ P R G) (at level 80).
Axiom ref_stable : forall {A P R G}(r:ref{A|P}[R,G]), stable P R.
(* TODO: Nuke this? if alloc only creates stable refs, then this is okay, though awkward. *)
Hint Resolve @ref_stable.

(** ** Heap interaction primitives
    Including reachability, containment, precision, and relation folding *)

Axiom heap_write : forall {A P R G} (p:ref A P R G) (v:A) (h:heap), heap.
Axiom heap_alloc : forall (A:Set) (a:A) (P:hpred A) (R G:hrel A), heap -> (ref A P R G * heap).
(** heap_deref doesn't need to fold types because it's entirely propositional; "inside the heap" if you will,
    and does not actually affect execution *)
Axiom heap_deref : forall {A P R G} (h:heap), ref{A|P}[R,G] -> A.
Notation "h [ r ]" := (heap_deref h r) (at level 40).
Axiom heap_lookup2 : forall {A P R G} (h:heap) (r:ref{A|P}[R,G]), P (h[r]) h.
(** Some concepts require a parameter-polymorphic reference equality. *)
Axiom ptr_eq : forall {A A' P P' R R' G G'}, ref A P R G -> ref A' P' R' G' -> Prop.
Infix "≡" := (ptr_eq) (at level 80).

Axiom type_based_nonaliasing : forall h τ σ P R G Q R' G' `(a:ref{τ|P}[R,G]) `(b:ref{σ|Q}[R',G']) v, τ<>σ ->
  (heap_write a v h)[b] = h[b].

(** ** Reachability
    We need to define what is reachable from a given type in order to define precise prediates and relations. *)
Class ImmediateReachability (A:Set) := {
  imm_reachable_from_in : forall {T:Set}{P R G} (p:ref{T|P}[R,G]) (a:A), Prop
}.
Global Instance ref_reach `{A:Set,P:hpred A,R:hrel A,G:hrel A}: ImmediateReachability (ref{A|P}[R,G]) :=
  { imm_reachable_from_in := fun T P' R' G' dst src => src≡dst}.
(** This is the reachability definition used globally.  Each structure must define a trusted
    ImmediateReachability instance to find pointers in a local structure.
    This relation adds the transitive and reflexive parts of reachability.
    This setup allows us to implement reference immutability generically over any
    type with an ImmediateReachability instance, and prove it precise without
    needing details about an unknown type's internal structure *)
Inductive reachable_from_in : forall {A:Set} {IRA:ImmediateReachability A}{T:Set}{P R G} (p:ref{T|P}[R,G]) (a:A) (h:heap), Prop :=
  | reflexively_reachable : forall (T:Set) P R G (r:ref{T|P}[R,G]) h, reachable_from_in r r h
  | directly_reachable : forall (U:Set) {IRU:ImmediateReachability U} {T:Set}{P R G}(p:ref{T|P}[R,G]) u h,
                           imm_reachable_from_in p u -> reachable_from_in p u h
  | trans_reachable : forall (A:Set){IRA:ImmediateReachability A} (a:A) (* value *)
                             (I:Set){ReI:ImmediateReachability I}{PI RI GI}(i:ref{I|PI}[RI,GI]) (* intermediate *)
                             {T:Set}{P R G}(p:ref{T|P}[R,G]) (* dest *)
                             h, (* heap *)
                        imm_reachable_from_in i a -> reachable_from_in p (h[i]) h ->
                        reachable_from_in p a h.
(** ** Precision
    Predicates and relations must be agnostic to changes outside the heap reachable
    from their target. *)
(** For predicates, precision really means stability over any heap changes that don't touch
    the predicates footprint *)
Definition precise_pred {A:Set}{AR:ImmediateReachability A} (P:hpred A) :=
  forall a h h', P a h ->
                 (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a h -> h[r]=h'[r]) ->
                 P a h'.
(** For relations, precision means they accept any heap changes outside their footprint. *)
Definition precise_rel {A:Set}{AR:ImmediateReachability A} (R:hrel A) :=
  forall a a' h h' h2 h2',
    (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a h -> h[r]=h2[r]) ->
    (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a' h' -> h'[r]=h2'[r]) ->
    (R a a' h h' -> R a a' h2 h2').

(** ** Relation Folding:
    Folding a rely-guarantee pair through a type to restrict the results of
    heap reads.  For any well-formed ref type the rely relation must already
    contain the literal rely of any reachable refs, so the rely portion
    is essentially a no-op.  The guarantee, however, still needs to be
    projected and intersected component-wise in any structure. *)
Class rel_fold (A:Set) :=
  { rgfold : forall (R G:hrel A), Set ;
    fold : forall {R G}, A -> rgfold R G
  }.
(** In meta-proofs, of things like satisfying a guarantee, we use this
    identity fold instead of the appropriate developer instance so
    G and P don't have to have polymorphic arities and relation arguments
    to work on all sorts of folded versions of A. We place it in its
    own section so it isn't used as an instance by user programs.
*)
Section HideMetaFold.
Local Instance meta_fold {A:Set} : rel_fold A :=
  { rgfold := fun R G => A ;
    fold := fun _ _ x => x
  }.
End HideMetaFold.
Notation "{{{ e }}}" := (let mfold : forall A, rel_fold A := @meta_fold in e) (at level 50).

(** ** Containment
    Containment means a reference's rely admits at least as much interference
    on references reachable from it as those reachable references themselves. *)
Class Containment (A:Set) := {
  contains : forall (R:hrel A), Prop
}.

(* TODO: relation folding on heap reads, and enforcing that G is reflexive/permits reads! *)
(** Ideally deref would have the type
<<
forall {A:Set}`{rel_fold A}{P:hpred A}{R G:hrel A}, hreflexive G -> ref A P R G -> rgfold R G.
>>
But unforunately, Coq's default type conversion procedure doesn't fully reduce the rgfold instance,
which in most cases is reduced naturally by
<<
cbv iota delta beta
>>
But that reduction is stronger than default conversion (at least in 8.3... still building 8.4).
*)
Axiom deref : forall {A:Set}{B:Set}`{rel_fold A}{P:hpred A}{R G:hrel A}, hreflexive G -> rgfold R G = B -> ref A P R G -> B.
(*Axiom deref : forall {A:Set}{P:hpred A}{R G:hrel A}, ref A P R G -> A.*)
Notation "! e" := (deref _ _ e) (at level 30). (* with reflexivity, add an _ in there *)

(* This axiom asserts that all folds that produce the same result type operate equally on
   the underlying values. This is fragile if a developer specifies multiple instances for
   folding the same type.  This is a weaker version of a more general axiom that
   the relationship between the results of folds of different result types depends on the
   relationship between results of the fold members of the instances when applied to the
   same value.  This version is really only useful for equating identity folds with
   the identity meta_fold instance results. *)
Axiom deref_conversion : forall (A B:Set)(f f':rel_fold A) P R G  rf1 rf2 fe1 fe2,
                         @deref A B f P R G rf1 fe1 = @deref A B f' P R G rf2 fe2.

Axiom ptr_eq_deref : forall A P P' R R' G G' h (p:ref{A|P}[R,G]) (r:ref{A|P'}[G',R']), p≡r -> h[p]=h[r].
Hint Resolve ptr_eq_deref.
Axiom ptr_eq_update : forall A P P' R R' G G' (p:ref{A|P}[R,G]) (r:ref{A|P'}[G',R']),
                        p≡r -> (forall h h' v, h'=heap_write p v h -> h'[r]=v).
(* ptr_eq_update is not likely to be effective for automated solving.  Possibly a good
   candidate for a custom tactic, or with experience with goals that need this
   perhaps we can rewrite it to be more useful as a general hint. *)
Require Import Coq.Setoids.Setoid.
Global Instance refl_ptr_eq {A P R G} : Reflexive (@ptr_eq A A P P R R G G). Admitted.
Global Instance trans_ptr_eq {A P R G} : Transitive (@ptr_eq A A P P R R G G). Admitted.

(** * Default Instances for reachability, containment, precision, folding *)
(** ** Reachability *)

(** A parameterized reachability instance useful for closed base types *)
Definition closed (A:Set) (T:Set){P R G} (p:ref{T|P}[R,G]) (a:A) : Prop := False.
Global Instance nat_reach : ImmediateReachability nat := {imm_reachable_from_in := closed nat}.
Global Instance bool_reach : ImmediateReachability bool := {imm_reachable_from_in := closed bool}.
Global Instance unit_reach : ImmediateReachability unit := {imm_reachable_from_in := closed unit}.
Global Instance pair_reach `{A:Set,B:Set,AR:ImmediateReachability A,BR:ImmediateReachability B} : ImmediateReachability (A*B) :=
  { imm_reachable_from_in :=
    fun T P R G v a => match a with
                   | (l,r) => imm_reachable_from_in v l \/ imm_reachable_from_in v r
                   end
  }.
Fixpoint list_reachable {A:Set}{AR:ImmediateReachability A} (T:Set){P R G} (v:ref{T|P}[R,G]) (a:list A) : Prop :=
  match a with
  | nil => False
  | cons hd tl => imm_reachable_from_in v hd \/ list_reachable T v tl
  end.
Global Instance list_reach `{A:Set,AR:ImmediateReachability A} : ImmediateReachability (list A) :=
  { imm_reachable_from_in := fun T P R G v a => list_reachable T v a }.
(** The reference immediate reachability instance (i.e. reflexivity) was defined earlier *)

(** TODO: Containment and folding are currently formulated as functions. I might get
    better expressiveness if they were formulated as relations (propositions) instead *)
(** ** Containment *)
(** For primitives, any relation contains the permitted interference (none) *)
Definition closed_contains (A:Set) (R:hrel A) : Prop := True.
Global Instance nat_contains : Containment nat := { contains := closed_contains nat }.
Global Instance bool_contains : Containment bool := { contains := closed_contains bool }.
Global Instance unit_contains : Containment unit := { contains := closed_contains unit }.
(** TODO: This pair contains is quite weak. If R cares assumes a certain domain
    of values for either component, this basically becomes unprovable. *)
Global Instance pair_contains `{A:Set,B:Set,CA:Containment A,CB:Containment B} : Containment (A*B) :=
  { contains :=
    fun R => contains (fun a a' h h' => forall b, R (a,b) (a',b) h h')
          /\ contains (fun b b' h h' => forall a, R (a,b) (a,b') h h')
  }.
Global Instance ref_contains {A:Set}{P:hpred A}{R G:hrel A} : Containment (ref{A|P}[R,G]) :=
  { contains :=
    fun R' => forall a a' h h',
                R a a' h h' ->
                forall (r:ref{A|P}[R,G]),
                  h[r]=a -> h'[r]=a' ->
                  R' r r h h'
  }.
(** TODO: polymorphic lists *)

(** ** Relation Folding *)
Definition const_rel_fold (A:Set) (R G:hrel A) : Set := A.
Definition const_id_fold {A:Set}(R G:hrel A)(x:A) := x.
Global Instance nat_fold : rel_fold nat := {rgfold := const_rel_fold nat; fold := const_id_fold}.
Global Instance bool_fold : rel_fold bool := {rgfold := const_rel_fold bool; fold := const_id_fold}.
Global Instance unit_fold : rel_fold unit := {rgfold := const_rel_fold unit; fold := const_id_fold}.
Global Instance pair_fold `{A:Set,B:Set,FA:rel_fold A,FB:rel_fold B}: rel_fold (A*B) :=
  { rgfold := fun R G =>
    prod (rgfold (fun _ _ _ _ => True) (fun a a' h h' => forall b, G (a,b) (a',b) h h'))
         (rgfold (fun _ _ _ _ => True) (fun b b' h h' => forall a, G (a,b) (a,b') h h')) ;
    fold := fun R G xy => match xy with (x,y) => (fold x, fold y) end
  }.
Global Instance ref_fold `{A:Set,P:hpred A,R:hrel A,G:hrel A} : rel_fold (ref{A|P}[R,G]) :=
  { rgfold := fun R' G' => ref{A|P}[R,G ⋂ (fun a a' h h' =>
                                             forall (r:ref{A|P}[R,G]), h[r]=a -> h'[r]=a' -> G' r r h h')]
  }.
(* We'll admit the runtime fold for references; the semantics for proofs will need an extensional treatment
   as an axiom. *)
Admitted.
Global Instance fn_fold {T : Set}{B : T -> Set} : rel_fold (forall x : T, B x) := {
    rgfold := fun _ _ => (forall x : T, B x);
    fold := fun _ _ x => x
  }.

(** TODO: polymorphic lists *)

(** ** Reachability, containment, and folding for pure types *)
(** A pure type is one that contains no references, anywhere.
    A polymorphic type is pure if all arguments to the type constructor
    and all data constructors are themselves pure. *)
Class pure_type (T:Set).
Global Instance pure_reachable `{A:Set,PA:pure_type A} : ImmediateReachability A :=
  { imm_reachable_from_in := fun _ _ _ _ _ _ => False }.
Global Instance pure_contains `{A:Set,PA:pure_type A} : Containment A :=
  { contains := fun _ => True }.
Global Instance pure_fold `{A:Set,PA:pure_type A} : rel_fold A :=
  { rgfold := fun _ _ => A ; fold := const_id_fold }.
Global Instance nat_pure : pure_type nat.
Global Instance bool_pure : pure_type bool.
Global Instance unit_pure : pure_type unit.
Global Instance list_pure `{A:Set,PA:pure_type A} : pure_type (list A).

(** ** Additional Axioms
    Things like heap dereference being the same between converted and unconverted references, etc. *)
(** For now we need an explicit subtyping operator *)
Axiom convert_P : forall {A:Set}{P P':hpred A}{R G}`{ImmediateReachability A},(forall v h, P v h -> P' v h) -> precise_pred P' -> stable P' R -> ref{A|P}[R,G] -> ref{A|P'}[R,G].
Axiom conversion_P_refeq : forall h A (P P':hpred A) (R G:hrel A)`{ImmediateReachability A} pf1 pf2 pf3 x, h[(@convert_P A P P' R G _ pf1 pf2 pf3 x)]=h[x].
Axiom convert : forall {A:Set}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A},
                ref{A|P}[R,G] ->
                (forall v h, P v h -> P' v h) ->
                (G' ⊆ G) -> (R ⊆ R') -> stable P' R' ->
                (G' ⊆ R') -> (* <-- self-splitting, this is a pure conversion *)
                ref{A|P'}[R',G'].
Axiom convert_equiv : forall {A}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A}
                             (r:ref{A|P}[R,G]) pfP pfG pfR stab splt,
                             forall h, h[r]=h[@convert A P P' R R' G G' _ r pfP pfG pfR stab splt].

Axiom refine_ref : forall {A:Set}{P P' R G}{fld : rel_fold A}{rfl : hreflexive G}
                   (r : ref{A|P}[R,G])
                   (x : rgfold R G),
                   stable P' R ->
                   ((@deref _ _ fld _ _ _ rfl (eq_refl) r) = x) -> (* <-- This is only available in special match statements, and flow is restricted! *)
                   (forall h, (fold (h[r]))=(deref rfl (eq_refl) r) -> (deref rfl eq_refl r) = x -> P (h[r]) h -> P' (h[r]) h) ->
                   ref{A|P'}[R,G].
Axiom refinement_equiv : forall {A P P' R G}{fld : rel_fold A}{rfl : hreflexive G}
                                (r:ref{A|P}[R,G]) x stab pf refpf,
                                forall h, h[r] = h[@refine_ref A P P' R G fld rfl r x stab pf refpf].