From iris.program_logic Require Export ectx_language ectxi_language.
From iris_logrel.prelude Require Export base.
From iris.algebra Require Export cofe.
From iris.prelude Require Import gmap.

Module lang.
  Definition loc := positive.

  Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive expr :=
  | Var (x : var)
  | Lam (e : {bind 1 of expr})
  | App (e1 e2 : expr)
  (* Unit *)
  | Unit
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  Instance expr_dec_eq (e e' : expr) : Decision (e = e').
  Proof. solve_decision. Defined.

  Inductive val :=
  | LamV (e : {bind 1 of expr})
  | TLamV (e : {bind 1 of expr})
  | UnitV
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | FoldV (v : val)
  | LocV (l : loc).

  Instance val_dec_eq (v v' : val) : Decision (v = v').
  Proof. solve_decision. Defined.

  Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | LamV e => Lam e
    | TLamV e => TLam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | FoldV v => Fold (of_val v)
    | LocV l => Loc l
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | TLam e => Some (TLamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Fold e => v ← to_val e; Some (FoldV v)
    | Loc l => Some (LocV l)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | TAppCtx
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val).

  Notation ectx := (list ectx_item).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | TAppCtx => TApp e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    end.

  Definition state : Type := gmap loc val.

  Inductive head_step : expr → state → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ e1.[e2/] σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ e σ []
  (* Polymorphic Types *)
  | TBeta e σ :
      head_step (TApp (TLam e)) σ e σ []
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Loc l)) σ (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Loc l) e) σ (Unit) (<[l:=v]>σ) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 e2 σ2 ef :
    head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
    head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom _ σ) in
    to_val e = Some v → head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.

  Canonical Structure stateC := leibnizC state.
  Canonical Structure valC := leibnizC val.
  Canonical Structure exprC := leibnizC expr.
End lang.

(** Language *)
Program Instance heap_ectxi_lang :
  EctxiLanguage
    (lang.expr) lang.val lang.ectx_item lang.state := {|
  of_val := lang.of_val; to_val := lang.to_val;
  fill_item := lang.fill_item; head_step := lang.head_step
|}.
Solve Obligations with eauto using lang.to_of_val, lang.of_to_val,
  lang.val_stuck, lang.fill_item_val, lang.fill_item_no_val_inj,
  lang.head_ctx_step_val.

Canonical Structure lang := ectx_lang (lang.expr).

Export lang.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | _ => False
  end.
Lemma is_atomic_correct e : is_atomic e → language.atomic e.
Proof.
  intros ?; apply ectx_language_atomic.
  - destruct 1; simpl; by eauto using to_of_val.
  - intros [|Ki K] e' -> Hval%eq_None_not_Some; [done|].
    destruct Hval; apply (fill_val K e'). destruct Ki; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Hint Extern 0 (language.atomic _) => solve_atomic.
Hint Extern 0 (language.atomic _) => solve_atomic : typeclass_instances.


Require Import Common Computation.Core ADT.Core Ensembles.

Section HideADT.

  Context {extSig : ADTSig}.
  (* The extended signature *)

  Context {resConstructorIndex : Type}.
  (* The restricted set of constructor indices *)

  Context {resMethodIndex : Type}.
  (* The restricted set of method indices *)

  Variable constructorMap : resConstructorIndex -> ConstructorIndex extSig.
  (* Map from restricted to extended constructor indices *)

  Variable methodMap : resMethodIndex -> MethodIndex extSig.
  (* Map from restricted to extended method indices *)

  Definition resSig :=
    {| ConstructorIndex := resConstructorIndex;
       MethodIndex := resMethodIndex;
       ConstructorDom idx := ConstructorDom extSig (constructorMap idx);
       MethodDomCod idx := MethodDomCod extSig (methodMap idx)
    |}.
  (* The signature of the ADT with restricted constructor and method indices *)

  Definition HideADT (extADT : ADT extSig) : ADT resSig :=
    match extADT with
        {| Rep := rep;
           Constructors := extConstructors;
           Methods := extMethods
        |} =>
        Build_ADT resSig
          (fun idx => extConstructors (constructorMap idx))
          (fun idx => extMethods (methodMap idx))
    end.

End HideADT.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P Q R X Y : Universe, ((wd_ X Y /\ (wd_ A B /\ (wd_ P Q /\ (wd_ B C /\ (wd_ A C /\ (wd_ Q A /\ (wd_ Q C /\ (wd_ P B /\ (wd_ P C /\ (wd_ R Y /\ (col_ A R B /\ (col_ X Y R /\ (col_ A P Q /\ (col_ B P Q /\ (col_ Q A C /\ col_ P B C))))))))))))))) -> col_ A B P)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D T X Y Z M1 Z1 : Universe, ((wd_ B D /\ (wd_ C D /\ (wd_ D T /\ (wd_ T X /\ (wd_ A D /\ (wd_ B C /\ (wd_ C T /\ (wd_ B T /\ (wd_ A B /\ (wd_ A C /\ (wd_ A T /\ (wd_ Y X /\ (wd_ Y T /\ (wd_ Y Z1 /\ (wd_ T Z /\ (wd_ Y M1 /\ (wd_ B Z1 /\ (wd_ A Z1 /\ (wd_ X Z1 /\ (wd_ M1 Z1 /\ (col_ A B M1 /\ (col_ T Y Z /\ (col_ A B Y /\ (col_ Y M1 Z1 /\ (col_ Y T X /\ (col_ B D C /\ col_ A D T)))))))))))))))))))))))))) -> col_ A B Z1)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Works in 8.9.1, submitted by jakobbotsh *)

Require Hurkens.

Module TypeNequivSmallType.
Import Hurkens.

Section Paradox.

(* I feel like this version of the paradox should already by in
   Hurkens.v but can't find it, there's only the version with A=U *)

Definition U := Type.
Variable A:U.

Variable down : U -> A.
Variable up : A -> U.
Hypothesis up_down : forall (X:U), up (down X) = X.

Theorem paradox : False.
Proof.
  Generic.paradox p.
  (** Large universe *)
  + exact U.
  + exact (fun X=>X).
  + cbn. exact (fun X F => forall x:X, F x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
  + exact (fun F => forall x:A, F (up x)).
  + cbn. exact (fun _ f => fun x:A => f (up x)).
  + cbn. intros * f X.
    specialize (f (down X)).
    rewrite up_down in f.
    exact f.
  (** Small universe *)
  + exact A.
  (** The interpretation of [A] as a universe is [U]. *)
  + cbn. exact up.
  + cbn. exact (fun _ F => down (forall x, up (F x))).
  + cbn. exact (fun _ F => down (forall x, up (F x))).
  + cbn. exact (down False).
  + rewrite up_down in p.
    exact p.
  + cbn. easy.
  + cbn. intros ? f X.
    destruct (up_down X). cbn.
    reflexivity.
  + cbn. intros ? ? f.
    rewrite up_down.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down in f.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down in f.
    exact f.
Qed.

End Paradox.

End TypeNequivSmallType.

Inductive foo (A:Type) := bar X : foo X -> foo A | nonempty.
Arguments nonempty {_}.

Notation U := TypeNequivSmallType.U.

Definition A : U := foo nat.

Definition down : U -> A := fun u => bar nat u nonempty.

Definition up : A -> U := fun a => match a with bar _ u _ => u | nonempty => nat end.

Lemma up_down : forall (X:U), up (down X) = X.
Proof.
  reflexivity.
Qed.

Definition contender_final : nat := 7.

Lemma n_lt_contender_final :
  forall n, n < contender_final.
Proof (match TypeNequivSmallType.paradox A down up up_down with end).

Print Assumptions n_lt_contender_final.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Cat.
Require Import Category.Instance.Cat.Cartesian.
Require Import Category.Instance.Sets.

Generalizable All Variables.

#[local] Set Transparent Obligations.

Definition pairing {A B : Type} (p : A * B) : p = (fst p, snd p) :=
  match p with (x, y) => eq_refl end.

#[export]
Program Instance Cat_Closed : @Closed Cat Cat_Cartesian := {
  exponent_obj := @Fun;         (* the internal hom is a functor category *)
  exp_iso := fun A B C =>
    {| to :=
       {| morphism := fun F : A × B ⟶ C =>
          {| fobj := fun x : A =>
             {| fobj := fun y : B => F (x, y)
              ; fmap := fun J K (f : J ~{B}~> K) =>
                  fmap[F] (@id A x, f) |}
           ; fmap := fun J K (f : J ~{A}~> K) =>
             {| transform := fun L : B =>
                  fmap[F] (f, @id B L) |} |} |}
     ; from :=
       {| morphism := fun F : A ⟶ [B, C] =>
          {| fobj := fun x : A × B => F (fst x) (snd x)
           ; fmap := fun J K (f : J ~{A × B}~> K) =>
               fmap (snd f) ∘ transform[fmap[F] (fst f)] _ |} |} |}
}.
Next Obligation.
  proper; apply fmap_respects.
  split; simpl; cat.
Qed.
Next Obligation.
  rewrite <- fmap_comp; simpl.
  apply fmap_respects; split; simpl; cat.
Qed.
Next Obligation.
  rewrite <- !fmap_comp.
  apply fmap_respects; simpl; cat; simpl; cat.
Qed.
Next Obligation.
  rewrite <- !fmap_comp.
  apply fmap_respects; simpl; cat.
Qed.
Next Obligation.
  proper; simpl; cat;
  rewrites; reflexivity.
Qed.
Next Obligation.
  simpl; intros.
  rewrite <- fmap_comp.
  apply fmap_respects; cat; simpl; cat.
Qed.
Next Obligation.
  proper.
  - isomorphism; simpl.
    + transform; simpl; intros.
      * apply x0.
      * simpl.
        rewrite e.
        rewrite !comp_assoc.
        rewrite iso_to_from; cat.
      * simpl.
        rewrite e.
        rewrite !comp_assoc.
        rewrite iso_to_from; cat.
    + transform; simpl; intros.
      * apply x0.
      * simpl.
        rewrite e.
        rewrite <- !comp_assoc.
        rewrite iso_to_from; cat.
      * simpl.
        rewrite e.
        rewrite <- !comp_assoc.
        rewrite iso_to_from; cat.
    + simpl; cat; apply iso_to_from.
    + simpl; cat; apply iso_from_to.
  - apply e.
Qed.
Next Obligation.
  proper.
  rewrite H.
  comp_left.
  destruct F; simpl in *.
  apply fmap_respects.
  assumption.
Qed.
Next Obligation.
  simpl; cat.
  destruct F; simpl in *.
  rewrite fmap_id; cat.
Qed.
Next Obligation.
  symmetry.
  rewrite naturality.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (fmap[F o1] h2)).
  rewrite <- fmap_comp.
  rewrite naturality.
  rewrite comp_assoc.
  destruct F; simpl in *.
  rewrite <- !fmap_comp.
  rewrite naturality.
  reflexivity.
Qed.
Next Obligation.
  proper; simpl.
  - isomorphism.
    + apply x0.
    + apply (from (x0 _)).
    + srewrite (iso_to_from (x0 x1)); cat.
    + srewrite (iso_from_to (x0 x1)); cat.
  - simpl.
    rewrite e.
    do 2 comp_right.
    apply naturality.
Qed.
Next Obligation.
  constructive; simpl.
  - transform; simpl; intros.
    + exact id.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
  - transform; simpl; intros.
    + exact id.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
  - simpl; cat.
  - destruct x; simpl in *.
    rewrite fmap_id; cat.
  - destruct x; simpl in *; cat.
Qed.
Next Obligation.
  constructive; simpl.
  - rewrite <- pairing.
    exact id.
  - rewrite <- pairing.
    exact id.
  - destruct x0; simpl; cat.
  - destruct x0; simpl; cat.
  - destruct f; simpl; cat.
    rewrite <- fmap_comp.
    apply fmap_respects; simpl; cat.
Qed.
Next Obligation.
  constructive; simpl.
  - rewrite <- pairing.
    exact id.
  - rewrite <- pairing.
    exact id.
  - destruct x; simpl; cat.
  - destruct x; simpl; cat.
  - destruct f; simpl; cat.
    rewrite <- fmap_comp.
    apply fmap_respects; simpl; cat.
Qed.


Require Import String. Import StringSyntax.

(* Is this relevant? *)

Add LoadPath  "/local/res/josh/coq" as Ling.

(* First compile BS.v as follows.
 /Applications/CoqIDE_8.13.1.app/Contents/Resources/bin/coqc -Q . Ling -vos BSm2.v

Josh has put in changes from BSm.v.
*)

From Ling Require Import BSm2.
Import Ling.

(* muddy, copulatives *)

Definition muddy : AP := et "muddy".
Definition is : (DP \ S) / AP := fun x y => x y.

(* Generalized bind *)
Definition gbind {a b c : Cat} (x : a || b -- c) : a || (c >> b) -- c :=
  fun k => x (fun y => k y y).

(*
 This is the type of a structured antecedent. S[DP\S] encodes a propositional and
 a predicate antecedent.
*)

Notation "x [ y ]" := (Struct y x) (at level 30, format "x [ y ]").

(* The recursive focus stuff is cut.

The category of the structured binder is

S || S[DP \ S] >> S
--
S

indicating power to bind a S[DP \ S] pronoun. The category of [BEN did ---] should be

S[DP \ S] >> S || S
--
S

*)

(* Copied from focus.v renaming focus to foc. *)

Parameter (alt : Prop -> ((interp DP) -> Prop) -> (interp DP) -> Prop).

Definition foc (x : DP) : ((S >> S) || S -- S)|| S -- DP :=
  fun k => (fun f => (fun p => (f (alt p k x)) /\ k x)).

(* Example with focus anaphora. This should be modified to parasitic focus-vp anaphora. *)

Check lower ((gbind (lift (ari <: (is :> muddy)))) <|
      ((lift and) |> (lower ((foc ben)  <| (lift (is :> muddy)))))).

Eval compute in lower ((gbind (lift (ari <: (is :> muddy)))) <|
      ((lift and) |> (lower ((foc ben)  <| (lift (is :> muddy)))))).

(*

Guess the semantics of BEN_F_did.

  BEN_F_did equires a structured antecedent, providing a propositional and a VP
  antecedent.
*)

Definition BEN_F_did : ((S[DP \ S] >> S) || S -- S) :=
      fun (f : Prop -> Prop)
      (x : (E -> Prop) * ((E -> Prop) -> Prop))
    => f
         (alt ((snd x) (fst x)) (fun y : E => (fst x) y)
            ben) /\
       (fst x) ben.

(*
(S[DP \ S] >> S) || S
--
S
*)

Definition ALICE_F_did : ((S[DP \ S] >> S) || S -- S) :=
      fun (f : Prop -> Prop)
      (x : (E -> Prop) * ((E -> Prop) -> Prop))
    => f
         (alt ((snd x) (fst x)) (fun y : E => (fst x) y)
            alice) /\
       (fst x) alice.

Check ALICE_F_did.

(*
Define an operator that applies to VP to create the structured antecedent.
This has the two towers strategy, where the result for the lower tower
is a tower.
*)

(* TODO: generalize to DP \ DP \ S, .... *)

(* TODO: generalize ant to apply to a tower, not just DP \ S *)
(* allow ant to apply to not just S on the left, but like DP >> S *)

Definition ant (f : DP \ S) : (S || (S[DP \ S] >> S) -- S)|| S -- (DP \ S) :=
    fun c => (fun k =>
       k (c f)
         (f, c)).

Eval compute in lower ((lift john) <| (ant (kissed ben))).
(*
fun k : Prop ->
             (E -> Prop) * ((E -> Prop) -> Prop) -> Prop
       =>
       k (eet "kiss" (e "john") (e "ben"))
         (fun x : E => eet "kiss" x (e "ben"),
         fun a : E -> Prop => a (e "john"))
     :
S || S[DP \ S] >> S
--
S

*)

Definition john_kissed_ben_and_ALICE_F_did :=
 lower ((lower ((lift john) <| (ant (kissed ben)))) <| ((lift and) |> ALICE_F_did)).

Eval compute in john_kissed_ben_and_ALICE_F_did.

(*
     = (eet "kiss" (e "john") (e "ben") /\
        alt (eet "kiss" (e "john") (e "ben"))
          (fun y : E => eet "kiss" y (e "ben"))
          (e "alice")) /\
       eet "kiss" (e "alice") (e "ben")
     : S

In the above, ALICE_F_did is a primitive, rather than being derived compositionally. Fixing this is
the next step.

It should be done in a way that 'did' contributes a simple VP antecedent, or one with one or more pronouns.

*)

Definition did : ((DP \ S) >> S) || S -- (DP \ S) := fun k => k.

(* FOC turns a structured anaphor into a regular one, adding the alt operator along the way. *)

Definition FOC (a : DP) : (S[DP \ S] >> S) || ((DP \ S) >> S) -- DP :=
  fun (k : DP -> (DP \ S) >> S)
      (ana : S[DP \ S]) =>
    k a (fst ana) /\
    alt ((snd ana) (fst ana)) (fun y => (fst ana) y) a.

Check (FOC alice <| did).
Definition compositional_version' := lower ((lower ((lift john) <| (ant (kissed ben)))) <| ((lift and) |> (FOC alice <| did))).

Eval compute in compositional_version'.

Goal john_kissed_ben_and_ALICE_F_did <-> compositional_version'.
  firstorder.
Qed.

(* TODO's:

   - Generalize to other variable versions,
       NP:
       "A short man ate ice cream, and a TALL one did as well."

       no variables:
       "John praised his mother, and BEN praised his mother too."

   - Enforce only structured anaphors:
      - maybe disallow BIND on (DP \ S)? And only allow structured anaphoric bind
      - block plain VP anaphors across S's
           - Maybe add a typeclass constraint on cleft/cright (|> / <|) that blocks this propogation

   - Do covariance / sloppy identity in this framework
      - covariance:
        ARI knows he is muddy, but ben doesn't know this.
        -> ben doesn't know ben is muddy
        -> ben doesn't know ari is muddy

*)


(* begin hide *)

From ITree Require Import
     Basics.Basics
     Core.Subevent.

From CTree Require Import
  CTree
  Eq.

Import CTreeNotations.
Open Scope ctree_scope.

(* end hide *)

(*|
Helper inductive: [epsilon_det t t'] judges that [t' ≡ Guard* t]
|*)
  Inductive epsilon_det {E C X} `{B1 -< C}: relation (ctree E C X) :=
  | epsilon_det_id : forall t t', t ≅ t' -> epsilon_det t t'
  | epsilon_det_tau : forall t t' t'',
      epsilon_det t t' -> t'' ≅ Guard t -> epsilon_det t'' t'.

(*|
Helper inductive: [productive t] judges that [t]'s head constructor is not a [BrD]
|*)
  Inductive productive {E C X} : ctree E C X -> Prop :=
  | prod_ret {r t} (EQ: t ≅ Ret r) : productive t
  | prod_vis {Y} {e : E Y} {k t} (EQ: t ≅ Vis e k) : productive t
  | prod_tau {X} {c: C X} {k t} (EQ: t ≅ BrS c k) : productive t.

(*|
Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a path made of [BrD] branches.
|*)
  Inductive epsilon_ {E C X} : ctree' E C X -> ctree' E C  X -> Prop :=
  | EpsilonId : forall t t', t ≅ t' -> epsilon_ (observe t) (observe t')
  | EpsilonBr : forall X (c: C X) k x t, epsilon_ (observe (k x)) t -> epsilon_ (BrDF c k) t.

  Definition epsilon {E C X} (t t' : ctree E C X) := epsilon_ (observe t) (observe t').

  Section epsilon_det_theory.

    #[global] Instance epsilon_det_equ {E C X} `{Tau: B1 -< C}:
    Proper (equ eq ==> equ eq ==> flip impl) (@epsilon_det E C X _).
    Proof.
      cbn. intros.
      revert x H. induction H1; intros.
      - econstructor. now rewrite H0, H1.
      - eapply epsilon_det_tau. apply IHepsilon_det. apply H0. reflexivity. rewrite H2. apply H.
    Qed.

    #[global] Instance epsilon_det_equ' {E C X} `{Tau: B1 -< C}:
      Proper (equ eq ==> equ eq ==> impl) (@epsilon_det E C X _).
    Proof.
      cbn. intros. rewrite <- H, <- H0. apply H1.
    Qed.

    #[global] Instance epsilon_det_refl {E C X} `{HasB1: B1 -< C} :
      Reflexive (@epsilon_det E C X _).
    Proof.
      now left.
    Qed.

    Lemma epsilon_det_bind {E C X Y} `{Tau: B1 -< C}: forall (t t' : ctree E C X) (k : X -> ctree E C Y),
        epsilon_det t t' ->
        epsilon_det (t >>= k) (t' >>= k).
    Proof.
      intros. induction H.
      - rewrite H. constructor. reflexivity.
      - rewrite H0. setoid_rewrite bind_guard. eapply epsilon_det_tau. apply IHepsilon_det. reflexivity.
    Qed.

    Lemma epsilon_det_bind_ret_l {E C X Y} `{Tau: B1 -< C}: forall (t : ctree E C X) t' (k : X -> ctree E C Y) x,
        epsilon_det t (Ret x) ->
        epsilon_det (k x) t' ->
        epsilon_det (t >>= k) t'.
    Proof.
      intros. remember (Ret x) as R. revert t' k x HeqR H0. induction H; intros; subst.
      - subst. rewrite H, bind_ret_l. apply H0.
      - rewrite H0. setoid_rewrite bind_guard.
        eapply epsilon_det_tau. 2: reflexivity. eapply IHepsilon_det. reflexivity. apply H1.
    Qed.

    Lemma epsilon_det_bind_ret_l_equ {E C X Y} `{Tau: B1 -< C}:
      forall (t : ctree E C X) (k : X -> ctree E C Y) x,
        epsilon_det t (Ret x) ->
        x <- t;; k x ≅ t;; k x.
    Proof.
      intros. remember (Ret x) as R. induction H; subst.
      - rewrite H. rewrite !bind_ret_l. reflexivity.
      - rewrite H0. rewrite !bind_guard. apply br_equ. intro. apply IHepsilon_det. reflexivity.
    Qed.

    Lemma epsilon_det_trans {E C X} `{Stuck: B0 -< C} `{Tau: B1 -< C} :
      forall l (t t' t'' : ctree E C X),
        epsilon_det t t' -> trans l t' t'' -> trans l t t''.
    Proof.
      intros. induction H.
      - now rewrite H.
      - apply IHepsilon_det in H0. apply trans_guard in H0. now rewrite <- H1 in H0.
    Qed.

    Lemma sbisim_epsilon_det {E C X} `{Stuck: B0 -< C} `{Tau: B1 -< C}:
      forall (t t' : ctree E C X), epsilon_det t t' -> t ~ t'.
    Proof.
      intros. induction H.
      - now rewrite H.
      - rewrite H0. rewrite sb_guard. apply IHepsilon_det.
    Qed.

  End epsilon_det_theory.

  Section productive_theory.

    #[global] Instance productive_equ : forall {E C X}, Proper (equ eq ==> impl) (@productive E C X).
    Proof.
      cbn. intros. inv H0; rewrite H in *.
      - eapply prod_ret; eauto.
      - eapply prod_vis; eauto.
      - eapply prod_tau; eauto.
    Qed.

    #[global] Instance productive_equ' : forall {E C X}, Proper (equ eq ==> flip impl) (@productive E C X).
    Proof.
      cbn. intros. rewrite <- H in H0. apply H0.
    Qed.

    #[local] Hint Constructors productive : trans.

    Lemma ctree_case_productive : forall {E C X} (t: ctree E C X),
      productive t \/ exists X (c : C X) k, t ≅ BrD c k.
    Proof.
      intros. setoid_rewrite (ctree_eta t). desobs t; etrans.
      destruct vis; etrans.
    Qed.

    Lemma productive_br {E C X Y} : forall vis c (k : Y -> ctree E C X),
      productive (Br vis c k) -> vis = true.
    Proof.
      intros. inv H; inv_equ. reflexivity.
    Qed.

    Lemma productive_brD : forall {E C X Y} (c : C Y) (k : Y -> ctree E C X),
      ~ productive (BrD c k).
    Proof.
      intros ** ?. inversion H; inv_equ.
    Qed.

    Lemma productive_bind : forall {E C X Y} t (k : Y -> ctree E C X), productive (t >>= k) -> productive t.
    Proof.
      intros. inversion H; inv_equ; subst.
      - apply ret_equ_bind in EQ as (? & ? & ?). subs. now eapply prod_ret.
      - apply vis_equ_bind in EQ as [(? & ?) | (? & ? & ?)]; subs.
        + now eapply prod_ret.
        + now eapply prod_vis.
      - apply br_equ_bind in EQ as [(? & ?) | (? & ? & ?)]; subs.
        + now eapply prod_ret.
        + now eapply prod_tau.
    Qed.

  End productive_theory.

  #[global] Hint Constructors productive : trans.
  #[global] Hint Resolve productive_brD : trans.

  Section epsilon_theory.

    #[global] Instance epsilon_equ_ {E C X} :
    Proper (going (equ eq) ==> going (equ eq) ==> impl) (@epsilon_ E C X).
    Proof.
      cbn. intros.
      revert y y0 H H0. induction H1; intros.
      - pose (EpsilonId (go y) (go y0)). cbn in e. apply e.
        rewrite <- H0, <- H1, H. reflexivity.
      - destruct H. step in H. inv H. invert.
        econstructor.
        apply IHepsilon_.
        + constructor.
          rewrite <- !ctree_eta. apply REL.
        + apply H0.
    Qed.

    #[global] Instance epsilon_equ_' {E C X} :
      Proper (going (equ eq) ==> going (equ eq) ==> flip impl) (@epsilon_ E C X).
    Proof.
      cbn. intros. now rewrite <- H, <- H0 in H1.
    Qed.

    #[global] Instance epsilon_equ {E C X} : Proper (equ eq ==> equ eq ==> iff) (@epsilon E C X).
    Proof.
      unfold epsilon. split; intros.
      - now rewrite <- H, <- H0.
      - now rewrite H, H0.
    Qed.

    #[global] Instance epsilon_refl {E C X} :
      Reflexive (@epsilon E C X).
    Proof.
      now left.
    Qed.

    Lemma epsilon_br {E C X Y} : forall (t' : ctree E C X) k (c : C Y) x,
      epsilon (k x) t' -> epsilon (BrD c k) t'.
    Proof.
      intros. eright. apply H.
    Qed.

    Lemma epsilon_case {E C X} : forall (t t' : ctree E C X),
      epsilon t t' ->
      t ≅ t' \/ exists Y (c : C Y) k x, t ≅ BrD c k /\ epsilon (k x) t'.
    Proof.
      intros * EPS.
      inversion EPS; [left | right].
      - setoid_rewrite ctree_eta. now rewrite <- H, H1, H0.
      - subst. exists X0, c, k, x. split; auto. now rewrite H, <- ctree_eta.
    Qed.

    Lemma epsilon_trans {E C X} `{Stuck: B0 -< C} : forall (t t' : ctree E C X),
        epsilon t t' -> forall l t'', trans l t' t'' -> trans l t t''.
    Proof.
      intros. red in H. rewrite ctree_eta. rewrite ctree_eta in H0.
      genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'.
      induction H.
      - rewrite H. apply H0.
      - apply IHepsilon_ in H0. eapply trans_brD in H0. apply H0. rewrite <- ctree_eta. reflexivity.
    Qed.

    Lemma epsilon_fwd : forall {E C X} (t : ctree E C X) k x (c : C X),
        epsilon t (BrD c k) -> epsilon t (k x).
    Proof.
      intros. red in H. red.
      genobs t ot. clear t Heqot.
      remember (observe (BrD c k)) as oc.
      revert c k x Heqoc. induction H.
      - intros. rewrite H, Heqoc. cbn. eapply EpsilonBr. econstructor. reflexivity.
      - intros. subst. eapply EpsilonBr. eapply IHepsilon_. reflexivity.
    Qed.

    Lemma trans_epsilon {E C X} `{Stuck: B0 -< C} l (t t'' : ctree E C X) : trans l t t'' -> exists t',
          epsilon t t' /\ productive t' /\ trans l t' t''.
    Proof.
      intros. do 3 red in H.
      setoid_rewrite (ctree_eta t). setoid_rewrite (ctree_eta t'').
      genobs t ot. genobs t'' ot''. clear t Heqot t'' Heqot''.
      induction H; intros.
      - destruct IHtrans_ as (? & ? & ? & ?).
        rewrite <- ctree_eta in H0. eapply EpsilonBr in H0.
        exists x0. etrans.
      - eexists. split; [| split ].
        + left. reflexivity.
        + eapply prod_tau. reflexivity.
        + rewrite <- H, <- ctree_eta. etrans.
      - eexists. split; [| split ].
        + left. reflexivity.
        + eapply prod_vis. reflexivity.
        + rewrite <- H, <- ctree_eta. etrans.
      - eexists. split; [| split ].
        + left. reflexivity.
        + eapply prod_ret. reflexivity.
        + rewrite br0_always_stuck. etrans.
    Qed.

    Lemma trans_val_epsilon {E C X}  `{Stuck: B0 -< C}  : forall x (t t' : ctree E C X),
        trans (val x) t t' -> epsilon t (Ret x) /\ t' ≅ stuckD.
    Proof.
      intros. apply trans_epsilon in H as (? & ? & ? & ?).
      inv H0.
      - rewrite EQ in H, H1. inv_trans. subst. auto.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans.
    Qed.

    Lemma trans_tau_epsilon {E C X}  `{Stuck: B0 -< C} : forall (t t' : ctree E C X),
        trans tau t t' -> exists X (c: C X) k x, epsilon t (BrS c k) /\ t' ≅ k x.
    Proof.
      intros. apply trans_epsilon in H as (? & ? & ? & ?).
      inv H0.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans.
        do 2 eexists.
        exists k. exists x0.
        eauto.
    Qed.

    Lemma trans_obs_epsilon {E C X Y} `{Stuck: B0 -< C} : forall (t t' : ctree E C X) e (x : Y),
        trans (obs e x) t t' -> exists k, epsilon t (Vis e k) /\ t' ≅ k x.
    Proof.
      intros. apply trans_epsilon in H as (? & ? & ? & ?).
      inv H0.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans. subst. etrans.
      - rewrite EQ in H1. inv_trans.
    Qed.

    Lemma productive_epsilon {E C X} : forall (t t' : ctree E C X),
        productive t -> epsilon t t' -> t ≅ t'.
    Proof.
      intros. setoid_rewrite ctree_eta.
      inversion H; subst; rewrite (ctree_eta t) in EQ; inversion H0; subst.
      - now rewrite H3.
      - rewrite <- H1 in EQ. step in EQ. inv EQ.
      - now rewrite H3.
      - rewrite <- H1 in EQ. step in EQ. inv EQ.
      - now rewrite H3.
      - rewrite <- H1 in EQ. step in EQ. inv EQ.
    Qed.

    Lemma epsilon_transitive {E C X} : forall (t u v : ctree E C X),
      epsilon t u -> epsilon u v -> epsilon t v.
    Proof.
      intros. red in H.
      rewrite (ctree_eta t). rewrite (ctree_eta u) in H0.
      genobs t ot. genobs u ou. clear t Heqot u Heqou.
      revert v H0. induction H; intros.
      - subs. apply H0.
      - setoid_rewrite <- ctree_eta in IHepsilon_.
        eright. now apply IHepsilon_.
    Qed.

    Lemma epsilon_bind_l {E C X Y} : forall t t' (k : Y -> ctree E C X),
      epsilon t t' -> epsilon (t >>= k) (t' >>= k).
    Proof.
      intros. setoid_rewrite (ctree_eta t). setoid_rewrite (ctree_eta t').
      red in H. genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'.
      induction H.
      - subs. reflexivity.
      - rewrite bind_br. eright. rewrite (ctree_eta (k0 x)). apply IHepsilon_.
    Qed.

    Lemma epsilon_bind_ret {E C X Y} : forall t (k : Y -> ctree E C X) v,
      epsilon t (Ret v) -> epsilon (t >>= k) (k v).
    Proof.
      intros. rewrite <- (bind_ret_l v k).
      now apply epsilon_bind_l.
    Qed.

    Lemma epsilon_bind {E C X Y} : forall t u (k : Y -> ctree E C X) v,
      epsilon t (Ret v) -> epsilon (k v) u -> epsilon (t >>= k) u.
    Proof.
      intros. eapply epsilon_bind_ret in H.
      eapply epsilon_transitive; eassumption.
    Qed.

    Lemma epsilon_det_epsilon {E C X} `{Stuck: B0 -< C} `{Tau: B1 -< C} : forall (t t' : ctree E C X),
        epsilon_det t t' -> epsilon t t'.
    Proof.
      intros. induction H.
      - now left.
      - rewrite H0. now right.
    Qed.

    Lemma ss_epsilon_l {E F C D X Y L R} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u : ctree F D Y) :
      (forall t0, epsilon t t0 -> productive t0 -> ss L R t0 u) ->
      ss L R t u.
    Proof.
      intros. cbn. intros. apply trans_epsilon in H0 as (? & ? & ? & ?).
      red in H0.
      setoid_rewrite (ctree_eta t) in H. genobs t ot. clear t Heqot.
      rewrite (ctree_eta x) in H1, H2. genobs x ox. clear x Heqox.
      induction H0.
      - apply H in H1 as ?. 2: { rewrite H0. now left. }
        apply H3 in H2. apply H2.
      - apply IHepsilon_; auto. intros. apply H; auto. eright. apply H3.
    Qed.

    Lemma ss_epsilon_r {E F C D X Y L R} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u u0 : ctree F D Y) :
      epsilon u u0 ->
      ss L R t u0 ->
      ss L R t u.
    Proof.
      intros. cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?).
      eapply epsilon_trans in H1; eauto.
    Qed.

    Lemma ssim_epsilon_l {E F C D X Y L} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u : ctree F D Y) :
      (forall t0, epsilon t t0 -> productive t0 -> ssim L t0 u) ->
      ssim L t u.
    Proof.
      intros. step. apply ss_epsilon_l.
      intros. apply H in H1. now step in H1. assumption.
    Qed.

    Lemma ssim_epsilon_r {E F C D X Y L} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u u0 : ctree F D Y) :
      epsilon u u0 ->
      ssim L t u0 ->
      ssim L t u.
    Proof.
      intros. cbn. intros.
      step in H0. step. eapply ss_epsilon_r in H0; eauto.
    Qed.

    Lemma ssim_ret_epsilon {E F C D X Y L} `{HasB0: B0 -< C} `{HasB0': B0 -< D} :
      forall r (u : ctree F D Y),
      Respects_val L ->
      (Ret r : ctree E C X) (≲L) u ->
      exists r', epsilon u (Ret r') /\ L (val r) (val r').
    Proof.
      intros * RV SIM *.
      step in SIM. specialize (SIM (val r) stuckD (trans_ret _)).
      destruct SIM as (l' & u' & TR & _ & EQ).
      apply RV in EQ as ?. destruct H as [? _]. specialize (H (Is_val _)). inv H.
      apply trans_val_invT in TR as ?. subst.
      apply trans_val_epsilon in TR as []. eauto.
    Qed.

    Lemma ssim_vis_epsilon {E F C D X Y Z L} `{HasB0: B0 -< C} `{HasB0': B0 -< D} :
      forall e (k : Z -> ctree E C X) (u : ctree F D Y),
      Respects_val L ->
      Respects_tau L ->
      Vis e k (≲L) u ->
      forall x, exists Z' (e' : F Z') k' y, epsilon u (Vis e' k') /\ k x (≲L) k' y /\ L (obs e x) (obs e' y).
    Proof.
      intros * RV RT SIM *.
      step in SIM. cbn in SIM. specialize (SIM (obs e x) (k x) (trans_vis _ _ _)).
      destruct SIM as (l' & u'' & TR & SIM & EQ).
      apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR).
      destruct PROD.
      1: {
        subs. inv_trans. subst.
        apply RV in EQ. destruct EQ as [_ ?]. specialize (H (Is_val _)). inv H.
      }
      2: {
        subs. inv_trans. subst.
        apply RT in EQ. destruct EQ as [_ ?]. specialize (H eq_refl). inv H.
      }
      subs. inv_trans. subst.
      eexists _, _, _, _. etrans.
    Qed.

    Lemma ssim_brS_epsilon {E F C D X Y Z L} `{HasB0: B0 -< C} `{HasB0': B0 -< D} :
      forall c (k : Z -> ctree E C X) (u : ctree F D Y),
      Respects_tau L ->
      L tau tau ->
      BrS c k (≲L) u ->
      forall x, exists Z' (c' : D Z') k' y, epsilon u (BrS c' k') /\ k x (≲L) k' y.
    Proof.
      intros * RT HL SIM *.
      step in SIM. cbn in SIM. specialize (SIM tau (k x) (trans_brS _ _ _)).
      destruct SIM as (l' & u'' & TR & SIM & EQ).
      apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR).
      destruct PROD.
      1: {
        subs. inv_trans. subst.
        apply RT in EQ. destruct EQ as [? _]. specialize (H eq_refl). inv H.
      }
      1: {
        subs. inv_trans. subst.
        apply RT in EQ. destruct EQ as [? _]. specialize (H eq_refl). inv H.
      }
      subs. inv_trans. subst.
      eexists _, _, _, _. etrans.
    Qed.

  End epsilon_theory.

#[global] Hint Resolve epsilon_trans : trans.


(** This file implements boolsets as functions into Prop. *)
From stdpp Require Export prelude.
From stdpp Require Import options.

Record boolset (A : Type) : Type := BoolSet { boolset_car : A → bool }.
Arguments BoolSet {_} _ : assert.
Arguments boolset_car {_} _ _ : assert.

Instance boolset_top {A} : Top (boolset A) := BoolSet (λ _, true).
Instance boolset_empty {A} : Empty (boolset A) := BoolSet (λ _, false).
Instance boolset_singleton `{EqDecision A} : Singleton A (boolset A) := λ x,
  BoolSet (λ y, bool_decide (y = x)).
Instance boolset_elem_of {A} : ElemOf A (boolset A) := λ x X, boolset_car X x.
Instance boolset_union {A} : Union (boolset A) := λ X1 X2,
  BoolSet (λ x, boolset_car X1 x || boolset_car X2 x).
Instance boolset_intersection {A} : Intersection (boolset A) := λ X1 X2,
  BoolSet (λ x, boolset_car X1 x && boolset_car X2 x).
Instance boolset_difference {A} : Difference (boolset A) := λ X1 X2,
  BoolSet (λ x, boolset_car X1 x && negb (boolset_car X2 x)).
Instance boolset_top_set `{EqDecision A} : TopSet A (boolset A).
Proof.
  split; [split; [split| |]|].
  - by intros x ?.
  - by intros x y; rewrite <-(bool_decide_spec (x = y)).
  - split; [apply orb_prop_elim | apply orb_prop_intro].
  - split; [apply andb_prop_elim | apply andb_prop_intro].
  - intros X Y x; unfold elem_of, boolset_elem_of; simpl.
    destruct (boolset_car X x), (boolset_car Y x); simpl; tauto.
  - done.
Qed.
Instance boolset_elem_of_dec {A} : RelDecision (∈@{boolset A}).
Proof. refine (λ x X, cast_if (decide (boolset_car X x))); done. Defined.

Typeclasses Opaque boolset_elem_of.
Global Opaque boolset_empty boolset_singleton boolset_union
  boolset_intersection boolset_difference.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Vocabularies *)

Set Implicit Arguments.

Require Import Relations Morphisms.
Require Import Sumbool.
Require List.
Require Import ZArith.
Require Import hpattern vgtac.
Require Import TStr.

Notation "A &&& B" := (sumbool_and _ _ _ _ A B)
                        (at level 80, right associativity) : sumbool.
Notation "A ||| B" := (sumbool_or _ _ _ _ A B)
                        (at level 85, right associativity) : sumbool.
Notation "~~ A" := (sumbool_not _ _ A)
                        (at level 75, right associativity) : sumbool.

Definition default {A : Type} (def : A) (opt_v : option A) : A :=
  match opt_v with
    | Some v => v
    | None => def
  end.

Definition opt_eq {A : Type} (req : relation A) : relation (option A) :=
  fun opt_x opt_y =>
    match opt_x, opt_y with
      | Some x, Some y => req x y
      | None, None => True
      | _, _ => False
    end.

Definition list_fold {A C : Type} (f : A -> C -> C) (l : list A) (acc : C)
           : C :=
  List.fold_left (fun acc x => f x acc) l acc.

Fixpoint list_fold2_def {A B C : Type} (f : A -> B -> C -> C)
         (l1 : list A) (l2 : list B) (acc default : C) : C :=
  match l1, l2 with
    | nil, nil => acc
    | (a :: l1')%list, (b :: l2')%list =>
      list_fold2_def f l1' l2' (f a b acc) default
    | _, _ => default
  end.

Fixpoint list_fold2 {A B C : Type} (f : A -> B -> C -> C)
         (l1 : list A) (l2 : list B) (acc : C) : C :=
  match l1, l2 with
    | nil, nil => acc
    | (a :: l1')%list, (b :: l2')%list =>
      list_fold2 f l1' l2' (f a b acc)
    | _, _ => acc
  end.

Definition nat_eqb x y := if eq_nat_dec x y then true else false.

Definition print {A : Type} (_ : A) : unit := tt.
Extract Constant print => "fun _ -> ()".

Definition print2 {A B : Type} (_ : A) (_ : B) : unit := tt.
Extract Constant print2 => "fun _ _ -> ()".

Definition print_when_false {A B : Type} (print : A -> unit) (print_arg : A)
           (step : B -> bool) (arg : B) : bool := step arg.
Extract Constant print_when_false =>
"fun print print_arg step arg ->
 if step arg then true else (print print_arg; false)".

Definition small_step {A B : Type} (f : A -> B) (arg : A) : B := f arg.

Axiom physical_eq : forall (A : Type) (x y : A), bool.
Extract Constant physical_eq => "( == )".
Axiom physical_eq_prop :
  forall A (x y : A) (Heq : physical_eq x y = true), x = y.
Axiom structural_eq : forall {A : Type} (x y : A), bool.
Extract Constant structural_eq => "( = )".
Axiom structural_eq_prop :
  forall A (x y : A) (Heq : structural_eq x y = true), x = y.
Axiom invalid_arg : forall {A : Type} (msg : string_t), A.
Extract Constant invalid_arg => "invalid_arg".

Definition string_lengthZ s := Z.of_nat (S (String.length s)).

Ltac dest_if_dec :=
match goal with
  | [H : context [if ?x then _ else _] |- _] => destruct x; try by auto
  | [ |- context [if ?x then _ else _] ] => destruct x; try by auto
end.

Ltac dest_if :=
match goal with
  | [H : context [if ?cond then _ else _] |- _] =>
    let cond' := fresh "cond" in
    remember cond as cond'; destruct cond'; try by auto
end.

Ltac dest_bool :=
  repeat match goal with
           | [H: andb _ _ = true |- _] => apply Bool.andb_true_iff in H
         end.

Ltac dest_trivial_match :=
match goal with
  | [H: Some _ = match ?x with None => None | _ => _ end |- _ ] =>
    let cond := fresh "cond" in
    remember x as cond; destruct cond; try by auto
  | [H: match ?x with Some _ => _ | None => False end |- _ ] =>
    let cond := fresh "cond" in
    remember x as cond; destruct cond; try by auto
  | [H: match ?x with Some _ => _ | None => false end = true |- _ ] =>
    let cond := fresh "cond" in
    remember x as cond; destruct cond; try by auto
end.

Definition monotone (C A : Type) le gamma :=
  forall (c: C) (x y: A) (Hx: gamma c x) (Hle: le x y), gamma c y.

Definition c_div (x y : Z) : Z :=
  (if Z_ge_dec x 0 then x / y else (- (-x / y)))%Z.

Lemma c_div_monotone :
  forall l u (Hlu : (l <= u)%Z) x (Hx : (0 <= x)%Z), (c_div l x <= c_div u x)%Z.
Proof.
i. unfold c_div.
destruct (Z_eq_dec x 0); [|assert (0 < x)%Z as Hx'; [omega|]]; subst.
- do 4 rewrite Zdiv_0_r; s.
  destruct (Z_ge_dec l 0); destruct (Z_ge_dec u 0); by auto.
- destruct (Z_ge_dec l 0).
  + destruct (Z_ge_dec u 0); [|omega].
    apply Z_div_le; omega.
  + destruct (Z_ge_dec u 0).
    * apply Z.le_trans with 0%Z.
      { apply Z.opp_le_mono; rewrite Z.opp_involutive; s.
        apply Z_div_pos; omega. }
      { apply Z_div_pos; omega. }
    * apply Z.opp_le_mono. do 2 rewrite Z.opp_involutive.
      apply Z_div_le; omega.
Qed.

Lemma list_fold_mor T (t_eq : T -> T -> Prop) U :
  Proper
    ((@Logic.eq U ==> t_eq ==> t_eq) ==> @Logic.eq (list U) ==> t_eq ==> t_eq)
    list_fold.
Proof.
intros f1 f2 Hf l1 l2 Hl i1 i2 Hi; unfold list_fold; subst.
generalize i1 i2 Hi.
induction l2.
- by auto.
- simpl List.fold_left; i; apply IHl2.
  by apply Hf.
Qed.

Lemma list_fold_mor2 T (t_eq : T -> T -> Prop) U (u_eq : U -> U -> Prop) :
  Proper
    ((u_eq ==> t_eq ==> t_eq) ==> SetoidList.eqlistA u_eq ==> t_eq ==> t_eq)
    list_fold.
Proof.
intros f1 f2 Hf l1 l2 Hl i1 i2 Hi; unfold list_fold; subst.
generalize i1 i2 Hi; clear i1 i2 Hi.
induction Hl.
- i; by s.
- simpl List.fold_left; i. apply IHHl.
  by apply Hf.
Qed.

Lemma list_map_mor T U (t_eq : T -> T -> Prop) (u_eq : U -> U -> Prop) :
  Proper
    ((t_eq ==> u_eq) ==> SetoidList.eqlistA t_eq ==> SetoidList.eqlistA u_eq)
    (@List.map T U).
Proof.
intros f1 f2 Hf l1 l2 Hl.
induction Hl.
- s. by constructor.
- s. constructor; [by apply Hf|by auto].
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand &  Vincent Rahli & Mark Bickford

*)

Require Import sequents_tacs.
Require Import subst_tacs.
Require Import cequiv_tacs.
Require Import tactics2.
Require Import sequents_equality.
Require Import sequents_tacs2.
Require Import per_props.
Require Import lsubst_hyps.

Lemma tequality_image {p} :
  forall lib (A1 A2 F1 F2 : @CTerm p),
    tequality lib
              (mkc_image A1 F1)
              (mkc_image A2 F2)
    <=>
    (tequality lib A1 A2
     # equality lib F1 F2 mkc_base
    ).
Proof.
  intros.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold tequality, nuprl in teq; exrepnd.
    inversion teq0; subst; try not_univ.
    allunfold_per.
    computes_to_value_isvalue.
    unfold tequality; sp.
    + exists eqa; sp.
    + apply equality_in_base_iff; spcast; auto.

  - Case "<-".
    introv e; exrepnd.
    rename e0 into teqa; rename e into teqb.
    unfold tequality in teqa; exrepnd.
    rename eq into eqa.
    exists (per_image_eq lib eqa F1).
    apply CL_image; fold (@nuprl p lib).
    unfold per_image.
    exists eqa A1 A2 F1 F2; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_image))).
    apply equality_in_base in teqb; spcast; auto.
Qed.

Lemma equality_image {p} :
  forall lib (A1 A2 F1 F2 : @CTerm p) i,
    equality lib (mkc_image A1 F1)
             (mkc_image A2 F2)
             (mkc_uni i)
    <=>
    (equality lib A1 A2 (mkc_uni i)
     #  equality lib F1 F2 mkc_base).
Proof.
  introv.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold equality, nuprl in teq; exrepnd.
    inversion teq1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    rename eqa into eqi.
    ioneclose; subst; try not_univ.

    destruct H as [eqa H]; exrepnd.
    computes_to_value_isvalue; GC.
    dands.

    exists eq; sp.
    allrw.
    exists eqa; sp.
    apply equality_in_base_iff; spcast; auto.

  - Case "<-".
    intro eqs.
    destruct eqs as [eqa eqb].
    unfold equality in eqa; exrepnd.
    inversion eqa1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    allfold (@nuprli p lib j0).

    exists eq; sp.
    allrw.

    exists (per_image_eq lib eqa F1).
    unfold nuprli.
    apply CL_image; fold (@nuprli p lib j0).
    unfold per_image.
    exists eqa.

    exists A1 A2 F1 F2; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_image))).
    apply equality_in_base_iff; auto.
Qed.

(**

<<
   H, x : Image (A,f), J |- C ext e

     By imageElimination w

     H, [w:A],  J[f w\x] |- C[f w\x] ext e
>>

 *)

Definition rule_image_elimination {p}
           (A f C e : NTerm)
           (x w : NVar)
           (H J : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_image A f)) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        ((snoc H (mk_hhyp w A))
           ++ (lsubst_hyps [(x, mk_apply f (mk_var w))] J))
        (mk_concl (lsubst  C [(x, mk_apply f (mk_var w))] ) e)
    ]
    [].

(* Lemma hyps_functionality_app {o} :
   forall lib,
   forall s1 s2 : @CSub o,
   forall H1 H2 : @bhyps o,
      (length s1 = length H1) ->
      (hyps_functionality lib (s1 ++ s2) (H1 ++ H2) <=>
        (hyps_functionality lib s1 H1 # hyps_functionality lib s2 H2)).
Proof.
   intro. intro.  remember (length s1). revert Heqn. induction n; intro; intro; induction H1; introv leneq; inversion leneq.
   simpl. split; intros; dands; repnd; auto.

   simpl. *)

Hint Rewrite @nh_vars_hyps_app : core.
Hint Rewrite @nh_vars_hyps_snoc : core.

Lemma rule_image_elimination_true {p} :
  forall lib,
  forall A f C e : NTerm,
  forall x w : NVar,
  forall H J: @barehypotheses p,
    rule_true lib
         (rule_image_elimination
                 A f C e x w H J).
Proof.
   unfold rule_image_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
    (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.
  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_image A f)) ++ J))) as ce2.
  - clear hyp1.
    autorewrite with core in *. allsimpl.
    apply covered_snoc_app_weak.
    auto.
  - exists ce2.

 (* we now start proving the sequent *)
  vr_seq_true.
  rw  @similarity_app in sim; exrepnd.
  rw @similarity_snoc in sim5; exrepnd.
  allsimpl.
  lsubst_tac.
  dup sim5 as eqimg.
  apply equality_in_mkc_image in sim5.
  destruct sim5 as [tA imeq].
  apply equal_in_image_prop in imeq.
  exrepnd.
   subst.
  vr_seq_true  in hyp1.

  pose proof (hyp1 (snoc s1a0 (w, a1) ++ s1b) (snoc s2a0 (w, a1) ++ s2b)) as hh.
  clear hyp1.
  dimp hh.
  + (*  hyp functionality *)
     clear hh.
     introv sim.
     apply similarity_app in sim; exrepnd; subst.
     apply similarity_snoc in sim9; exrepnd; subst.
     spcast.
     autorewrite with core in *.
     allrw @length_snoc; cpx.
     apply app_split in sim0; allrw @length_snoc; cpx; try omega.
     repnd; subst.
     apply snoc_inj in sim5.
     repnd; ginv; subst.
     pose proof (eqh (snoc s2a1 (x, t2) ++ s2b0)) as eqhh.
     autodimp eqhh xx.
     * apply similarity_app.
       eexists; eexists; eexists; eexists; dands; eauto;
       try (allrw length_snoc; omega).
       apply similarity_snoc; simpl.
        eexists; eexists;eexists; eexists. exists w0 p0; dands; eauto.
       lsubst_tac; auto.

     assert (forall J,
             forall a b : hypothesis,
             !LIn w (dom_csub s1a1) ->
             !LIn w (free_vars f) ->
             !LIn w (hyps_free_vars J) ->
             !LIn x (dom_csub s1a1) ->
             (LIn (a,b)
                (combine (substitute_hyps (snoc s1a1 (w, t0))
                          (lsubst_hyps [(x, mk_apply f (mk_var w))] J))
                         (substitute_hyps (snoc s1a1 (x, t1)) J))) ->
                 (cequiv lib (htyp a) (htyp b))).
       { induction J0; introv wns1a1 wnf wnJ xfresh I; simpl in I. destruct I. repndors.
        - destruct a; ginv; simpl.
          eapply cequiv_rw_l_eauto; [apply alpha_eq_sym; apply combine_sub_nest | ].
          unfold lsubst_sub; allsimpl.
          pose proof @lsubst_cequiv_congr.

(* UNIFINISHED *)

Abort.

(* [17] ============ IMAGE EQUALITY ============ *)

  (*
   H |-image(A1,f1) = image(A2,f2) in Type

     By imageEquality ()

     H |- f1 = f2 in Base
     H |- A1 = A2 in Type
 *)
Definition rule_image_equality {p}
           (A1 A2 f1 f2 : NTerm)
           (i : nat)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_image A1 f1)
                      (mk_image A2 f2)
                      (mk_uni i))))
    [ mk_baresequent H (mk_conclax (mk_equality f1 f2 mk_base)),
      mk_baresequent H (mk_conclax (mk_equality A1 A2 (mk_uni i)))
    ]
    [].

(* [17] ============ IMAGE MEMBER EQUALITY ============ *)

  (*
   H |-f a1 = f a2 in image(A,f)

     By imageMemberEquality ()

     H |- a1 = a2 in A
     H |- f = f in Base
 *)
Definition rule_image_member_equality {p}
           (A f a1 a2 : NTerm)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_apply f a1)
                      (mk_apply f a2)
                      (mk_image A f)
                      )))
    [ mk_baresequent H (mk_conclax (mk_equality a1 a2 A)),
      mk_baresequent H (mk_conclax (mk_equality f f mk_base))
    ]
    [].

Lemma rule_image_member_equality_true {p} :
  forall lib,
  forall A f a1 a2 : NTerm,
  forall H : @barehypotheses p,
    rule_true lib
         (rule_image_member_equality
                 A f a1 a2 H).
Proof.
   unfold rule_image_member_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
    (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom p (nh_vars_hyps H)).
   (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply tequality_mkc_equality_implies in h0.
  apply tequality_mkc_equality_implies in h2.
  repnd.
  generalize (teq_and_eq_if_equality lib (mk_image A f) (mk_apply f a1) (mk_apply f a2) s1 s2 H
              wT w1 w2 c1 c4 c2 c6 cT cT0 eqh sim
              ); intro k; lsubst_tac; apply k; clear k; auto.

  - apply tequality_image; dands; auto; destruct h2 as [xx | yy]; auto.
    spcast. apply equality_respects_cequivc; auto.
  - clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply tequality_mkc_equality_implies in hyp3.
  repnd.
  assert ((lsubstc f w0 s1 c1) ~=~( lib)(lsubstc f w0 s2 c0)) by
  ( destruct hyp3 as [xx | yy];
  try (apply equality_in_base in xx); auto).
  spcast.
  generalize_lsubstc_terms f1.
  generalize_lsubstc_terms a11.
  generalize_lsubstc_terms f2.
  generalize_lsubstc_terms a22.
  generalize_lsubstc_terms A1.
  revert hyp1.
  generalize_lsubstc_terms a21.
  revert hyp0.
  generalize_lsubstc_terms a12.
  generalize_lsubstc_terms A2.
  introv teq eq.
  apply tequality_mkc_equality_implies in teq.
  repnd.
  dimp teq1.
  assert (equality lib a11 a22  A1) as eq2.
  + eapply equality_trans with (t2 := a12).
    { destruct teq; auto; spcast. apply equality_respects_cequivc; auto. eapply equality_refl. eauto. }
    { eapply tequality_preserving_equality; [exact hyp |apply tequality_sym;auto ]. }
  +  apply equality_in_mkc_image; dands.
  * eapply tequality_refl; eauto.
  * eapply eq_in_image_eq; [exact eq2 | spcast | spcast]; eauto 3 with slow.
    apply implies_cequivc_apply; auto; apply cequivc_sym; auto.
Qed.

Lemma rule_image_equality_true {p} :
  forall lib,
  forall A1 A2 f1 f2 : NTerm,
  forall i : nat,
  forall H : @barehypotheses p,
    rule_true lib
         (rule_image_equality
                 A1 A2 f1 f2
                 i
                 H).
Proof.
  unfold rule_image_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  inversion wg as [ wfh wfc ]; allsimpl.
  inversion wfc as [ wtt wte ]; allsimpl; clear wfc.
  generalize (hyps (mk_baresequent H (mk_conclax (mk_equality f1 f2 mk_base)))
                   (inl eq_refl))
             (hyps (mk_baresequent H (mk_conclax (mk_equality A1 A2 (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destruct ws1 as [ ws1 ws1' ]; allsimpl.
  destruct ws2 as [ ws2 ws2' ]; allsimpl.
  destruct ws1 as [ wh1 wc1 ]; allsimpl.
  destruct ws2 as [ wh2 wc2 ]; allsimpl.
  destruct ws1' as [ ct1 ce1 ]; allsimpl.
  destruct ws2' as [ ct2 ce2 ]; allsimpl.
  allunfold @closed_type; allsimpl.
  allunfold @closed_extract; allsimpl;
  GC.

  allunfold @closed_type; allunfold @closed_extract; allunfold @nh_vars_hyps; allsimpl.

  assert (covered (@mk_axiom p) (vars_hyps (filter is_nh H))) as ce by prove_seq.
  exists ce.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  allrw @sequent_true_eq_VR.
  rw @VR_sequent_true_all; simpl; introv sim eqh.
  intros.
  lsubst_tac.
  assert ( tequality lib (mkc_uni i) (mkc_uni i)) as Z by
   (apply tequality_mkc_uni).
  assert (wf_term (mk_image A1 f1)) as wfa by (apply wf_image; auto).
  assert (wf_term (mk_image A2 f2)) as wfb by (apply wf_image; auto).

  pose proof (teq_and_eq_if_equality lib (@mk_uni p i) (mk_image A1 f1) (mk_image A2 f2)
              s1 s2 H wT wfa wfb c1 c0 c2 c3 cT cT0 eqh sim) as X.
  lsubst_tac.
  allrw @member_eq;
  allrw <- @member_equality_iff.
  apply X; auto.
  introv hfun ss.
  lsubst_tac.
  clear dependent s1.
  clear dependent s2.
  rename s0 into s1.
  rename s3 into s2.
  apply equality_image.
  rw @VR_sequent_true_ex in hyp1; rw @VR_sequent_true_ex in hyp2. allsimpl.
  generalize (hyp1 s1 s2) (hyp2 s1 s2); clear hyp1 hyp2; intros hyp1 hyp2.
  repeat (dest_imp hyp1 h); repeat (dest_imp hyp2 h); exrepnd.
  lsubst_tac.
  allrw @member_eq;
  allrw <- @member_equality_iff.
  rw @tequality_mkc_equality in hyp0; rw @tequality_mkc_equality in hyp3; repnd.
  dands; auto.
  - generalize_lsubstc_terms A11.
    generalize_lsubstc_terms A22.
    revert hyp0. generalize_lsubstc_terms A21.
    revert hyp9. generalize_lsubstc_terms A12.
    introv aa.
    assert (equality lib A11 A12 (mkc_uni i)) as eq1 by
      ( destruct aa; auto;
        spcast; apply equality_respects_cequivc; auto;
         eapply equality_refl; eauto).
    assert (equality lib A21 A11 (mkc_uni i)) by
      (apply equality_sym; auto).
    introv bb.
    assert (equality lib A21 A22 (mkc_uni i)) as eq2 by
      (destruct bb; auto;
        spcast; apply equality_respects_cequivc; auto;
         eapply equality_refl; eauto).
    eapply equality_trans; [exact hyp2 | auto].

  - allrw @equality_in_base_iff.
    revert hyp3. revert hyp6.
    generalize_lsubstc_terms f11.
    generalize_lsubstc_terms f12.
    generalize_lsubstc_terms f21.
    generalize_lsubstc_terms f22.
    introv aa.
    assert ((f11) ~=~( lib)(f12)) as e1 by
     (destruct aa; auto; apply equality_in_base in H0; auto).
    introv bb.
    assert ((f21) ~=~( lib)(f22)) as e2 by
     (destruct bb; auto; apply equality_in_base in H0; auto).
    spcast.
    eapply cequivc_trans; [exact hyp1| auto].
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


From iris.base_logic Require Import base_logic.
Set Default Proof Using "Type".

(* In this file we show that the bupd can be thought of a kind of
   step-indexed double-negation when our meta-logic is classical *)
Definition uPred_nnupd {M} (P: uPred M) : uPred M :=
  ∀ n, (P -∗ ▷^n False) -∗ ▷^n False.

Notation "|=n=> Q" := (uPred_nnupd Q)
  (at level 99, Q at level 200, format "|=n=>  Q") : uPred_scope.
Notation "P =n=> Q" := (P ⊢ |=n=> Q)
  (at level 99, Q at level 200, only parsing) : stdpp_scope.
Notation "P =n=∗ Q" := (P -∗ |=n=> Q)%I
  (at level 99, Q at level 200, format "P  =n=∗  Q") : uPred_scope.

(* Our goal is to prove that:
  (1) |=n=> has (nearly) all the properties of the |==> modality that are used in Iris
  (2) If our meta-logic is classical, then |=n=> and |==> are equivalent
*)

Section bupd_nnupd.
Context {M : ucmraT}.
Implicit Types φ : Prop.
Implicit Types P Q : uPred M.
Implicit Types A : Type.
Implicit Types x : M.
Import uPred.

(* Helper lemmas about iterated later modalities *)
Lemma laterN_big n a x φ: ✓{n} x →  a ≤ n → (▷^a ⌜φ⌝)%I n x → φ.
Proof.
  induction 2 as [| ?? IHle].
  - induction a; repeat (rewrite //= || uPred.unseal).
    intros Hlater. apply IHa; auto using cmra_validN_S.
    move:Hlater; repeat (rewrite //= || uPred.unseal).
  - intros. apply IHle; auto using cmra_validN_S.
    eapply uPred_mono; eauto using cmra_validN_S.
Qed.

Lemma laterN_small n a x φ: ✓{n} x →  n < a → (▷^a ⌜φ⌝)%I n x.
Proof.
  induction 2.
  - induction n as [| n IHn]; [| move: IHn];
      repeat (rewrite //= || uPred.unseal).
    naive_solver eauto using cmra_validN_S.
  - induction n as [| n IHn]; [| move: IHle];
      repeat (rewrite //= || uPred.unseal).
    red; rewrite //=. intros.
    eapply (uPred_mono _ _ (S n)); eauto using cmra_validN_S.
Qed.

(* It is easy to show that most of the basic properties of bupd that
   are used throughout Iris hold for nnupd.

   In fact, the first three properties that follow hold for any
   modality of the form (- -∗ Q) -∗ Q for arbitrary Q. The situation
   here is slightly different, because nnupd is of the form
   ∀ n, (- -∗ (Q n)) -∗ (Q n), but the proofs carry over straightforwardly.

 *)

Lemma nnupd_intro P : P =n=> P.
Proof. apply forall_intro=>?. apply wand_intro_l, wand_elim_l. Qed.
Lemma nnupd_mono P Q : (P ⊢ Q) → (|=n=> P) =n=> Q.
Proof.
  intros HPQ. apply forall_intro=>n.
  apply wand_intro_l.  rewrite -{1}HPQ.
  rewrite /uPred_nnupd (forall_elim n).
  apply wand_elim_r.
Qed.
Lemma nnupd_frame_r P R : (|=n=> P) ∗ R =n=> P ∗ R.
Proof.
  apply forall_intro=>n. apply wand_intro_r.
  rewrite (comm _ P) -wand_curry.
  rewrite /uPred_nnupd (forall_elim n).
  by rewrite -assoc wand_elim_r wand_elim_l.
Qed.
Lemma nnupd_ownM_updateP x (Φ : M → Prop) :
  x ~~>: Φ → uPred_ownM x =n=> ∃ y, ⌜Φ y⌝ ∧ uPred_ownM y.
Proof.
  intros Hbupd. split. rewrite /uPred_nnupd. repeat uPred.unseal.
  intros n y ? Hown a.
  red; rewrite //= => n' yf ??.
  inversion Hown as (x'&Hequiv).
  edestruct (Hbupd n' (Some (x' ⋅ yf))) as (y'&?&?); eauto.
  { by rewrite //= assoc -(dist_le _ _ _ _ Hequiv). }
  case (decide (a ≤ n')).
  - intros Hle Hwand.
    exfalso. eapply laterN_big; last (uPred.unseal; eapply (Hwand n' (y' ⋅ x'))); eauto.
    * rewrite comm -assoc. done.
    * rewrite comm -assoc. done.
    * exists y'. split=>//. by exists x'.
 - intros; assert (n' < a). omega.
    move: laterN_small. uPred.unseal.
    naive_solver.
Qed.

(* However, the transitivity property seems to be much harder to
   prove. This is surprising, because transitivity does hold for
   modalities of the form (- -∗ Q) -∗ Q. What goes wrong when we quantify
   now over n?
 *)

Remark nnupd_trans P: (|=n=> |=n=> P) ⊢ (|=n=> P).
Proof.
  rewrite /uPred_nnupd.
  apply forall_intro=>a. apply wand_intro_l.
  rewrite (forall_elim a).
  rewrite (nnupd_intro (P -∗ _)).
  rewrite /uPred_nnupd.
  (* Oops -- the exponents of the later modality don't match up! *)
Abort.

(* Instead, we will need to prove this in the model. We start by showing that
   nnupd is the limit of a the following sequence:

   (- -∗ False) - ∗ False,
   (- -∗ ▷ False) - ∗ ▷ False ∧ (- -∗ False) - ∗ False,
   (- -∗ ▷^2 False) - ∗ ▷^2 False ∧ (- -∗ ▷ False) - ∗ ▷ False ∧ (- -∗ False) - ∗ False,
   ...

   Then, it is easy enough to show that each of the uPreds in this sequence
   is transitive. It turns out that this implies that nnupd is transitive. *)

(* The definition of the sequence above: *)
Fixpoint uPred_nnupd_k {M} k (P: uPred M) : uPred M :=
  ((P -∗ ▷^k False) -∗ ▷^k False) ∧
  match k with
    O => True
  | S k' => uPred_nnupd_k k' P
  end.

Notation "|=n=>_ k Q" := (uPred_nnupd_k k Q)
  (at level 99, k at level 9, Q at level 200, format "|=n=>_ k  Q") : uPred_scope.

(* One direction of the limiting process is easy -- nnupd implies nnupd_k for each k *)
Lemma nnupd_trunc1 k P: (|=n=> P) ⊢ |=n=>_k P.
Proof.
  induction k.
  - rewrite /uPred_nnupd_k /uPred_nnupd.
    rewrite (forall_elim 0) //= right_id //.
  - simpl. apply and_intro; auto.
    rewrite /uPred_nnupd.
    rewrite (forall_elim (S k)) //=.
Qed.

Lemma nnupd_k_elim n k P: n ≤ k → ((|=n=>_k P) ∗ (P -∗ (▷^n False)) ⊢  (▷^n False))%I.
Proof.
  induction k.
  - inversion 1; subst; rewrite //= ?right_id. apply wand_elim_l.
  - inversion 1; subst; rewrite //= ?right_id.
    * rewrite and_elim_l. apply wand_elim_l.
    * rewrite and_elim_r IHk //.
Qed.

Lemma nnupd_k_unfold k P:
  (|=n=>_(S k) P) ⊣⊢ ((P -∗ (▷^(S k) False)) -∗ (▷^(S k) False)) ∧ (|=n=>_k P).
Proof. done.  Qed.
Lemma nnupd_k_unfold' k P n x:
  (|=n=>_(S k) P)%I n x ↔ (((P -∗ (▷^(S k) False)) -∗ (▷^(S k) False)) ∧ (|=n=>_k P))%I n x.
Proof. done.  Qed.

Lemma nnupd_k_weaken k P: (|=n=>_(S k) P) ⊢ |=n=>_k P.
Proof. by rewrite nnupd_k_unfold and_elim_r. Qed.

(* Now we are ready to show nnupd is the limit -- ie, for each k, it is within distance k
   of the kth term of the sequence *)
Lemma nnupd_nnupd_k_dist k P: (|=n=> P)%I ≡{k}≡ (|=n=>_k P)%I.
  split; intros n' x Hle Hx. split.
  - by apply (nnupd_trunc1 k).
  - revert n' x Hle Hx; induction k; intros n' x Hle Hx;
      rewrite ?nnupd_k_unfold' /uPred_nnupd.
    * rewrite //=. unseal.
      inversion Hle; subst.
      intros (HnnP&_) n k' x' ?? HPF.
      case (decide (k' < n)).
      ** move: laterN_small; uPred.unseal; naive_solver.
      ** intros. exfalso. eapply HnnP; eauto.
         assert (n ≤ k'). omega.
         intros n'' x'' ???.
         specialize (HPF n'' x''). exfalso.
         eapply laterN_big; last (unseal; eauto).
         eauto. omega.
    * inversion Hle; subst.
      ** unseal. intros (HnnP&HnnP_IH) n k' x' ?? HPF.
         case (decide (k' < n)).
         *** move: laterN_small; uPred.unseal; naive_solver.
         *** intros. exfalso. assert (n ≤ k'). omega.
             assert (n = S k ∨ n < S k) as [->|] by omega.
             **** eapply laterN_big; eauto; unseal. eapply HnnP; eauto.
             **** move:nnupd_k_elim. unseal. intros Hnnupdk.
                  eapply laterN_big; eauto. unseal.
                  eapply (Hnnupdk n k); first omega; eauto.
                  exists x, x'. split_and!; eauto. eapply uPred_mono; eauto.
      ** intros HP. eapply IHk; auto.
         move:HP. unseal. intros (?&?); naive_solver.
Qed.

(* nnupd_k has a number of structural properties, including transitivity *)
Lemma nnupd_k_intro k P: P ⊢ (|=n=>_k P).
Proof.
  induction k; rewrite //= ?right_id.
  - apply wand_intro_l. apply wand_elim_l.
  - apply and_intro; auto.
    apply wand_intro_l. apply wand_elim_l.
Qed.

Lemma nnupd_k_mono k P Q: (P ⊢ Q) → (|=n=>_k P) ⊢ (|=n=>_k Q).
Proof.
  induction k; rewrite //= ?right_id=>HPQ.
  - do 2 (apply wand_mono; auto).
  - apply and_mono; auto; do 2 (apply wand_mono; auto).
Qed.
Instance nnupd_k_mono' k: Proper ((⊢) ==> (⊢)) (@uPred_nnupd_k M k).
Proof. by intros P P' HP; apply nnupd_k_mono. Qed.

Instance nnupd_k_ne k : NonExpansive (@uPred_nnupd_k M k).
Proof. intros n. induction k; rewrite //= ?right_id=>P P' HP; by rewrite HP. Qed.
Lemma nnupd_k_proper k P Q: (P ⊣⊢ Q) → (|=n=>_k P) ⊣⊢ (|=n=>_k Q).
Proof. intros HP; apply (anti_symm (⊢)); eapply nnupd_k_mono; by rewrite HP. Qed.
Instance nnupd_k_proper' k: Proper ((⊣⊢) ==> (⊣⊢)) (@uPred_nnupd_k M k).
Proof. by intros P P' HP; apply nnupd_k_proper. Qed.

Lemma nnupd_k_trans k P: (|=n=>_k |=n=>_k P) ⊢ (|=n=>_k P).
Proof.
  revert P.
  induction k; intros P.
  - rewrite //= ?right_id. apply wand_intro_l.
    rewrite {1}(nnupd_k_intro 0 (P -∗ False)%I) //= ?right_id. apply wand_elim_r.
  - rewrite {2}(nnupd_k_unfold k P).
    apply and_intro.
    * rewrite (nnupd_k_unfold k P). rewrite and_elim_l.
      rewrite nnupd_k_unfold. rewrite and_elim_l.
      apply wand_intro_l.
      rewrite {1}(nnupd_k_intro (S k) (P -∗ ▷^(S k) (False)%I)).
      rewrite nnupd_k_unfold and_elim_l. apply wand_elim_r.
    * do 2 rewrite nnupd_k_weaken //.
Qed.

Lemma nnupd_trans P : (|=n=> |=n=> P) =n=> P.
Proof.
  split=> n x ? Hnn.
  eapply nnupd_nnupd_k_dist in Hnn; eauto.
  eapply (nnupd_k_ne (n) n ((|=n=>_(n) P)%I)) in Hnn; eauto;
    [| symmetry; eapply nnupd_nnupd_k_dist].
  eapply nnupd_nnupd_k_dist; eauto.
  by apply nnupd_k_trans.
Qed.

(* Now that we have shown nnupd has all of the desired properties of
   bupd, we go further and show it is in fact equivalent to bupd! The
   direction from bupd to nnupd is similar to the proof of
   nnupd_ownM_updateP *)

Lemma bupd_nnupd P: (|==> P) ⊢ |=n=> P.
Proof.
  split. rewrite /uPred_nnupd. repeat uPred.unseal. intros n x ? Hbupd a.
  red; rewrite //= => n' yf ??.
  edestruct Hbupd as (x'&?&?); eauto.
  case (decide (a ≤ n')).
  - intros Hle Hwand.
    exfalso. eapply laterN_big; last (uPred.unseal; eapply (Hwand n' x')); eauto.
    * rewrite comm. done.
    * rewrite comm. done.
  - intros; assert (n' < a). omega.
    move: laterN_small. uPred.unseal.
    naive_solver.
Qed.

(* However, the other direction seems to need a classical axiom: *)
Section classical.
Context (not_all_not_ex: ∀ (P : M → Prop), ¬ (∀ n : M, ¬ P n) → ∃ n : M, P n).
Lemma nnupd_bupd P:  (|=n=> P) ⊢ (|==> P).
Proof using Type*.
  rewrite /uPred_nnupd.
  split. uPred.unseal; red; rewrite //=.
  intros n x ? Hforall k yf Hle ?.
  apply not_all_not_ex.
  intros Hfal.
  specialize (Hforall k k).
  eapply laterN_big; last (uPred.unseal; red; rewrite //=; eapply Hforall);
    eauto.
  red; rewrite //= => n' x' ???.
  case (decide (n' = k)); intros.
  - subst. exfalso. eapply Hfal. rewrite (comm op); eauto.
  - assert (n' < k). omega.
    move: laterN_small. uPred.unseal. naive_solver.
Qed.
End classical.

(* We might wonder whether we can prove an adequacy lemma for nnupd. We could combine
   the adequacy lemma for bupd with the previous result to get adquacy for nnupd, but
   this would rely on the classical axiom we needed to prove the equivalence! Can
   we establish adequacy without axioms? Unfortunately not, because adequacy for
   nnupd would imply double negation elimination, which is classical: *)

Lemma nnupd_dne φ: (|=n=> ⌜¬¬ φ → φ⌝: uPred M)%I.
Proof.
  rewrite /uPred_nnupd. apply forall_intro=>n.
  apply wand_intro_l. rewrite ?right_id.
  assert (∀ φ, ¬¬¬¬φ → ¬¬φ) by naive_solver.
  assert (Hdne: ¬¬ (¬¬φ → φ)) by naive_solver.
  split. unseal. intros n' ?? Hupd.
  case (decide (n' < n)).
  - intros. move: laterN_small. unseal. naive_solver.
  - intros. assert (n ≤ n'). omega.
    exfalso. specialize (Hupd n' ε).
    eapply Hdne. intros Hfal.
    eapply laterN_big; eauto.
    unseal. rewrite right_id in Hupd *; naive_solver.
Qed.

(* Nevertheless, we can prove a weaker form of adequacy (which is equvialent to adequacy
   under classical axioms) directly without passing through the proofs for bupd: *)
Lemma adequacy_helper1 P n k x:
  ✓{S n + k} x → ¬¬ (Nat.iter (S n) (λ P, |=n=> ▷ P)%I P (S n + k) x)
            → ¬¬ (∃ x', ✓{n + k} (x') ∧ Nat.iter n (λ P, |=n=> ▷ P)%I P (n + k) (x')).
Proof.
  revert k P x. induction n.
  - rewrite /uPred_nnupd. unseal=> k P x Hx Hf1 Hf2.
    eapply Hf1. intros Hf3.
    eapply (laterN_big (S k) (S k)); eauto.
    specialize (Hf3 (S k) (S k) ε). rewrite right_id in Hf3 *. unseal.
    intros Hf3. eapply Hf3; eauto.
    intros ??? Hx'. rewrite left_id in Hx' *=> Hx'.
    unseal.
    assert (n' < S k ∨ n' = S k) as [|] by omega.
    * intros. move:(laterN_small n' (S k) x' False). rewrite //=. unseal. intros Hsmall.
      eapply Hsmall; eauto.
    * subst. intros. exfalso. eapply Hf2. exists x'. split; eauto using cmra_validN_S.
  - intros k P x Hx. rewrite ?Nat_iter_S_r.
    replace (S (S n) + k) with (S n + (S k)) by omega.
    replace (S n + k) with (n + (S k)) by omega.
    intros. eapply IHn. replace (S n + S k) with (S (S n) + k) by omega. eauto.
    rewrite ?Nat_iter_S_r. eauto.
Qed.

Lemma adequacy_helper2 P n k x:
  ✓{S n + k} x → ¬¬ (Nat.iter (S n) (λ P, |=n=> ▷ P)%I P (S n + k) x)
            → ¬¬ (∃ x', ✓{k} (x') ∧ Nat.iter 0 (λ P, |=n=> ▷ P)%I P k (x')).
Proof.
  revert x. induction n.
  - specialize (adequacy_helper1 P 0). rewrite //=. naive_solver.
  - intros ?? Hfal%adequacy_helper1; eauto using cmra_validN_S.
    intros Hfal'. eapply Hfal. intros (x''&?&?).
    eapply IHn; eauto.
Qed.

Lemma adequacy φ n : Nat.iter n (λ P, |=n=> ▷ P)%I ⌜φ⌝%I → ¬¬ φ.
Proof.
  cut (∀ x, ✓{S n} x → Nat.iter n (λ P, |=n=> ▷ P)%I ⌜φ⌝%I (S n) x → ¬¬φ).
  { intros help H. eapply (help ∅); eauto using ucmra_unit_validN.
    eapply H; try unseal; eauto using ucmra_unit_validN. red; rewrite //=. }
  destruct n.
  - rewrite //=; unseal; auto.
  - intros ??? Hfal.
    eapply (adequacy_helper2 _ n 1); (replace (S n + 1) with (S (S n)) by omega); eauto.
    unseal. intros (x'&?&Hphi). simpl in *.
    eapply Hfal. auto.
Qed.

(* Open question:

   Do the basic properties of the |==> modality (bupd_intro, bupd_mono, rvs_trans, rvs_frame_r,
      bupd_ownM_updateP, and adequacy) uniquely characterize |==>?
*)

End bupd_nnupd.