Require Import Iron.Language.SystemF2Effect.Base.

(********************************************************************)
(* Store Property *)
Inductive stprop :=
 (* A region descriptor.
    One of these exists in the store for every live region in the store. *)
 | SRegion : nat -> stprop.

(* Store Properties *)
Definition stprops
 := list stprop.

(********************************************************************)
(* Take a region back from a store property *)
Fixpoint regionOfStProp (s : stprop) : option nat :=
 match s with
 | SRegion p      => Some p
 end.

(* Check if this is a store property with the given
   region identifier. *)
Definition isSRegion (p : nat) (pp : stprop) : bool :=
 match pp with
 | SRegion p' => beq_nat p p'
 end.

(* Check if any of the given store properties include this
   region identifier *)
Definition hasSRegion (p : nat) (sp : stprops)
 := elem (isSRegion p) sp.

(********************************************************************)
(* Allocate a fresh region. *)
Definition allocRegion (sp : stprops) : nat
 := S (max_list (catOptions (map regionOfStProp sp))).

Lemma allocRegion_weaken
 :  forall sp s p
 ,  allocRegion sp        >= p
 -> allocRegion (sp :> s) >= p.
Proof.
 intros.
  destruct p.
  omega.
  unfold allocRegion in *.
   snorm.
   have (max_list (catOptions (map regionOfStProp sp)) >= p)
    by omega. clear H.
   cut  (max n (max_list (catOptions (map regionOfStProp sp))) >= p).
    intros. omega.
    apply max_weaken_left.
    auto.
Qed.
Hint Resolve allocRegion_weaken.

(* A freshly allocated region is greater than all regions already
   in the store properties. *)
Lemma allocRegion_above
 : forall sp
 , Forall (fun s => match regionOfStProp s with
                    | Some p => allocRegion sp > p
                    | None   => True
                    end)
          sp.
Proof.
 induction sp; intros.
  snorm.
  snorm.
  inverts H.
   destruct x.
    snorm.
    unfold allocRegion.
     simpl.
     remember (max_list (catOptions (map regionOfStProp sp))) as X.
     cut (max n0 X >= n0).
      intros. omega.
     apply max_ge_left1.
   destruct x.
    snorm.
    spec IHsp H0.
    snorm.
    apply allocRegion_weaken. auto.
Qed.

(* Allocated region is fresh wrt existing store properties. *)
Lemma allocRegion_fresh
 : forall sp
 , not (In (SRegion (allocRegion sp)) sp).
Proof.
 intros.
 unfold not. intros.
 lets D: allocRegion_above sp.
  snorm.
 spec D H.
  snorm. omega.
Qed.
Hint Resolve allocRegion_fresh.

(* Old store properties do not contain allocated region. *)
Lemma allocRegion_fresh_has
 :  forall p sp
 ,  p = allocRegion sp
 -> hasSRegion p sp = false.
Proof.
 intros.
 subst.
  unfold hasSRegion.
  eapply elem_get_not.
  unfold not. intros.
   destruct H as [ix].
   destruct H as [x].
   rip.
   destruct x.
    simpl in H1.
    snorm. symmetry in H1. subst.
    apply get_in in H0.
    have (not (In (SRegion (allocRegion sp)) sp))
     by apply allocRegion_fresh.
    tauto.
Qed.
Hint Resolve allocRegion_fresh_has.


Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Setoids.Setoid
        Coq.Arith.PeanoNat
        Coq.omega.Omega
        Coq.setoid_ring.Ring
        Coq.setoid_ring.Ring_theory
        Matrix
        SparseMatrix
        DenseMatrix
        MyHelpers.

Notation SDM n := (Mt (Matrix := DenseMatrix) n n).
Notation SSM n := (Mt (Matrix := SparseMatrix) n n).
Notation Vt n := (Mt (Matrix := DenseMatrix) n 1).

Global Opaque DenseMatrix.
Global Opaque SparseMatrix.

Section MatrixLemmas.

Context {E: MatrixElem}.

Definition transpose {n m MM} (A : @Mt E MM n m) :=
  @Mfill E MM m n (fun i j => Mget A j i).
Definition MVtimes {n} (M: SDM n) (v: Vt n) := M @* v.
Axiom inversion : forall {n}, SDM n -> SDM n.

Global Add Parametric Morphism n: (MVtimes ) with
      signature (Meq (m:=n)(n:=n)) ==> (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) as MVtimes_mor.
Admitted.

Global Add Parametric Morphism n m MM: (transpose ) with
      signature (Meq (m:=m)(n:=n)(M1:=MM)) ==> (Meq (m:=n)(n:=m)(M1:=MM)) as transpose_mor.
Admitted.

Global Add Parametric Morphism n: (inversion ) with
      signature (Meq (m:=n)(n:=n)) ==> (Meq (m:=n)(n:=n)) as inversion_mor.
Admitted.

Global Add Parametric Morphism m n: (Mget) with
      signature (Meq (m:=m)(n:=n)(ME:=E)(M1:=DenseMatrix)) ==> (eq) ==> (eq) ==> (eq) as mget_mor.
Admitted.

Infix "&*" := MVtimes (at level 40, left associativity) : matrix_scope.
Definition Vplus {n} (v: Vt n) (u: Vt n):= v @+ u.
Infix "&+" := Vplus (at level 50, left associativity) : matrix_scope.

Global Add Parametric Morphism n: (Vplus ) with
      signature (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) as Vplus_mor.
Admitted.

Definition Vminus {n} (v: Vt n) (u: Vt n):= v @- u.
Infix "&-" := Vminus (at level 50, left associativity) : matrix_scope.

Global Add Parametric Morphism n: (Vminus ) with
      signature (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) ==> (Meq (m:=n)(n:=1)) as Vminus_mor.
Admitted.

Definition Id {n} := @I n E DenseMatrix.

Arguments Mtimes : simpl never.

Definition sparsify {n} (A: SDM n) := @Mfill E SparseMatrix n n (fun i j => Mget A i j).
Lemma sparsify_correct: forall n: nat, forall M : SDM n, M @= sparsify M.
Proof.
  intros.
  unfold sparsify.
  unfold "@=".
  intros.
  rewrite Mfill_correct; try assumption.
  reflexivity.
Qed.

(* can be optimized *)
Definition densify {n} (A: SSM n) := @Mfill E DenseMatrix n n (fun i j => Mget A i j).
Lemma densify_correct: forall n: nat, forall M : SSM n, M @= densify M.
Proof.
  intros.
  unfold densify.
  unfold "@=".
  intros.
  rewrite Mfill_correct; try assumption.
  reflexivity.
Qed.
Lemma densify_correct_rev: forall n: nat, forall M : SSM n,  densify M @= M.
Proof.
  intros.
  unfold densify.
  unfold "@=".
  intros.
  rewrite Mfill_correct; try assumption.
  reflexivity.
Qed.

Lemma matrix_eq_commutes :
  forall (m n: nat) ME M1 M2 (m1: @Mt ME M1 m n) (m2: @Mt ME M2 m n),
    m1 @= m2 -> m2 @= m1.
Proof.
  intros.
  unfold "@=" in *.
  intros.
  rewrite H; auto.
Qed.

Axiom solveR: forall {n}, SDM n -> SDM n -> SDM n.
Axiom solveR_correct: forall n: nat, forall M1 M2:SDM n,
  M1 @* (inversion M2) = solveR M2 M1.
Lemma multi_assoc: forall n: nat, forall M1 M2 M3 : SDM n,
      (M1 @* M2) @* M3 @= M1 @* (M2 @* M3).
Proof.
  intros.
  rewrite mult_assoc.
  reflexivity.
Qed.

Axiom Cholesky_DC: forall {n}, SDM n -> SDM n.
Axiom solveR_lower: forall {n}, SDM n -> SDM n -> SDM n.
Axiom solveR_upper: forall {n}, SDM n -> SDM n -> SDM n.
Lemma ABv_assoc: forall n:nat, forall A B: SDM n, forall v : Vt n,
        MVtimes (A @* B) v @=  MVtimes A (MVtimes B v).
Proof.
  intros.
  unfold "&*".
  rewrite mult_assoc.
  reflexivity.
Qed.

Axiom Cholesky_DC_correct: forall n:nat, forall M1 M2 : SDM n,
      solveR M1 M2 = solveR_upper (transpose (Cholesky_DC M1)) (solveR_lower (Cholesky_DC M1) M2).

Axiom Densify_correct: forall n:nat, forall M : SDM n, forall S : SSM n,
        M @= S -> M @= densify S.

Lemma Densify_correct_rev: forall n:nat, forall M : SDM n, forall S : SSM n,
        M @= densify S -> M @= S.
Proof.
  intros.
  unfold densify in H.
  unfold "@=" in *.
  intros.
  rewrite H; auto.
  rewrite Mfill_correct; auto.
Qed.

Axiom dense_sparse_mul: forall {n}, SDM n -> SSM n -> SDM n.
Axiom dense_sparse_mul_correct: forall {n}, forall A: SDM n, forall B: SSM n,
        dense_sparse_mul A B = A @* densify B.
Axiom sparse_dense_mul: forall {n}, SSM n -> SDM n -> SDM n.
Axiom sparse_dense_mul_correct: forall {n}, forall A: SSM n, forall B: SDM n,
        sparse_dense_mul A B = densify A @*  B.
Axiom dense_sparse_mul_to_sparse: forall {n}, SDM n -> SSM n -> SSM n.
Axiom dense_sparse_mul_to_sparse_correct: forall {n}, forall A: SDM n, forall B: SSM n,
        sparsify (dense_sparse_mul A B) = dense_sparse_mul_to_sparse A B.

Lemma if_cond_helper {n m MM} : forall x1:bool, forall A B C D: @Mt E MM n m, A @= B -> C @= D -> (if x1 then A else C) @= (if x1 then B else D).
Proof.
  intros.
  destruct x1; auto.
Qed.

End MatrixLemmas.

Hint Resolve sparsify_correct densify_correct densify_correct_rev matrix_eq_commutes solveR_correct multi_assoc Densify_correct Densify_correct_rev dense_sparse_mul_correct sparse_dense_mul_correct dense_sparse_mul_to_sparse_correct eq_Mt_refl: matrices.

Infix "&*" := MVtimes (at level 40, left associativity) : matrix_scope.
Infix "&+" := Vplus (at level 50, left associativity) : matrix_scope.
Infix "&-" := Vminus (at level 50, left associativity) : matrix_scope.


(**
  [TypeTheory.CwF_TypeCat.CwF_Cats]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module defines an isomorphism of categories for slightly
different definitions of CwF structures.
Since the difference is merely how components of objects and morphisms
are "packed" the proof boils down to a simple repackaging.

See [weq_cwf'_cwf_structure] for the "repackaging" of objects
and [weq_cwf'_to_cwf_structure_mor] for morphisms.

Main definitions are

- [cwf'_to_cwf_functor], [cwf'_to_cwf_is_catiso] — isomorphism of categories of [cwf_structure] and [cwf'_structure] (composed of [obj_ext_structure] and [term_fun_structure])
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.
Require Import TypeTheory.Auxiliary.TypeOfMorphisms.

Require Import TypeTheory.CwF.CwF_def.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Defs.

Require Import TypeTheory.CwF.CwF_Cats.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Cats.
Require Import UniMath.CategoryTheory.catiso.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences.

Section CwF_Cat_Equiv.

  Context (C : category).

  Definition cwf_to_cwf'_structure : cwf_structure C → cwf'_structure C.
  Proof.
    intros [[[Ty Tm] p] ΓAπ_te_axiom_isPullback].
    set (ΓAπ      := λ Γ A, pr1 (ΓAπ_te_axiom_isPullback Γ A)).
    set (te       := λ Γ A, pr1 (pr1 (pr2 (ΓAπ_te_axiom_isPullback Γ A)))).
    set (te_axiom := λ Γ A, pr2 (pr1 (pr2 (ΓAπ_te_axiom_isPullback Γ A)))).
    set (pullback := λ Γ A, pr2 (pr2 (ΓAπ_te_axiom_isPullback Γ A))).
    set (axioms   := λ Γ A, (te_axiom Γ A, pullback Γ A)).
    exact ((Ty ,, ΓAπ) ,, ((Tm ,, p ,, te) ,, axioms)).
  Defined.

  Definition cwf'_to_cwf_structure : cwf'_structure C → cwf_structure C.
  Proof.
    intros [[Ty ΓAπ] [[Tm [p te]] axioms]].
    set (te_axiom := λ Γ A, pr1 (axioms Γ A)).
    set (pullback := λ Γ A, pr2 (axioms Γ A)).

    set (pp := ((Ty ,, Tm) ,, p) : mor_total (preShv C)).
    set (r := (λ Γ A,
               (ΓAπ Γ A ,, (te Γ A ,, te_axiom Γ A) ,, pullback Γ A))
              : cwf_representation pp).
    exact (pp ,, r).
  Defined.

  Definition isweq_cwf'_to_cwf_structure : isweq cwf'_to_cwf_structure.
  Proof.
    apply (isweq_iso cwf'_to_cwf_structure cwf_to_cwf'_structure).
    - intros x. apply idpath.
    - intros x. apply idpath.
  Defined.

  Definition weq_cwf'_cwf_structure
    : cwf'_structure C ≃ cwf_structure C.
  Proof.
    use tpair.
    - apply cwf'_to_cwf_structure.
    - apply isweq_cwf'_to_cwf_structure.
  Defined.

  (* Morphisms of CwF' structures *)
  Definition cwf'_structure_mor (X Y : cwf'_structure C) : UU
    := ∑ (ext : obj_ext_mor (pr1 X) (pr1 Y)),
       term_fun_mor X Y ext.

  Section mor.

    Context (X' Y' : cwf'_structure C).

    Local Definition X := cwf'_to_cwf_structure X'.
    Local Definition Y := cwf'_to_cwf_structure Y'.

    Definition cwf'_to_cwf_structure_mor
      : cwf'_structure_mor X' Y' → cwf_structure_mor X Y.
    Proof.
      intros [[F_TY p_ax1] [F_TM [ax2 ax3]]].
      set (p   := λ Γ A, pr1 (p_ax1 Γ A)).
      set (ax1 := λ Γ A, pr2 (p_ax1 Γ A)).
      exact ((F_TM ,, F_TY ,, p) ,, (ax1 ,, ax2 ,, ax3)).
    Defined.

    Definition cwf_to_cwf'_structure_mor
      : cwf_structure_mor X Y → cwf'_structure_mor X' Y'.
    Proof.
      intros [[F_TM [F_TY p]] [ax1 [ax2 ax3]]].
      set (ext := (F_TY ,, λ Γ A, (p Γ A ,, ax1 Γ A))
                  : obj_ext_mor (pr1 X') (pr1 Y')).
      set (tfm := (F_TM ,, ax2 ,, ax3) : term_fun_mor X' Y' ext).
      exact (ext ,, tfm).
    Defined.

    Definition isweq_cwf'_to_cwf_structure_mor : isweq cwf'_to_cwf_structure_mor.
    Proof.
      apply (isweq_iso cwf'_to_cwf_structure_mor
                       cwf_to_cwf'_structure_mor).
      - intros x. apply idpath.
      - intros x. apply idpath.
    Defined.

    Definition weq_cwf'_to_cwf_structure_mor
        : cwf'_structure_mor X' Y' ≃ cwf_structure_mor X Y.
    Proof.
      use tpair.
      - apply cwf'_to_cwf_structure_mor.
      - apply isweq_cwf'_to_cwf_structure_mor.
    Defined.

  End mor.

  (* CwF' to CwF functor *)

  Definition cwf'_to_cwf_functor_data
    : functor_data (cwf'_structure_precat C) (@cwf_structure_cat C).
  Proof.
    use make_functor_data.
    - apply cwf'_to_cwf_structure.
    - apply cwf'_to_cwf_structure_mor.
  Defined.

  Definition cwf'_to_cwf_functor_idax
    : functor_idax cwf'_to_cwf_functor_data.
  Proof.
    intros c.
    use total2_paths_f.
    + apply idpath.
    + use total2_paths_f.
      * apply idpath.
      * use total2_paths_f.
        -- apply idpath.
        -- apply impred_isaprop. intros Γ.
           apply impred_isaprop. intros A.
           apply setproperty.
  Defined.

  Definition cwf'_to_cwf_functor_compax
    : functor_compax cwf'_to_cwf_functor_data.
  Proof.
    intros a b c.
    intros f g.

    use total2_paths_f.
    + apply idpath.
    + apply dirprod_paths.
      - apply impred_isaprop. intros Γ.
        apply impred_isaprop. intros A.
        apply homset_property.
      - apply dirprod_paths.
        * apply homset_property.
        * apply impred_isaprop. intros Γ.
          apply impred_isaprop. intros A.
          apply setproperty.
  Defined.

  Definition cwf'_to_cwf_is_functor
    : is_functor cwf'_to_cwf_functor_data
    := (cwf'_to_cwf_functor_idax ,, cwf'_to_cwf_functor_compax).

  Definition cwf'_to_cwf_functor
    : functor (cwf'_structure_precat C)
              (@cwf_structure_precategory_data C).
  Proof.
    use (make_functor cwf'_to_cwf_functor_data).
    apply cwf'_to_cwf_is_functor.
  Defined.

  Definition cwf'_to_cwf_is_catiso : is_catiso cwf'_to_cwf_functor.
  Proof.
    use tpair.
    - unfold fully_faithful.
      intros X Y.
      apply isweq_cwf'_to_cwf_structure_mor.
    - apply isweq_cwf'_to_cwf_structure.
  Defined.

End CwF_Cat_Equiv.


(* The type 'v' represents the set of variables symbols.        *)
(* The type T v is the set of lambda terms with variables in v. *)

Inductive T (v:Type) : Type :=
| Var : v -> T v                    (* variable                 *)
| App : T v -> T v -> T v           (* application              *)
| Lam : v -> T v -> T v             (* lambda abstraction       *)
.

Arguments Var {v} _.
Arguments App {v} _ _.
Arguments Lam {v} _ _.


Require Import Coq.Bool.Bool.

Require Export Stlc.

Scheme Equality for type.

Lemma type_beq_refl : forall t,
  type_beq t t = true.
Proof.
  induction t.
  - reflexivity.
  - simpl.
    rewrite IHt1.
    rewrite IHt2.
    reflexivity.
Qed.

Lemma type_beq_eq_iff : forall t1 t2,
  type_beq t1 t2 = true <-> t1 = t2.
Proof.
  intros t1 t2.
  split; intros H.
  - generalize dependent t2.
    induction t1; intros t2 H.
    + destruct t2; try discriminate; reflexivity.
    + destruct t2; try discriminate.
      simpl in H.
      apply andb_true_iff in H as [H1 H2].
      apply IHt1_1 in H1.
      apply IHt1_2 in H2.
      subst.
      reflexivity.
  - rewrite H.
    apply type_beq_refl.
Qed.

(******************************************************************************)
(* has_type                                                                   *)
(******************************************************************************)
Print has_type.

Fixpoint fhas_type (c : context) (e : expr) : option type :=
  match e with
  | eunit => Some tunit
  | evar x => Context.find x c
  | eabs x t1 e =>
      option_map (tfun t1) (fhas_type (Context.add x t1 c) e)
  | eapp e1 e2 =>
      match fhas_type c e1 with
      | Some (tfun t1 t2) =>
          match fhas_type c e2 with
          | Some t3 =>
              if type_beq t1 t3 then Some t2 else None
          | None => None
          end
      | Some _ => None
      | None => None
      end
  | elet x e1 e2 =>
      match fhas_type c e1 with
      | Some t1 => fhas_type (Context.add x t1 c) e2
      | None => None
      end
  end.

Theorem fhas_type_if_has_type : forall c e t,
  has_type c e t -> fhas_type c e = Some t.
Proof.
  intros c e t HAS_TYPE.
  induction HAS_TYPE.
  - reflexivity.
  - simpl.
    rewrite H.
    reflexivity.
  - simpl.
    rewrite IHHAS_TYPE.
    reflexivity.
  - simpl.
    rewrite IHHAS_TYPE1.
    rewrite IHHAS_TYPE2.
    rewrite type_beq_refl.
    reflexivity.
  - simpl.
    rewrite IHHAS_TYPE1.
    assumption.
Qed.

Theorem has_type_if_fhas_type : forall c e t,
  fhas_type c e = Some t -> has_type c e t.
Proof.
  intros c e.
  generalize dependent c.
  induction e; intros c ty H.
  - inversion H; clear H.
    apply has_type_unit.
  - inversion H; clear H.
    apply has_type_var.
    assumption.
  - inversion H; clear H.
    destruct (fhas_type (Context.add v t c) e) eqn:Heqn.
    + inversion H1; clear H1.
      apply has_type_abs.
      auto.
    + discriminate.
  - inversion H; clear H.
    destruct (fhas_type c e1) eqn:Heqn1.
    + destruct t eqn:Heqn2.
      * discriminate.
      * destruct (fhas_type c e2) eqn:Heqn3.
        { destruct (type_beq t0_1 t0) eqn:Heqn4.
          - apply type_beq_eq_iff in Heqn4; subst.
            inversion H1; clear H1; subst.
            eapply has_type_app; eauto.
          - discriminate.
        }
        { discriminate. }
    + discriminate.
  - inversion H; clear H.
    destruct (fhas_type c e1) eqn:Heqn1; try discriminate.
    destruct (fhas_type (Context.add v t c) e2) eqn:Heqn2; try discriminate.
    inversion H1; subst.
    eauto using has_type_let.
Qed.

Theorem has_type_iff_fhas_type : forall c e t,
  has_type c e t <-> fhas_type c e = Some t.
Proof.
  intros. split.
  - eauto 2 using fhas_type_if_has_type.
  - eauto 2 using has_type_if_fhas_type.
Qed.

(******************************************************************************)
(* value                                                                      *)
(******************************************************************************)

Definition is_value (e : expr) : bool :=
  match e with
  | eunit => true
  | eabs _ _ _ => true
  | _ => false
  end.

Theorem value_iff_is_value : forall e,
  value e <-> is_value e = true.
Proof.
  intros e. split; intros H.
  - induction H; reflexivity.
  - induction e; auto using value; inversion H.
Qed.

Theorem not_value_iff_is_value_false : forall e,
  ~ value e <-> is_value e = false.
Proof.
Admitted.

(******************************************************************************)
(* feval                                                                      *)
(******************************************************************************)

Print eval.

Fixpoint feval (h : heap) (e : expr) : option expr :=
  match e with
  | eunit => None
  | evar x => Heap.find x h
  | eabs _ _ _ => None
  | eapp (eabs x t e) e2 =>
      if is_value e2 then
        Some (subst x e2 e)
      else
        match feval h e2 with
        | Some v2 => Some (eapp (eabs x t e) v2)
        | None => None
        end
  | eapp e1 e2 =>
      match feval h e1 with
      | Some v1 => Some (eapp v1 e2)
      | None => None
      end
  | elet x e1 e2 =>
      if is_value e1 then
        Some (subst x e1 e2)
      else
        match feval h e1 with
        | Some v1 => Some (elet x v1 e2)
        | None => None
        end
  end.

Lemma not_value_if_eval : forall h e1 e2, eval h e1 e2 -> ~ value e1.
Proof.
  intros h e1 e2 H.
  inversion H; rewrite value_iff_is_value; try discriminate.
Qed.

Theorem feval_if_eval : forall c h e1 e2 t,
  has_type c e1 t ->
  eval h e1 e2 ->
  feval h e1 = Some e2.
Proof.
  intros c h e1 e2 t HAS_TYPE EVAL.
  generalize dependent t.
  generalize dependent c.
  induction EVAL; intros c ty HAS_TYPE.
  - assumption.
  - simpl.
    destruct e1;
      inversion EVAL; inversion HAS_TYPE; subst;
      erewrite IHEVAL; eauto.
  - simpl.
    destruct v1.
    + inversion HAS_TYPE; subst.
      inversion H3.
    + inversion H.
    + inversion HAS_TYPE; subst.
      apply not_value_if_eval in EVAL.
      rewrite value_iff_is_value in EVAL.
      apply not_true_is_false in EVAL.
      rewrite EVAL.
      erewrite IHEVAL; eauto.
    + inversion H.
    + inversion H.
  - apply value_iff_is_value in H.
    simpl.
    rewrite H.
    reflexivity.
  - simpl.
    inversion HAS_TYPE; clear HAS_TYPE; subst.
    apply not_value_if_eval in EVAL.
    rewrite value_iff_is_value in EVAL.
    apply not_true_is_false in EVAL.
    destruct (is_value e1) eqn:Heqn.
    + discriminate.
    + erewrite IHEVAL; eauto 1.
  - simpl.
    apply value_iff_is_value in H.
    rewrite H.
    reflexivity.
Qed.

Lemma eval_if_not_value : forall e1,
  ~ value e1 -> exists h e2, eval h e1 e2.
Proof.
Admitted.

Theorem eval_if_feval : forall c h e1 e2 t,
  has_type c e1 t ->
  feval h e1 = Some e2 ->
  eval h e1 e2.
Proof.
  intros c h e1.
  generalize dependent h.
  generalize dependent c.
  induction e1; intros c h e2 ty HAS_TYPE H.
  - inversion H.
  - simpl in H.
    apply eval_var.
    assumption.
  - inversion H.
  - inversion HAS_TYPE; clear HAS_TYPE; subst.
    destruct e1_1 eqn:Heqn.
    + discriminate.
    + simpl in H.
      destruct (Heap.find (elt:=expr) v h) eqn:Heqn2.
      * inversion H.
        apply eval_app1.
        apply eval_var.
        assumption.
      * discriminate.
    + simpl in H.
      destruct (is_value e1_2) eqn:Heqn2.
      * inversion H.
        apply eval_beta.
        apply value_iff_is_value.
        assumption.
      * destruct (feval h e1_2) eqn:Heqn3;
          inversion H; clear H; subst;
          eauto using eval_app2, vabs.
    + rewrite <- Heqn in *.
      simpl in H.
      destruct (feval h e1_1) eqn:Heqn2.
      * rewrite Heqn in *.
        inversion H.
        eauto using eval_app1.
      * rewrite Heqn in *.
        discriminate.
    + rewrite <- Heqn in *.
      simpl in H.
      destruct (feval h e1_1) eqn:Heqn2.
      * rewrite Heqn in *.
        inversion H.
        eauto using eval_app1.
      * rewrite Heqn in *.
        discriminate.
  - inversion HAS_TYPE; clear HAS_TYPE; subst.
    simpl in H.
    destruct (is_value e1_1) eqn:Heqn1.
    + inversion H; clear H; subst.
      apply eval_let2.
      apply value_iff_is_value.
      assumption.
    + destruct (feval h e1_1) eqn:Heqn2;
        inversion H; clear H; subst;
        eauto using eval_let1.
Qed.

Theorem eval_iff_feval : forall c h e1 e2 t,
  has_type c e1 t ->
  eval h e1 e2 <-> feval h e1 = Some e2.
Proof.
  intros. split.
  - eauto 2 using feval_if_eval.
  - eauto 2 using eval_if_feval.
Qed.


(** printing \2/ $\cup$ #∪# *)
(** printing <2= $\subseteq$ #⊆# *)
(** printing forall $\forall$ #∀# *)
(** printing -> $\rightarrow$ #→# *)
(** printing /\ $\land$ #∧# *)

Require Import Setoid Program.
Require Import Paco.paco.

(** * Illustrating the [paco] library

    This tutorial shows how to use our [paco] library to reason about
    coinductive predicates in Coq.  By coinductive predicates we mean
    objects that one can define using [CoInductive] and whose type
    ends in [Prop].  The library implements _parameterized
    coinduction_, as described in our draft paper entitled ## _The Power of
    Parameterization in Coinductive Proof_ ##.

    How does parameterized coinduction compare to Coq's existing
    support for coinductive proofs?

    For proofs by _induction_, Coq provides a tactic called [fix], but
    proofs done directly with [fix] are required to satisfy a
    _syntactic guardedness_ criterion.  Fortunately, Coq also
    generates induction _lemmas_ for every inductive definition, which
    eliminate the need to ever use the low-level [fix] tactic and
    worry about guardedness.  For proofs by coinduction, Coq provides
    a tactic [cofix] analogous to [fix], i.e., also based on a
    syntactic guardedness criterion.  However, Coq does not generate
    any lemmas for coinductive definitions.  Consequently, to reason
    about such definitions, the user must use the low-level [cofix]
    tactic.  Due to its syntactic nature, [cofix] is problematic in
    several ways (please see the paper linked above for detailed
    discussion of these points):

    - It is non-compositional.
    - It is inefficient.
    - It is not user-friendly.
    - It interacts poorly with builtin automation tactics.

    The [paco] library provides a tactic, [pcofix], which can be seen
    as a replacement for Coq's builtin [cofix] tactic (in the case of
    predicates) that does not involve any syntactic guardedness
    criterion and thus avoids all of these problems.  In addition,
    like Coq's [cofix], [pcofix] provides built-in support for
    _incremental_ proofs, i.e., proofs in which the coinduction
    hypothesis is extended gradually as the proof progresses.

    We believe this combination of compositionality, incrementality,
    robustness, and ease of use makes [pcofix] a superior alternative
    to [cofix] for proofs about coinductive predicates.

    The rest of this tutorial illustrates the use of the [paco]
    library with the help of three examples.
*)(* *)

(** ** Example: stream equality

    The first example involves streams of natural numbers and an
    equality thereon.  We prove a particular equality via [cofix], and
    then explain how that proof can be turned into one via [pcofix].
*)

(** We start by defining a type of streams of natural numbers.
*)

CoInductive stream :=
  | cons : nat -> stream -> stream.

(** The following, seemingly useless, lemma is a common trick for
    working with corecursive terms such as our streams.  (It will be
    used in the example proofs.)  For details, see for instance #Adam
    Chlipala's book on Certified Programming with Dependent
    Types#.
*)

Definition sunf s :=
  match s with cons n s' => cons n s' end.

Lemma sunf_eq : forall s, s = sunf s.
Proof.
  destruct s; auto.
Qed.

(** In order to state our example equality, we define an enumeration
    stream and a map operation for streams.
*)

CoFixpoint enumerate n : stream :=
  cons n (enumerate (S n)).

CoFixpoint map f s : stream :=
  match s with cons n s' => cons (f n) (map f s') end.

(** *** A proof using [cofix]

    We will now prove, using [cofix], that for any [n] the stream
    [enumerate n] is equal to the stream [cons n (map S (enumerate n))].
*)

(** First, we define an equality [seq] on streams.  Usually, one would
    do this as follows.

    [CoInductive seq : stream -> stream -> Prop :=] #
#
    [  | seq_fold : forall n s1 s2 (R : seq s1 s2), seq (cons n s1) (cons n s2).]

    Instead, we define the generating function, [seq_gen], beforehand,
    and then define [seq] as its greatest fixed point using
    [CoInductive].  The reason is simply that we need [seq_gen] later
    when using [paco].  If applying parameterized coinduction to an
    existing development where the generating function is not
    explicit, it can always easily be made explicit.

    Note that, albeit the use of [Inductive], the definition
    of [seq_gen] is not recursive.
*)

Inductive seq_gen seq : stream -> stream -> Prop :=
  | _seq_gen : forall n s1 s2 (R : seq s1 s2 : Prop), seq_gen seq (cons n s1) (cons n s2).
#[export] Hint Constructors seq_gen : core.

CoInductive seq : stream -> stream -> Prop :=
  | seq_fold : forall s1 s2, seq_gen seq s1 s2 -> seq s1 s2.

(** Second, we do the actual proof.
*)

Theorem example : forall n, seq (enumerate n) (cons n (map S (enumerate n))).
Proof.
  cofix CIH.
  intros; apply seq_fold.
  pattern (enumerate n) at 1; rewrite sunf_eq; simpl.
  constructor.
  rewrite (sunf_eq (enumerate n)); simpl.
  rewrite (sunf_eq (map _ _)); simpl.
  apply CIH.
Qed.

(** _Note_: One might want to eliminate the use of [pattern] in the
    proof script by replacing the corresponding line with the
    following:

    [rewrite sunf_eq at 1; simpl.]

    However, doing so will result in an invalid proof (rejected at
    [Qed]-time).  The reason is that the proof term created by
    [rewrite] ... [at 1] involves some lemmas from the [Setoid]
    library.  Like most lemmas, these are opaque, so guardedness
    checking cannot inspect their proofs and thus fails.  This is a
    great example of two of the previously mentioned problems with the
    [cofix] approach, namely lack of compositionality and poor
    interaction with standard tactics.
*)(* *)

(** *** A proof using our [pcofix]

    We will now do the same proof, but using the [paco] library.  We
    first simply show the new (but equivalent) definition of stream
    equality and the new proof of the example, and then explain what
    is going on behind the scenes.  In both, we use [paco] constructs
    with suffix "2" because we are dealing with predicates of arity 2
    here.

    _Note_: [Paco] supports predicates of arity up to 8.  Also, it
    supports up to three mutually coinductive predicates (see the last
    example of this tutorial).  In either case, extending this is just
    a matter of copy and paste.

    We also have to prove monotonicity of the generating function
    [seq_gen], which can be discharged by the tactic [pmonauto], and
    register it in the Hint databse [paco].

    _Remark_: Unlike [CoInductive], [paco] does not care whether the
    generating function is given in a _strictly positive_ syntactic
    form; all that matters is that the function is monotone. More
    specifically, [paco2 f] is well defined for an arbitrary generating
    function [f] regardless of whether it is monotone or not. However,
    in order to ensure that [paco2 f bot2] is the greatest fixed point
    of [f], we need monotonicity of [f].
*)

Definition seq' s1 s2 := paco2 seq_gen bot2 s1 s2.
#[export] Hint Unfold seq' : core.
Lemma seq_gen_mon: monotone2 seq_gen. Proof. pmonauto. Qed.
#[export] Hint Resolve seq_gen_mon : paco.

Theorem example' : forall n, seq' (enumerate n) (cons n (map S (enumerate n))).
Proof.
  pcofix CIH.
  intros; pfold.
  rewrite sunf_eq at 1; simpl.
  constructor.
  rewrite (sunf_eq (enumerate n)); simpl.
  rewrite (sunf_eq (map _ _)); simpl.
  right; apply CIH.
Qed.

(** Observe that the proof script is essentially the same as before
    (this is no accident).  The main change is the use of [pcofix]
    instead of [cofix], which allows us to avoid any syntactic
    guardedness checking at [Qed]-time.  As a minor benefit of that,
    we are able to use [rewrite] ... [at 1], which we could not do
    before.  *)

(** **** How it works:

    To understand [seq'] and the proof of [example'], we have to
    explain some background.  Given a monotone function [f], we call
    [paco2 f] the _parameterized_ greatest fixed point of [f].  For a
    relation [r], [paco2 f r] is defined as the greatest fixed point
    of the function [fun x => f (x \2/ r)].  Clearly, [paco2 f bot2]
    (where [bot2] is the empty relation) is just the ordinary greatest
    fixed point of [f].

    Let us look at our example domain to understand better.  A proof
    of [paco2 seq_gen r s1 s2] can be seen as a proof of [r <2= seq ->
    seq s1 s2], where the use of the premise is guarded
    _semantically_, rather than syntactically.  More precisely, [paco2
    seq_gen r] relates two streams iff their heads are equal and their
    tails are either related by [r] or again related by [paco2 seq_gen
    r].  Compare this to [seq], the ordinary greatest fixed point of
    [seq_gen], which relates two streams iff their heads are equal and
    their tails are again related by [seq].  This should also make it
    clear why our definition of [seq'] is equivalent to [seq].

    To fold and unfold parameterized fixed points, we provide two
    tactics, where [upaco2 f r := paco2 f r \2/ r]:

    - [pfold] : when the conclusion is [paco2 f r] for some [f] and
      [r], [pfold] converts it to [f (upaco2 f r)]
    - [punfold H] : when the hypothesis [H] is [paco2 f r] for some
      [f] and [r], [punfold H] converts it to [f (upaco2 f r)]

    Other useful lemmas are:

    - [paco2_mon f : monotone2 (paco2 f)]
    - [paco2_mult f : forall r, paco2 f (paco2 f r) <2= paco2 f r]
    - [paco2_mult_strong f : forall r, paco2 f (upaco2 f r) <2= paco2 f r]

    We will see an example involving [paco2_mult] in a moment.  But
    first let us have another look at the proof scripts of [example]
    and [example'].  In the former, after calling [cofix], the proof
    state is as follows:

    [CIH : forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#
    [============================] #
#
    [forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#

    In this state, the hypothesis precisely matches the conclusion,
    and there is nothing preventing one from simply concluding the
    goal directly.  Of course, if one were to do that, one's "proof"
    would be subsequently rejected by [Qed] for failing to obey
    syntactic guardedness.

    Calling [pcofix] results in a similar state, except that the added
    hypothesis [CIH] now governs a fresh relation variable [r], which
    represents the current coinduction hypothesis relating [enumerate n]
    and [cons n (map S (enumerate n))] for all [n].  The new goal
    then says that, in proving the two streams equal, we can use [r]
    coinductively, but only in a semantically guarded position,
    i.e. after unfolding [paco2 seq_gen r].  In particular, one
    _cannot_ apply [CIH] immediately to "solve" the goal:

    [r : stream -> stream -> Prop] #
#
    [CIH : forall n : nat, r (enumerate n) (cons n (map S (enumerate n)))] #
#
    [============================] #
#
    [forall n : nat, paco2 seq_gen r (enumerate n) (cons n (map S (enumerate n)))] #
#

    The remaining differences between the proof scripts of [example]
    and [example'] are as follows.  First, let us examine [example].
    After applying [seq_fold] and unfolding [enumerate n] in the proof
    of [example], we have the following goal:

    [CIH : forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [seq_gen seq (cons n (enumerate (S n))) (cons n (map S (enumerate n)))] #
#

    By the definition of [seq_gen] and unfolding [map S (enumerate n)],
    this reduces to showing

    [CIH : forall n : nat, seq (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [seq (enumerate (S n)) (cons (S n) (map S (enumerate (S n))))] #
#

    which follows directly by applying the coinduction hypothesis [CIH].

    In the case of [example'], the proof is slightly different.
    First, we use the tactic [pfold] rather than [apply seq_fold],
    simply because we now reason about [seq'] rather than [seq].
    After applying [pfold] and unfolding [enumerate n], we have:

    [r : stream -> stream -> Prop] #
#
    [CIH : forall n : nat, r (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [seq_gen (paco2 seq_gen r \2/ r) (cons n (enumerate (S n))) (cons n (map S (enumerate n)))] #
#

    As you see, the relation [r] appears in the argument of
    [seq_gen]. Thus by definition of [seq_gen] and unfolding [map S
    (enumerate n)], we need to show [enumerate (S n)] and [cons (S n)
    (map S (enumerate (S n)))] are related by either [paco2 seq_gen r]
    or [r]:

    [r : stream -> stream -> Prop] #
#
    [CIH : forall n : nat, r (enumerate n) (cons n (map S (enumerate n)))] #
#
    [n : nat] #
#
    [============================] #
#
    [paco2 seq_gen r (enumerate (S n)) (cons (S n) (map S (enumerate (S n))))] #
#
    [ \/ r (enumerate (S n)) (cons (S n) (map S (enumerate (S n))))] #
#

    As the coinduction hypothesis gives us that they are related by [r],
    we first have to select the [right] disjunct, before we apply
    [CIH].

    Summing up, the two proofs are very similar, but in the one using
    [paco], the guardedness of the coinduction is guaranteed at every
    step by the way the proof is constructed, rather than by a
    syntactic check of the whole proof term after the fact.
 *)(* *)

(** *** Another example

    Before moving on to the second part, we briefly demonstrate the
    use of the tactics [punfold] and [pclearbot].
*)(* *)

(** Here is a proof for [seq].
*)

Theorem seq_cons : forall n1 n2 s1 s2 (SEQ : seq (cons n1 s1) (cons n2 s2)),
  n1 = n2 /\ seq s1 s2.
Proof.
  intros.
  inversion_clear SEQ; rename H into SEQ.
  inversion_clear SEQ; auto.
Qed.

(** And here is the corresponding proof for [seq'].

  Note that the tactic [pclearbot] simplifies all hypotheses of the form [upaco{n} gf bot{n}] to [paco{n} gf bot{n}].
*)

Theorem seq'_cons : forall n1 n2 s1 s2 (SEQ : seq' (cons n1 s1) (cons n2 s2)),
  n1 = n2 /\ seq' s1 s2.
Proof.
  intros.
  punfold SEQ.
  inversion_clear SEQ; pclearbot; auto.
Qed.

(** We also provide two tactics [pdestruct] and [pinversion].
    They are simply defined as follows:

    - [pdestruct H] := [punfold H; destruct H; pclearbot]
    - [pinversion H] := [punfold H; inversion H; pclearbot]

    Using this the proof of the above theorem [seq'_cons] can be
    simplified as [intros; pinversion SEQ; auto.]
*)(* *)

(** ** Example: infinite tree equality

    The second example involves infinite binary trees of natural
    numbers and an equality thereon.  We prove two particular
    equalities via [cofix] in an incremental fashion, and then show
    how these proofs can be done just as easily via [pcofix].
    We then show how, using [pcofix], the proofs can additionally
    be modularly decomposed.

*)

(** As before, we first define the coinductive type and the unfolding
    trick.
*)

CoInductive inftree :=
  | node : nat -> inftree -> inftree -> inftree.

Definition tunf t : inftree :=
  match t with node n tl tr => node n tl tr end.

Lemma tunf_eq : forall t, t = tunf t.
Proof.
  destruct t; auto.
Qed.

(** In order to state our example equalities, we define the following
    four trees.
*)

CoFixpoint one : inftree := node 1 one two
with       two : inftree := node 2 one two.

CoFixpoint eins : inftree := node 1 eins (node 2 eins zwei)
with       zwei : inftree := node 2 eins zwei.

(** *** Incremental proofs using [cofix]

    As before, we define the tree equality as the greatest fixed point
    of its generating function.
*)

Inductive teq_gen teq : inftree -> inftree -> Prop :=
  | _teq_gen : forall n t1l t1r t2l t2r (Rl : teq t1l t2l : Prop) (Rr : teq t1r t2r),
                 teq_gen teq (node n t1l t1r) (node n t2l t2r).
#[export] Hint Constructors teq_gen : core.

CoInductive teq t1 t2 : Prop :=
  | teq_fold (IN : teq_gen teq t1 t2).

(** We now prove, using [cofix], that [one] equals [eins] and,
    separately, that [two] equals [zwei].  Note the nested use of
    [cofix] in either proof script, which lets us strengthen the
    coinductive hypothesis in the middle of the proof.  For instance,
    in the proof [teq_one], we start out with the coinductive
    hypothesis that [one] and [eins] are equal ([CIH]).  Later on, we
    use [cofix] again to additionally assume that [two] and [zwei] are
    equal ([CIH']).  This is a prime example of _incremental_ proof:
    we start with no coinductive assumptions, and we progressively add
    more coinductive assumptions as the proof progresses.
*)

Theorem teq_one : teq one eins.
Proof.
  cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  apply teq_fold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
  cofix CIH'.
  apply teq_fold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Qed.

Theorem teq_two : teq two zwei.
Proof.
  cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
  cofix CIH'.
  apply teq_fold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  apply teq_fold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Qed.

(** *** Incremental proofs using our [pcofix]

    As before, we can easily turn the above [cofix]-proofs into
    [pcofix]-proofs.
*)

Definition teq' t1 t2 := paco2 teq_gen bot2 t1 t2.
#[export] Hint Unfold teq' : core.
Lemma teq_gen_mon: monotone2 teq_gen. Proof. pmonauto. Qed.
#[export] Hint Resolve teq_gen_mon : paco.

Theorem teq'_one : teq' one eins.
Proof.
  pcofix CIH.
  pfold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  left; pfold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
  left; pcofix CIH'.
  pfold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Qed.

Theorem teq'_two : teq' two zwei.
Proof.
  pcofix CIH.
  pfold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
  left; pcofix CIH'.
  pfold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  left; pfold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Qed.

(** *** Pseudo-compositional proofs using [cofix]

    It is easy to see that the proofs of [teq_one] and [teq_two] are
    essentially the same.  We can avoid duplicating some work by
    decomposing the proofs as follows.

    First we prove that [teq two zwei] holds under the coinductive
    assumption [teq one eins].  This is basically the second part of
    the proof of [teq_one] (and the first part of the proof of
    [teq_two]).  Then we prove the converse, i.e., that [teq one
    eins] holds under the coinductive assumption [teq two zwei].
    This is basically the first part of the proof of [teq_one] (and
    the second part of the proof of [teq_two]).

    The issue is that there seems to be no way to express these two
    properties.  The best we can do is prove [teq two zwei -> teq one
    eins] and [teq one eins -> teq two zwei], and make sure that in
    these proofs any use of the assumption is syntactically guarded.
    For instance, we are not allowed to prove [teq two zwei -> teq
    one eins] by inspecting [teq two zwei] and extracting [teq one
    eins] from that (see the proof of [teq_two_one_bad] below).
    Although a valid proof of that goal by itself, it could not be
    composed later to yield a proof of [teq one eins] or [teq two
    zwei] (see the aborted theorem [teq_eins_bad] below).

    Moreover, both lemmas must then be made transparent by using
    [Defined] instead of [Qed] at the end, such that, when composing
    them to prove [teq one eins] or [teq two zwei], guardedness
    checking can inspect their proof terms.  In other words, [cofix]
    is not properly compositional.
*)

Lemma teq_two_one_bad : teq two zwei -> teq one eins.
Proof.
  intros; rewrite (tunf_eq two), (tunf_eq zwei) in H.
  destruct H; inversion IN; auto.
Defined.

Lemma teq_two_one : teq two zwei -> teq one eins.
Proof.
  intros; cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  apply teq_fold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Defined.

Lemma teq_one_two : teq one eins -> teq two zwei.
Proof.
  intros; cofix CIH.
  apply teq_fold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Defined.

Theorem teq_eins : teq one eins.
Proof.
  cofix CIH.
  apply teq_two_one, teq_one_two, CIH.
Qed.

Theorem teq_zwei : teq two zwei.
Proof.
  cofix CIH.
  apply teq_one_two, teq_two_one, CIH.
Qed.

(** The following proof would fail guardedness checking at [Qed]-time,
    because in the proof of the lemma [teq_two_one_bad] the
    assumption is used "too early".
*)

Theorem teq_eins_bad : teq one eins.
Proof.
  cofix CIH.
  apply teq_two_one_bad, teq_one_two, CIH.
Abort.

(** *** Compositional proofs using our [pcofix]

    Using parameterized coinduction, we can state the actual desired
    lemmas as follows and prove them using [pcofix] (again, only
    minimal changes to the previous proof scripts are required).
    Observe that (i) the earlier "wrong" proof of [teq two zwei -> teq
    one eins] ([teq_two_one_bad]) is _not_ a proof of the
    corresponding lemma here, and (ii) we are not forced to make the
    lemmas transparent.
*)

Lemma teq'_two_one : forall r,
  (r two zwei : Prop) -> paco2 teq_gen r one eins.
Proof.
  intros; pcofix CIH.
  pfold.
  rewrite (tunf_eq one), (tunf_eq eins); simpl.
  constructor; auto.
  left; pfold.
  rewrite (tunf_eq two); simpl.
  constructor; auto.
Qed.

Lemma teq'_one_two : forall r,
  (r one eins : Prop) -> paco2 teq_gen r two zwei.
Proof.
  intros; pcofix CIH.
  pfold.
  rewrite (tunf_eq two), (tunf_eq zwei); simpl.
  constructor; auto.
Qed.

(** We now compose them with the help of the lemma [paco2_mult]:
    - [paco2_mult f : paco2 f (paco2 f r) <2= paco2 f r]

    The tactic [pmult] applies [paco{n}_mult] to the conclusion
    for an appropriate [n].
*)

Theorem teq'_eins : teq' one eins.
Proof.
  pcofix CIH.
  pmult; apply teq'_two_one, teq'_one_two, CIH.
Qed.

Theorem teq'_zwei : teq' two zwei.
Proof.
  pcofix CIH.
  pmult; apply teq'_one_two, teq'_two_one, CIH.
Qed.

(** ** Example: mutual coinduction

    The third and last example shows that [paco] also works for mutual
    coinduction.  Here, the mutuality involves two predicates.
*)(* *)

(** We define two generating functions (using the [inftree] type from
    before).
*)

(** *** A proof via [cofix]

    Using these, we now define two mutually coinductive predicates
    [eqone] and [eqtwo].  It is easy to see intuitively that they
    contain all trees that are equal to [one] and [two] from above,
    respectively.  We then prove that [eqone] contains [eins].
*)

CoInductive eqone : inftree -> Prop :=
  | eqone_fold tl tr (EQL : eqone tl : Prop) (EQR : eqtwo tr : Prop):
      eqone (node 1 tl tr)
with eqtwo : inftree -> Prop :=
  | eqtwo_fold tl tr (EQL : eqone tl : Prop) (EQR : eqtwo tr : Prop):
      eqtwo (node 2 tl tr).

Lemma eqone_eins : eqone eins.
Proof.
  cofix CIH0.
  rewrite (tunf_eq eins); simpl.
  constructor; [apply CIH0|].
  cofix CIH1.
  constructor; [apply CIH0|].
  rewrite (tunf_eq zwei).
  apply CIH1.
Qed.

(** *** A proof via [pcofix]

    To define the [paco] versions of [eqone] and [eqtwo], we apply
    the two constructors [paco1_2_0] and [paco1_2_1], respectively ("1"
    because we are dealing with unary predicates).  Again, the
    translation of the lemma and of its proof is almost trivial.
 *)

Inductive eqonetwo_gen eqonetwo : inftree+inftree -> Prop :=
  | eqonetwo_left: forall tl tr (EQL: eqonetwo (inl tl) : Prop) (EQR: eqonetwo (inr tr) : Prop),
      eqonetwo_gen eqonetwo (inl (node 1 tl tr))
  | eqonetwo_right: forall tl tr (EQL: eqonetwo (inl tl) : Prop) (EQR: eqonetwo (inr tr) : Prop),
      eqonetwo_gen eqonetwo (inr (node 2 tl tr))
.
#[export] Hint Constructors eqonetwo_gen : core.

Definition eqone' t := paco1 eqonetwo_gen bot1 (inl t).
Definition eqtwo' t := paco1 eqonetwo_gen bot1 (inr t).
#[export] Hint Unfold eqone' eqtwo' : core.
Lemma eqonetwo_gen_mon: monotone1 eqonetwo_gen.
Proof. pmonauto. Qed.
#[export] Hint Resolve eqonetwo_gen_mon : paco.

Lemma eqone'_eins: eqone' eins.
Proof.
  pcofix CIH0; pfold.
  rewrite (tunf_eq eins); simpl.
  constructor; [right; apply CIH0|].
  left; pcofix CIH1; pfold.
  constructor; [right; apply CIH0|].
  rewrite (tunf_eq zwei).
  right; apply CIH1.
Qed.


From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From ShortLogrels Require Import prelude language.

Inductive expr :=
| Var (v : var)
| TT
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
| Lam (e : {bind expr})
| App (e1 e2 : expr).

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

Inductive is_val : expr → Prop :=
| IVTT : is_val TT
| IVPair e1 e2 : is_val e1 → is_val e2 → is_val (Pair e1 e2)
| IVLam e : is_val (Lam e).

Inductive type :=
| TUnit
| TProd (τ1 τ2 : type)
| TFun (τ1 τ2 : type).

Definition context := environment type.

Inductive typed : context → expr → type → Prop :=
| TPVar Γ v tp : lookup Γ v = Some tp → typed Γ (Var v) tp
| TPTT Γ : typed Γ TT TUnit
| TPPAIR Γ e1 τ1 e2 τ2 : typed Γ e1 τ1 → typed Γ e2 τ2 → typed Γ (Pair e1 e2) (TProd τ1 τ2)
| TPFst Γ e τ1 τ2 : typed Γ e (TProd τ1 τ2) → typed Γ (Fst e) τ1
| TPSnd Γ e τ1 τ2 : typed Γ e (TProd τ1 τ2) → typed Γ (Snd e) τ2
| TPLam Γ e τ1 τ2 : typed (τ1 :: Γ) e τ2 → typed Γ (Lam e) (TFun τ1 τ2)
| TPApp Γ e1 e2 τ1 τ2 : typed Γ e1 (TFun τ1 τ2) → typed Γ e2 τ1 → typed Γ (App e1 e2) τ2.

Inductive head_step : expr → expr → Prop :=
| SFst e1 e2 : is_val e1 → is_val e2 → head_step (Fst (Pair e1 e2)) e1
| SSnd e1 e2 : is_val e1 → is_val e2 → head_step (Snd (Pair e1 e2)) e2
| SApp e1 e2 : is_val e2 → head_step (App (Lam e1) e2) e1.[e2/].

Inductive is_ectx : (expr → expr) → Prop :=
| ECTX_id : is_ectx (λ e, e)
| ECTX_Fst K : is_ectx K → is_ectx (λ e, Fst (K e))
| ECTX_Snd K : is_ectx K → is_ectx (λ e, Snd (K e))
| ECTX_Pair1 K e2 : is_ectx K → is_ectx (λ e, Pair (K e) e2)
| ECTX_Pair2 e1 K : is_val e1 → is_ectx K → is_ectx (λ e, Pair e1 (K e))
| ECTX_App1 K e2 : is_ectx K → is_ectx (λ e, App (K e) e2)
| ECTX_App2 e1 K : is_val e1 → is_ectx K → is_ectx (λ e, App e1 (K e)).

Local Hint Constructors is_ectx : is_ectx.

Lemma is_ectx_val : ∀ (e : expr) (K : expr → expr), is_ectx K → is_val (K e) → is_val e.
Proof.
  intros e K HK; revert e.
  induction HK; [trivial; fail|inversion 1; subst; auto .. ].
Qed.

Lemma is_val_dec e : is_val e ∨ ¬ is_val e.
Proof.
  induction e; try (right; inversion 1; fail).
  - left; constructor.
  - destruct IHe1; destruct IHe2; [left; constructor; auto; fail|right; inversion 1; tauto .. ].
  - left; constructor.
Qed.

Lemma ectx_head_step K e e' : is_ectx K → head_step (K e) e' → (∀ f : expr, K f = f) ∨ is_val e.
Proof.
  intros HK; revert e e'.
  induction HK.
  - left; trivial.
  - inversion HK; inversion 1; subst; right; [econstructor; eauto|eapply is_ectx_val; eauto .. ].
  - inversion HK; inversion 1; subst; right; [econstructor; eauto|eapply is_ectx_val; eauto .. ].
  - inversion HK; inversion 1.
  - inversion HK; inversion 1.
  - inversion HK; inversion 1; subst; right; constructor.
  - inversion 1; subst; right; eapply is_ectx_val; eauto.
Qed.

Lemma ectx_inj K e e' : is_ectx K → K e = K e' → e = e'.
Proof.
  intros HK; revert e e'.
  induction HK; intros e e' Hee.
  - trivial.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
Qed.

Lemma ectx_compose K K' : is_ectx K → is_ectx K' → is_ectx (λ e : expr, K (K' e)).
Proof.
  intros HK; revert K'.
  induction HK; [trivial| intros; econstructor; eauto .. ].
Qed.

Lemma ectxs_nesting K e K' e' :
  is_ectx K → is_ectx K' → K e = K' e' → ¬ is_val e → ¬ is_val e' →
  (∃ K'' : expr → expr, is_ectx K'' ∧ (∀ f : expr, K f = K' (K'' f)))
  ∨ (∃ K'' : expr → expr, is_ectx K'' ∧ (∀ f : expr, K' f = K (K'' f))).
Proof.
  intros HK; revert e e' K'.
  induction HK as [|?? IHK|?? IHK | K e2 ? IHK|e1 K Hval ? IHK|K e2 ? IHK|e1 K Hval ? IHK];
    intros e e' K' HK' Hee Hnve Hnve'.
  - right; exists K'; auto.
  - destruct HK'; [left; exists (λ e, Fst (K e)); auto with is_ectx; fail| |congruence ..].
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
      (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK'; [left; exists (λ e, Snd (K e)); auto with is_ectx; fail|
                    congruence| |congruence ..].
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption| assumption|left|right];
      (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK' as [| | | |? ? Hval | |];
      [left; eexists (λ e, Pair (K e) e2); eauto with is_ectx; fail|
        congruence|congruence | | |congruence .. ].
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
        [congruence|assumption|assumption|left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
  - destruct HK'; [left; eexists (λ e, Pair e1 (K e)); eauto with is_ectx; fail|
        congruence|congruence | | |congruence .. ].
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
        [congruence|assumption|assumption|left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK' as [| | | | | |? ? Hval];
      [left; exists (λ e, App (K e) e2); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence| ..].
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
  - destruct HK';
      [left; exists (λ e, App e1 (K e)); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence| ..].
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
Qed.

Global Instance stlc_valid_language : valid_language is_val is_ectx head_step.
Proof.
  split.
  - inversion 1; inversion 1.
  - apply is_ectx_val.
  - constructor.
  - apply is_val_dec.
  - apply ectx_head_step.
  - apply ectx_inj.
  - apply ectx_compose.
  - apply ectxs_nesting.
Qed.

Lemma det_head_step_fst v1 v2 : is_val v1 → is_val v2 → det_head_step (Fst (Pair v1 v2)) v1.
Proof.
  intros; split; [constructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_snd v1 v2 : is_val v1 → is_val v2 → det_head_step (Snd (Pair v1 v2)) v2.
Proof.
  intros; split; [constructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_app e v : is_val v → det_head_step (App (Lam e) v) e.[v/].
Proof.
  intros; split; [econstructor; assumption| inversion 1; subst; reflexivity].
Qed.

Ltac solve_det_head_step :=
  solve [eapply det_head_step_fst; assumption|
          eapply det_head_step_snd; assumption|
          eapply det_head_step_app; eassumption].


(*** Membership predicates ***)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Ring.
Require Import ott_list_base.
Require Import ott_list_core.
Require Import ott_list_nth.
Set Implicit Arguments.

(*** Membership predicate ***)

Section In.
Variable A : Set.
Implicit Types x : A.
Implicit Types xs l : list A.

(* Speed up proofs by providing trivial consequences of [List.in_or_app] that
   do not require eauto. *)
Lemma In_left_app :
  forall l l' a, In a l -> In a (l ++ l').
Proof. auto with datatypes. Qed.
Lemma In_right_app :
  forall l l' a, In a l -> In a (l ++ l').
Proof. auto with datatypes. Qed.

Lemma not_in_app_or :
  forall l l' a, ~In a (l ++ l') -> ~In a l /\ ~In a l'.
Proof. unfold not; auto with datatypes. Qed.
Lemma not_in_or_app :
  forall l l' a, ~In a l /\ ~In a l' -> ~In a (l ++ l').
Proof. unfold not; destruct 1; intros. pose (in_app_or _ _ _ H1). tauto. Qed.

Lemma nth_error_In :
  forall l n x, nth_error l n = Some x -> In x l.
Proof.
  intros; generalize dependent l; induction n; destruct l; intros;
    simpl in *; simplify_eq H; auto.
Qed.

Lemma nth_safe_In :
  forall l n H, In (nth_safe l n H) l.
Proof.
  intros. eapply nth_error_In. rewrite nth_safe_eq_nth_error. eauto.
Qed.

End In.

Hint Resolve In_left_app In_right_app : datatypes.
Hint Resolve not_in_app_or not_in_or_app : datatypes.
Hint Resolve nth_error_In nth_safe_In : datatypes.

(*** Membership predicate and map ***)

Lemma image_In_map :
  forall (A B:Set) x l (f:A->B),
    In x l -> In (f x) (map f l).
Proof.
  intros. induction l; simpl in * . tauto. destruct H; subst; tauto.
Qed.

Lemma In_map_exists :
  forall (A B:Set) l y (f:A->B),
    In y (map f l) -> exists x, y = f x /\ In x l.
Proof.
  intros. induction l; simpl in * . tauto. destruct H. eauto. firstorder.
Qed.

Ltac elim_In_map H x Eq Mem :=
  let tmp := fresh "tmp" in (
    try rename H into tmp;
    elim (In_map_exists _ _ _ tmp); intro x; destruct 1 as [Eq Mem];
    try clear tmp
  ).

Ltac elim_all_In_map :=
  repeat match goal with
           | H : In ?y (map ?f ?l) |- _ =>
             let Eq := fresh "Eq" with tmp := fresh "tmp" in (
               rename H into tmp;
               elim (In_map_exists _ _ _ tmp); intro; destruct 1 as [Eq Mem];
               clear tmp
             )
         end.

(*** Membership function ***)

Section list_mem.
Variable A : Set.
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).
Implicit Types x : A.
Implicit Types xs l : list A.

Ltac case_eq foo :=
  generalize (refl_equal foo);
  pattern foo at -1;
  case foo.

Notation list_mem := (list_mem eq_dec).

Lemma list_mem_implies_In :
  forall x l, Is_true (list_mem x l) -> In x l.
Proof.
  intros. induction l. assumption. simpl in *; destruct (eq_dec a x); tauto.
Qed.
Lemma list_mem_false_implies_not_In :
  forall x l, list_mem x l = false -> ~In x l.
Proof.
  intros. induction l; simpl in * . tauto.
  destruct (eq_dec a x). discriminate. tauto.
Qed.
Lemma case_list_mem_In :
  forall x l, if list_mem x l then In x l else ~In x l.
Proof.
  intros; induction l; simpl in * . tauto.
  destruct (eq_dec a x). tauto. destruct (list_mem x l); tauto.
Qed.
Lemma list_mem_eq_In_dec :
  forall x l, list_mem x l = if In_dec eq_dec x l then true else false.
Proof.
  intros. assert (If := case_list_mem_In x l).
  destruct (list_mem x l); destruct (In_dec eq_dec x l); tauto.
Qed.

Lemma In_implies_list_mem :
  forall x l, In x l -> Is_true (list_mem x l).
Proof.
  intros. induction l. assumption.
  simpl in *; destruct (eq_dec a x); simpl; tauto.
Qed.
Lemma not_In_implies_list_mem_false :
  forall x l, ~In x l -> list_mem x l = false.
Proof.
  intros. induction l; simpl in * . tauto. destruct (eq_dec a x); tauto.
Qed.

Lemma list_mem_app :
  forall x l l', list_mem x (l++l') = list_mem x l || list_mem x l'.
Proof.
  intros; repeat rewrite list_mem_eq_In_dec;
    repeat match goal with |- context C [In_dec ?eq_dec_ ?x_ ?l_] =>
             destruct (In_dec eq_dec_ x_ l_)
           end;
    intros; try ring; elimtype False;
    (let a := type of i in (generalize dependent i; fold (~a)));
    auto with datatypes.
Qed.

Lemma nth_error_mem :
  forall l n x, nth_error l n = Some x -> Is_true (list_mem x l).
Proof. intros; apply In_implies_list_mem. eapply nth_error_In; eauto. Qed.
Lemma nth_safe_mem :
  forall l n H, Is_true (list_mem (nth_safe l n H) l).
Proof. intros; apply In_implies_list_mem. apply nth_safe_In; auto. Qed.

End list_mem.

Hint Rewrite list_mem_app : lists.

(*** Removing an element ***)

Section list_minus.
Variable A : Set.
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).
Implicit Types x : A.
Implicit Types xs l : list A.

Notation list_minus := (list_minus eq_dec).

Lemma not_In_list_minus_self :
  forall l x, ~In x (list_minus l (x::nil)).
Proof.
  induction l; intros; simpl in * . tauto.
  destruct (eq_dec x a); simpl in *; firstorder.
Qed.

Lemma In_list_plus :
  forall x l l', In x (list_minus l l') -> In x l.
Proof.
  induction l; intros; simpl in * . assumption.
  destruct (list_mem eq_dec a l'); simpl in *; firstorder.
Qed.

Lemma In_list_minus_other :
  forall l x x', x' <> x -> In x l -> In x (list_minus l (x'::nil)).
Proof.
  induction l; intros; simpl in * . assumption.
  destruct (eq_dec x' a); subst; simpl in * .
  apply IHl; tauto.
  destruct H0. tauto. auto.
Qed.

End list_minus.

Hint Resolve In_list_plus : In_list_plus.
Hint Resolve In_list_minus_other : datatypes.


Require Import Utf8.
Require Import IxFree.Base IxFree.UnaryFixpoint.

Require Import Arith.
Require Import Omega.

Definition IRel_2 {A : Type} (P : A → Type) := ∀ x, IRel_1 (P x).
Definition True_2 {A : Type} {P : A → Type} : IRel_2 P := λ _, True_1.

Program Definition contractive_2 {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :=
  ∀ (n : nat) (R₁ R₂ : IRel_2 P),
  (∀ k, k < n → ∀ x y, (k ⊨ R₁ x y) <-> (k ⊨ R₂ x y)) →
  ∀ x y, (n ⊨ f R₁ x y) <-> (n ⊨ f R₂ x y).

Fixpoint pow_IRel_2 {A : Type} {P : A → Type}
    (f : IRel_2 P → IRel_2 P) (n : nat) (R₀ : IRel_2 P) :=
  match n with
  | 0   => R₀
  | S n => f (pow_IRel_2 f n R₀)
  end.

Lemma pow_IRel_2_limit {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
  contractive_2 f → ∀ k n m : nat, k ≤ n → k ≤ m → ∀ x y,
  ((k ⊨ f (pow_IRel_2 f n True_2) x y) <->
   (k ⊨ f (pow_IRel_2 f m True_2) x y)).
Proof.
  intro Hcon.
  apply (well_founded_ind lt_wf (λ k, ∀ n m, k ≤ n → k ≤ m → ∀ x y, (_ : Prop))).
  intros k HI n m H₁ H₂ x y ; destruct k.
  + apply Hcon ; intros ; omega.
  + apply Hcon ; intros l Hl.
    destruct n ; [ exfalso ; omega | ].
    destruct m ; [ exfalso ; omega | ].
    apply HI ; omega.
Qed.

Definition I_fix_2_func {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
    ∀ x, P x → nat → Prop :=
  λ x y n, n ⊨ f (pow_IRel_2 f n True_2) x y.

Lemma I_fix_2_func_monotone {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
  contractive_2 f → ∀ x y, monotone (I_fix_2_func f x y).
Proof.
  intros Hcon x y n ; induction n.
  + unfold I_fix_2_func ; simpl.
    intro H₁; apply (Hcon 0 True_2 (f True_2)).
    - intros k H; inversion H.
    - apply I_valid_monotone_S; assumption.
  + unfold I_fix_2_func.
    intro H₁; apply (Hcon (S n)
        (pow_IRel_2 f (S n) True_2) (pow_IRel_2 f (S (S n)) True_2)).
    - intros; apply pow_IRel_2_limit; trivial; omega.
    - apply I_valid_monotone_S; assumption.
Qed.

Definition I_fix_2 {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  IRel_2 P :=
  λ x y, mk_IProp (I_fix_2_func f x y) (I_fix_2_func_monotone f p x y).

Lemma I_fix_2_is_fixpoint {A : Type} {P : A → Type}
  (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  ∀ x y n, (n ⊨ I_fix_2 f p x y) <-> (n ⊨ f (I_fix_2 f p) x y).
Proof.
  intros x y n; apply iff_trans with (B := (n ⊨ f (pow_IRel_2 f n True_2) x y)).
  { split; intro H; [ apply I_valid_elim in H | apply I_valid_intro ]; auto. }
  apply p; intros k Hle x' y'.
  destruct n; [ omega | ]; simpl.
  apply iff_trans with (B := (k ⊨ f (pow_IRel_2 f k True_2) x' y')).
  { apply pow_IRel_2_limit; trivial; omega. }
  split; intro H; [ apply I_valid_intro | apply I_valid_elim in H ]; auto.
Qed.

Lemma I_fix_2_unroll {A : Type} {P : A → Type}
  (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  ∀ x y n, (n ⊨ I_fix_2 f p x y) → (n ⊨ f (I_fix_2 f p) x y).
Proof.
apply I_fix_2_is_fixpoint.
Qed.

Lemma I_fix_2_roll {A : Type} {P : A → Type}
  (f : IRel_2 P → IRel_2 P) (p : contractive_2 f) :
  ∀ x y n, (n ⊨ f (I_fix_2 f p) x y) → (n ⊨ I_fix_2 f p x y).
Proof.
apply I_fix_2_is_fixpoint.
Qed.


Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.

Definition Assertion := state -> Prop.

(* assertion is a proposition/property of a state *)

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Declare Scope hore_spec_scope.
Notation "P ->> Q" := (assert_implies P Q)
                        (at level 80) : hoare_spec_scope.

Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition Aexp : Type := state -> nat.

Definition assert_of_Prop (P : Prop) : Assertion := fun _ => P.
Definition Aexp_of_nat (n : nat) : Aexp := fun _ => n.

Definition Aexp_of_aexp (a : aexp) : Aexp := fun st => aeval st a.

Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.

Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.

Declare Scope assertion_scope.
Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.

Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).

Notation "~ P" := (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q" := (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q" := (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q" := (fun st => assert P st ->  assert Q st) : assertion_scope.
Notation "P <-> Q" := (fun st => assert P st <->  assert Q st) : assertion_scope.
Notation "a = b" := (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b" := (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b" := (fun st => mkAexp a st <= mkAexp b st) : assertion_scope.
Notation "a < b" := (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b" := (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b" := (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b" := (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b" := (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b" := (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

Definition ap {X} (f : nat -> X) (x : Aexp) :=
  fun st => f (x st).

Definition ap2 {X} (f : nat -> nat -> X) (x : Aexp) (y : Aexp) (st : state) :=
  f (x st) (y st).

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
     st =[ c ]=> st'  ->
     P st  -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c custom com at level 99)
  : hoare_spec_scope.

Theorem hoare_post_true :
  forall (P Q : Assertion) c,
  (forall st, Q st) -> {{P}} c {{Q}}.
Proof.
  intros.
  unfold hoare_triple.
  intros. apply H.
Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~ (P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros. unfold hoare_triple. intros.
  apply H in H1. inversion H1.
Qed.

(* The goal of Hoare logic is
to provide a compositional method
for proving the validity of specific Hoare triples.*)

Definition assn_sub X a (P:Assertion) : Assertion :=
  fun (st : state) =>
    P (X !-> aeval st a ; st).

Notation "P [ X |-> a ]" := (assn_sub X a P)
  (at level 10, X at next level, a custom com).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} X := a {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple, "->>".
  intros P P' Q c Hhoare Himp st st' Heval Hpre.
  apply Hhoare with (st := st).
  - assumption.
  - apply Himp. assumption.
Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple, "->>".
  intros P Q Q' c Hhoare Himp st st' Heval Hpre.
  apply Himp.
  apply Hhoare with (st := st).
  - assumption.
  - assumption.
Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Htriple Hpre Hpost.
  apply hoare_consequence_pre with (P' := P').
  - apply hoare_consequence_post with (Q' := Q').
    + assumption.
    + assumption.
  - assumption.
Qed.

Hint Unfold assert_implies hoare_triple assn_sub t_update : core.
Hint Unfold assert_of_Prop Aexp_of_nat Aexp_of_aexp : core.

Theorem hoare_skip : forall P,
     {{P}} skip {{P}}.
Proof.
  intros P st st' H HP. inversion H; subst. assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1; c2 {{R}}.
Proof.
  unfold hoare_triple.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  eapply H1; try (repeat eassumption).
  eapply H2; try (repeat eassumption).
Qed.


Require Import Coq.Strings.String.
Require Import Arith.EqNat.
Require Import ZArith.

From QuickChick Require Import QuickChick.

Require Import TestingCommon.
Require Import Printing.
Require Import Shrinking.
Require Import Generation.

Open Scope string_scope.

Require Import Reachability.

Definition is_low_state st lab := isLow (pc_lab (st_pc st)) lab.

Definition propSSNI_helper (t : table) (v : Variation) : Checker  :=
    let '(Var lab st1 st2) := v in
    (*  Checker.trace (Show.show lab ++ Show.nl ++
     showStatePair lab frameMap1 frameMap2 st1 st2) *)
    collect (option_bind opcode_of_instr
                         (instr_lookup (st_imem st1) (st_pc st1)))

    (* collect (show lab) *)
            (if indist lab st1 st2 then
               (* XXX Our generator should always give us this by design.
                  If that's not the case the generator is broken. *)
               match fstep t st1  with
                 | Some st1' =>
                   if is_low_state st1 lab then
                     match fstep t st2 with
                       | Some st2' =>
                         collect "LOW -> *" (
(*
                                   whenFail
                                     ("LOW -> *" ++ nl ++
                                                 (show_execution lab [st1; st1'] [st2; st2']))
*)
                                     (indist lab st1' st2')(*:Gen QProp*))
                       | _ => (* 1 took a low step and 2 failed *)
                         collect "Second failed" (checker true)
                     (*
                ((Checker.trace (show_pair lab st1 st1'))
                (checker false))
                      *)
                     (* XXX This used to fail the checker in ICFP paper.
                  But here it does happen for Alloc, Store and BRet *)
                     end
                   else (* is_high st1 *)
                     if is_low_state st1' lab then
                       match fstep t st2 with
                         | Some st2' =>
                           if is_low_state st2' lab then
                             collect "HIGH -> LOW" (
(*
                                       whenFail ("HIGH -> LOW" ++ Show.nl ++
                                                                (show_execution lab [st1; st1'] [st2; st2']))
*)
                                                 (indist lab st1' st2') (* : Gen QProp *)
                                     )
                           else collect "Second not low" (checker true)
                         (* This can happen; it's just a discard *)
                         (* TODO: could check that st2' `indist` st1 *)
                         | _ => collect "Second failed H" (checker true)
                       (* This can happen; it's just a discard *)
                       end
                     else
                       collect "HIGH -> HIGH" (
(*
                                 whenFail ("HIGH -> HIGH" ++ Show.nl ++
                                                          (show_pair lab st1 st1'))
*)
                                       (indist lab st1 st1')
                               (*: Gen QProp*))
                 | _ => collect "Failed" (checker true)
               (* This can happen; it's just a discard *)
               (* TODO: could check if st2 does a H -> H step *)
               end
             else collect "Not indist!" (checker true)).
           (* XXX this should never happen with a correct generator;
              and prop_generate_indist already tests this;
              so this should either go away or become (propery false) *)

  Definition propSSNI t : Checker :=
    forAllShrinkShow gen_variation_state (fun _ => nil) (fun _ => ""%string)
      (* shrinkVState *)
      (propSSNI_helper t).


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.
Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Import ListNotations. (* from List *)

Require Import Coq.Bool.Bool.
Require Import Coq.Classes.SetoidClass.
Open Scope equiv_scope.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Logic.Decidable.
Set Implicit Arguments.
Set Strict Implicit.

Require Import Oqarina.formalisms.Expressions.Propositions.
Require Import Oqarina.CoqExt.all.
(*| .. coq:: |*)

(*| .. coq:: none |*)
Section Specifications.
(*| .. coq:: |*)

(*|
Specification
=============

In the following, we provide a definition of a specification theory adapted from :cite:`10.1007/978-3-642-28872-2_3`,

Informally, given a class S of specifications, a specification theory includes a composition operator :coq:`×` to combine specifications to larger ones. Additionally, a specification theory has a refinement relation :coq:`≤` to relate “concrete” and “abstract” specifications. This relation defines a preorder, i.e., it is transitive and reflexive.
To obtain a specification theory, refinement must be compositional in the sense that it must be preserved by the composition operator.

|*)

(*| For a given type :coq:`T`, we define the concept of a model. A
model is equipped with a :coq:`valid` function that asserts model
validity, it is a decidable proposition. |*)

Class Model (T : Type) := {
    valid : T -> Prop;
    valid_decidable : forall (t : T), Decision (valid t);
}.

(*| For a given type :coq:`T`, we define the concept of a refinement. A
refinement is a relation that is also a preorder, that is reflexive and transitive. |*)

Class Refinement (T : Type) := {
    refinement : relation T ;
    refinement_preorder : PreOrder refinement
}.
Notation "s1 ≼ s2" := (refinement s1 s2)
    (at level 70, no associativity).

(*| For a given type :coq:`T`, we define the notion of composition.
The :coq:`compose` operator is commutative and associative.
Composition is connected to the notion of refinment through a
compatibility relation. |*)

Class Composition (T : Type) `{Refinement T} `{Setoid T} := {
    compose: T -> T -> T;

    compose_comm :> Setoid_Commutative compose;
    compose_assoc :> Setoid_SemiGroup compose;
    compose_compatible : forall S1 S2 T1 T2,
        S1 ≼ S2 -> T1 ≼ T2 -> (compose S1 T1) ≼ (compose S2 T2);
}.

(*| From these considerations, we can now define the :coq`Specification`
typeclass, equipped with a refinement and a composition operation. |*)

Class Specification (T : Type) `{s : Setoid T} := {
    m :> Model T;
    refinement_op :> Refinement T;
    compose_op :> Composition;
}.

(*| In :cite:`10.1007/978-3-642-28872-2_3`, the authors only consider composition operator as total function. We acknowledge that this is a strong hypothesis: semantic or syntactic rules may forbid some compositions to happem, or they might be incomplete. A typical example being two AADL components being composed: composition can be done in multiple ways, e.g. variations in connections, as subcomponents of different components, etc. Instead, we define a composition operation as a partial function. Partial composition is commutative and compatible with the notion of refinement. |*)

Class Partial_Composition (T : Type)  `{Refinement T} := {
    partial_compose: list T -> T -> Prop ;

    partial_compose_comm : forall (l l': list T) S,
        partial_compose l S
            -> Permutation l l'
            -> partial_compose l' S;

    partial_compose_compatible: forall S1 S2 T1 T2 R,
        S1 ≼ S2 -> T1 ≼ T2
            -> partial_compose [S2 ;T2] R
            -> partial_compose [S1 ;T1] R;
}.

(*| From these considerations, we can now define the :coq:`Rich_Specification` typeclass, equipped with a refinement and a partial composition operation. We call this "rich" as a partial composition is a natural consequence of rich modeling languages. |*)

Class Rich_Specification (T : Type) `{s : Setoid T} := {
    r :> Model T;
    r_refinement_op :> Refinement T;
    r_compose_op :> Partial_Composition;
}.

(*| .. coq:: none |*)
End Specifications.
(*| .. coq:: |*)

(*| We encapsulate the following notations to ease model
manipulation. |*)

Module Specifications_Notations.

Notation "s1 '×' s2" := (compose s1 s2)
    (at level 70, right associativity).

Notation "s3 |=c s1 '×' s2" := (partial_compose [s1 ;s2 ] s3)
    (at level 70, right associativity).

Notation "s1 ≼ s2" := (refinement s1 s2)
    (at level 70, no associativity).

End Specifications_Notations.

(*| .. coq:: none |*)
Section Specifications_PropF.

Import Specifications_Notations.
(*| .. coq:: |*)

(*|
Specification -- PropF
======================

In this section, we provide an instantiation of the previous
classes for propositions (see :coq:`PropF`). We build incrementally the notion of model (i.e. a PropF), of a refinement, and of a composition. |*)

Variable PropVars : Set.

(* A PropF is always valid, per construction of the Coq syntax. *)
Definition Valid_PropF (P : PropF PropVars) := True.

Lemma Valid_PropF_decidable: forall t : PropF PropVars,
    Decision (Valid_PropF t).
Proof.
    intros. compute. intuition.
Qed.

Instance Models_PropF : Model (PropF PropVars) := {
    valid := Valid_PropF;
    valid_decidable := Valid_PropF_decidable;
}.

Definition PropF_equiv (p1 p2: PropF PropVars) :=
    forall v, Eval_PropF v p1 = Eval_PropF v p2.

Lemma PropF_equiv_Reflexive : Reflexive PropF_equiv.
Proof.
    unfold Reflexive, PropF_equiv.
    intuition.
Qed.

Lemma PropF_equiv_Symetric: Symmetric PropF_equiv.
Proof.
    unfold Symmetric, PropF_equiv.
    intuition.
Qed.

Lemma PropF_equiv_Transitive: Transitive PropF_equiv.
Proof.
    unfold Transitive, PropF_equiv.
    intros.
    specialize (H v).
    specialize (H0 v).
    rewrite H.
    intuition.
Qed.

Instance Setoid_PropF : Setoid (PropF PropVars) := {
    equiv := PropF_equiv;
    setoid_equiv :=
        Build_Equivalence _ PropF_equiv_Reflexive
            PropF_equiv_Symetric PropF_equiv_Transitive ;
}.

(* P1 refines P2 iff P2 => P1. *)

Definition Refinement_PropF' (P1 P2: PropF PropVars) :=
    forall v, sat_PropF v P2 -> sat_PropF v P1.

Lemma Refinement_PropF_Reflexive : forall P1,
    Refinement_PropF' P1 P1.
Proof.
    unfold Refinement_PropF'. intuition.
Qed.

Lemma Refinement_PropF_Transitive : forall P1 P2 P3,
    Refinement_PropF' P1 P2
        -> Refinement_PropF' P2 P3
        -> Refinement_PropF' P1 P3.
Proof.
    unfold Refinement_PropF'. intuition.
Qed.

Instance Refinement_PropF : Refinement (PropF PropVars) := {
    refinement := Refinement_PropF';
    refinement_preorder :=
        Build_PreOrder _ Refinement_PropF_Reflexive Refinement_PropF_Transitive;
}.

(* The composition of two PropF is their conjunction. *)

Definition compose_PropF (p1 p2: PropF PropVars) :=
    (Conj p1 p2).

Lemma compose_PropF_comm: forall (p1 p2: PropF PropVars),
    (compose_PropF p1 p2) == (compose_PropF p2 p1).
Proof.
    unfold compose_PropF. simpl.
    unfold PropF_equiv. simpl.
    intros.
    rewrite andb_comm. intuition.
Qed.

Instance compose_PropF_Setoid_Commutative :
    Setoid_Commutative compose_PropF  := {
    commute_proof := compose_PropF_comm;
}.

Lemma compose_PropF_assoc: forall (p1 p2 p3: PropF PropVars),
    compose_PropF p1 (compose_PropF p2 p3) ==
        compose_PropF (compose_PropF p1 p2) p3.
Proof.
    unfold compose_PropF. simpl.
    unfold PropF_equiv. simpl.
    intros.
    rewrite andb_assoc. intuition.
Qed.

Instance compose_PropF_Setoid_SemiGroup :
    Setoid_SemiGroup compose_PropF := {
    assoc_f := compose_PropF_assoc;
}.

Lemma compose_PropF_compatible : forall (S1 S2 T1 T2 : PropF PropVars),
    S1 ≼ S2 -> T1 ≼ T2 ->
        (compose_PropF S1 T1) ≼ (compose_PropF S2 T2).
Proof.
    unfold compose_PropF. unfold refinement. simpl.
    unfold Refinement_PropF'.
    intros.
    rewrite sat_PropF_and_rewrite in *.
    split.
    - apply H. intuition.
    - apply H0. intuition.
Qed.

Instance Composition_PropF : Composition := {
    compose := compose_PropF ;
    compose_compatible := compose_PropF_compatible ;
    compose_assoc := compose_PropF_Setoid_SemiGroup ;
    compose_comm := compose_PropF_Setoid_Commutative ;
}.

(*| Finally, we can combine all results and build a valid instance of
a specification from PropF.|*)

Instance Specification_PropF : Specification := {
    m := Models_PropF;
    refinement_op := Refinement_PropF ;
    compose_op := Composition_PropF;
}.

(*| .. coq:: none |*)
End Specifications_PropF.


From Undecidability.L Require Export L.

(** * Step-indexed interpreter and modesty *)

(** ** Step-indexed interpreter *)

Fixpoint eval (n : nat) (u : term) :=
  match u with
  | var n => None
  | lambda s => Some (lambda s)
  | app s t => match n with
           | 0   => None
           | S n => match eval n s, eval n t with
                    | Some (lambda s), Some t => eval n (subst s 0 t)
                    |   _ , _ => None
                    end
            end
  end.

Lemma eval_S n s t : eval n s = Some t -> eval (S n) s = Some t.
Proof.
  revert s t; induction n; intros; cbn in H;
    repeat (destruct _ eqn:_; subst; try congruence; eauto).
    remember (S n) as n'; cbn; subst.
    now rewrite (IHn _ _ E), (IHn _ _ E0), (IHn _ _ H).
Qed.

Lemma eval_step s s' t n : s ≻ s' -> eval n s' = Some t -> eval (S n) s = Some t.
Proof.
  revert s s' t; induction n; intros.
  - cbn in H0. destruct _; inv H0.
    cbn. destruct _; inv H. now rewrite H3.
  - cbn in H0. inv H; repeat (destruct _ eqn:_; subst; try congruence).
    + cbn; now rewrite E, E0, E1.
    + cbn; now rewrite E.
    + remember (S n); cbn; subst.
      erewrite eval_S, IHn; eauto. now eapply eval_S.
    + remember (S n). cbn. subst.
      erewrite IHn, eval_S; eauto. now eapply eval_S.
Qed.

Lemma evaluates_eval s t : evaluates s t -> exists n, eval n s = Some t.
Proof.
  intros [A B] % evaluates_equiv. eapply equiv_star_lam in A; eauto. induction A.
  - destruct B. subst; now exists 0.
  - destruct (IHA B) as [k C]. eauto using eval_step.
Qed.

Lemma eval_evaluates n s t : eval n s = Some t -> evaluates s t.
Proof.
  revert s t; induction n; intros.
  - inv H. destruct _; try congruence. inv H1. firstorder.
  - inv H. repeat (destruct _ eqn:_; subst; try congruence).
    eapply IHn in E. eapply IHn in E0. eapply IHn in H1. eauto. inv H1. eauto.
Qed.

Lemma equiv_eval s t : lam t -> s ≡ t -> exists n, eval n s = Some t.
Proof.
  intros. eapply evaluates_eval. firstorder using evaluates_equiv.
Qed.

Lemma eval_equiv s s' n : eval n s = Some s' -> s ≡ s'.
Proof.
  intros ? % eval_evaluates. firstorder using evaluates_equiv.
Qed.

Lemma eval_lambda n s t : eval n s = Some t -> lam t.
Proof.
  intros ? % eval_evaluates. firstorder using evaluates_equiv.
Qed.

(** ** Modesty *)

Require Import DecidableRecognisable Encodings Coq.Logic.ConstructiveEpsilon.

Definition cChoice := constructive_indefinite_ground_description_nat_Acc.
Lemma computable_eva s : eva s -> { v | s ▷ v }.
Proof.
  intros.
  assert (exists n v, eval n s = Some v) by (destruct H as (? & ? % evaluates_eval); firstorder).
  eapply cChoice in H0 as []. destruct (eval x s) eqn:E.
  - exists t. eauto using eval_evaluates.
  - exfalso. firstorder congruence.
  - intros. destruct (eval n s). eauto.
    right. intros []. congruence.
Defined.

Lemma dec_pdec p : decidable p -> forall x, p x \/ ~ p x.
Proof.
  firstorder.
Qed.

Lemma decidable_dec p : decidable p -> exists f, forall s, f s = true <-> p s.
Proof with try tauto; try (eexists; reflexivity).
  intros (u & proc_u & Hu).
  assert (forall s, {v | u (tenc s) ▷ v}). {
    intros. eapply computable_eva. destruct (Hu s). exists T. tauto.
    exists F; tauto.
  }

  exists (fun s =>  let (v, _) := H s in if decision (v = T) then true else false).

  intros. destruct _. decide (x = T).
  - subst. firstorder. eapply decidable_spec; eauto.
  - firstorder. congruence. exfalso. eapply decidable_spec; eauto.
    destruct (Hu s) as [ [? [H4 ?] %evaluates_equiv] | []].
    destruct T_equiv_F.
    assert (x ≡ T) by now rewrite <- e, <- H4. eapply unique_normal_forms in H6. subst. congruence.
    eapply evaluates_abst; eauto. value. firstorder using evaluates_equiv.
Qed.

Fixpoint unenc s :=
match s with
| lambda (lambda 1) => Some 0
| lambda (lambda (app 0 s)) => match unenc s with Some n => Some (S n) | x=>x end
| _ => None
end.

Lemma unenc_correct m : (unenc (enc m)) = Some m.
Proof.
  induction m; simpl; now try rewrite IHm.
Qed.

Lemma unenc_correct2 t n : unenc t = Some n -> enc n = t.
Proof.
  revert n. eapply (size_induction (f := size) (p := (fun t => forall n, unenc t = Some n -> enc n = t))). clear t. intros t IHt n H.
  destruct t; try now inv H.
  destruct t; try now inv H.
  destruct t; try now inv H.
  destruct n0; try now inv H. destruct n0; try now inv H.
  destruct t1; try now inv H. destruct n0; try now inv H.
  simpl in H. destruct (unenc t2) eqn:A.
  specialize (IHt t2).
  assert (B : size t2 < size (lambda (lambda 0 t2))). simpl. omega.
  eapply IHt in B.
  destruct n. inv H. inversion H. subst n0.
    simpl. repeat f_equal. eassumption. eassumption. inv H.
Qed.

Fixpoint decode (s : term) :=
  match s with
  | lambda (lambda (lambda (app (var 2) t))) => match unenc t with Some n => Some (var n) | None => None end
  | lambda (lambda (lambda (app (app (var 1) s) t))) => match decode s, decode t with
                        | Some s, Some t => Some (s t)
                        | _, _ => None
                        end
  | lambda (lambda (lambda (app (var 0) s))) => match decode s with
                      | Some s => Some (lambda s)
                      | None => None
                                end
  | _ => None
  end.

Lemma decode_correct t : (decode (tenc t)) = Some t.
Proof.
  induction t; simpl.
  - now rewrite unenc_correct.
  - now rewrite IHt1, IHt2.
  - now rewrite IHt.
Qed.

Lemma decode_correct2 s t :
  decode s = Some t -> tenc t = s.
Proof.
  revert t. eapply (size_induction (f := size) (p := (fun s => forall t, decode s = Some t -> tenc t = s))).
  clear s. intros s IHs t H.
  destruct s; try now inv H.
  destruct s; try now inv H.
  destruct s; try now inv H.
  destruct s; try now inv H.
  destruct s1; try now inv H.
  destruct n as [ | [ | [] ] ]; try now inv H.
  - cbn in *. destruct (decode s2) eqn:E; inv H.
    eapply IHs in E; try omega. cbn. now rewrite E.
  - cbn in *. destruct (unenc s2) eqn:E; inv H.
    eapply unenc_correct2 in E. now rewrite <- E.
  - destruct s1_1; try now inv H. destruct n as [ | [] ]; try now inv H.
    cbn in *. destruct _ eqn:E1; inv H. destruct _ eqn:E2; inv H1. eapply IHs in E1; try omega.
    eapply IHs in E2; try omega. cbn. now rewrite <- E1, <- E2.
Qed.

Lemma L_computable_computable u :
  (forall s, exists t, u (tenc s) ▷ tenc t) -> { f | forall s, u (tenc s) ▷ tenc (f s)}.
Proof.
  intros H.
  assert (forall s, eva (u (tenc s))). intros. destruct (H s) as [t H1]. eauto.
  exists (fun s => match decode (proj1_sig (computable_eva (H0 s))) with Some t => t | None => 0 end).

  intros s.
  destruct (H s) as [t Ht].
  destruct computable_eva. cbn.
  enough (x = tenc t).
  - subst. now erewrite decode_correct.
  - eapply unique_normal_forms. now eapply evaluates_abst in e. value.
    now rewrite <- Ht, <- e.
Defined.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer .
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import TLCBuffer
     UnionFind01Data UnionFind04Compress.

(* We now define an inductive predicate that encodes the process of performing
   path compression iteratively along a path, up to the root. [ipc] stands for
   ``iterative path compression''. The predicate [ipc F x l F'] means that in
   the initial state [F], performing path compression along the path that
   begins at [x] leads in [l] steps to the final state [F']. *)

(* We define backward and forward variants of this predicate, [bw_ipc] and
   [fw_ipc].

   The forward variant corresponds intuitively to a two-pass algorithm, where
   the first pass finds the representative [z], and the second pass performs
   iterated path compression. This formulation is clearly the sequential
   composition of several path compression steps. For this reason, this
   formulation is more amenable to a simple proof of several lemmas (e.g.
   [amortized_cost_fw_ipc_preliminary] and [is_rdsf_fw_ipc]).

   The backward variant corresponds intuitively to the one-pass, recursive
   formulation of path compression, where path compression is performed as the
   stack is unwound. This formulation is *not* clearly the sequential
   composition of several path compression steps, because it is not obvious
   a priori that the representative of [x] before compression is the
   representative of [x] after compression.

   Naturally, the two predicates are in fact equivalent. *)

Inductive bw_ipc V (F : binary V) : V -> nat -> binary V -> Prop :=
| BWIPCBase:
    forall x,
    is_root F x ->
    bw_ipc F x 0 F
| BWIPCStep:
    forall F' F'' x y z l,
    F x y ->
    is_repr F y z ->
    bw_ipc F y l F' ->
    F'' = compress F' x z ->
    bw_ipc F x (S l) F''.

Inductive fw_ipc V : binary V -> V -> nat -> binary V -> Prop :=
| FWIPCBase:
    forall F x,
    is_root F x ->
    fw_ipc F x 0 F
| FWIPCStep:
    forall (F : binary V) F' x y z l,
    F x y ->
    is_repr F y z ->
    fw_ipc (compress F x z) y l F' ->
    fw_ipc F x (S l) F'.

Hint Constructors bw_ipc : bw_ipc.
Hint Constructors fw_ipc : fw_ipc.

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

(* Provided there is no path from [y] to [x], forward iterative compression at
   [y] commutes with one step of compression at [x]. *)

(* This statement should really be presented as a commutative diagram. *)

Lemma fw_ipc_compress_preliminary:
  forall V F x y z l F',
  @fw_ipc V F y l F' ->
  ~ path F y x ->
  fw_ipc (compress F x z) y l (compress F' x z).
Proof using.
  induction 1; intros.
  (* Base. *)
  { econstructor;
    eauto using compress_preserves_roots_other_than_x, not_rtclosure_inv_neq. }
  (* Step. *)
  { forwards: IHfw_ipc.
    (* The assumption that there is no path from [y] to [x] remains true as we move
       from [y] to its successor and perform one step of compression at [y]. *)
    { eauto 6 using compress_preserves_paths_converse, is_repr_path with rtclosure. }
    (* The assumption that there is no path from [y] to [x] gives us the fact that
       [y] and [x] are distinct. It is used twice below. *)
    forwards: not_rtclosure_inv_neq; eauto.
    econstructor.
    { eauto using compress_preserves_other_edges. }
    { eauto using compress_preserves_is_repr_weak with rtclosure. }
    { rewrite compress_compress by eauto. assumption. }}
Qed.

(* A corollary of the previous lemma. *)

Lemma fw_ipc_compress:
  forall V D F x y z l F',
  @is_dsf V D F ->
  F x y ->
  is_repr F y z ->
  fw_ipc F y l F' ->
  fw_ipc (compress F x z) y l (compress F' x z).
Proof using.
  eauto using fw_ipc_compress_preliminary, acyclicity with tclosure.
Qed.

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

(* Provided there is no path from [y] to [x], backward iterative compression at
   [y] commutes with one step of un-compression at [x]. *)

(* This statement should really be presented as a commutative diagram. *)

Lemma bw_ipc_compress_preliminary:
  forall V Fxz y l Fxz',
  @bw_ipc V Fxz y l Fxz' ->
  forall F x z,
  Fxz = compress F x z ->
  ~ path F y x ->
  exists F',
  Fxz' = compress F' x z /\
  bw_ipc F y l F'.
Proof using.
  induction 1; intros; subst.
  (* Base. *)
  { eexists. split. eauto.
    econstructor; eauto using compress_preserves_roots_converse. }
  (* Step. *)
  { (* The assumption that there is no path from [y] to [x] gives us the fact that
       [y] and [x] are distinct. *)
    forwards: not_rtclosure_inv_neq; eauto.
    (* This implies that the edge of [x] to [y], which exists after compression,
       already existed before compression. *)
    forwards: compress_preserves_other_edges_converse; eauto.
    forwards: IHbw_ipc.
      { eauto. }
      { eauto 6 using compress_preserves_paths_converse, is_repr_path with rtclosure. }
    unpack. subst. eexists. split.
    eapply compress_compress. { eauto. }
    econstructor;
      eauto 6 using compress_preserves_is_repr_weak_converse,
        compress_preserves_paths_converse, is_repr_path with rtclosure. }
Qed.

(* A corollary of the previous lemma. *)

Lemma bw_ipc_compress:
  forall V D F x y z l F'',
  @is_dsf V D F ->
  F x y ->
  is_repr F y z ->
  bw_ipc (compress F x z) y l F'' ->
  exists F',
  F'' = compress F' x z /\
  bw_ipc F y l F'.
Proof using.
  eauto using bw_ipc_compress_preliminary, acyclicity with tclosure.
Qed.

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

(* Equivalence between [fw_ipc] and [bw_ipc]. *)

Lemma bw_ipc_fw_ipc:
  forall V F x l F',
  @bw_ipc V F x l F' ->
  forall D,
  is_dsf D F ->
  @fw_ipc V F x l F'.
Proof using.
  induction 1; intros; subst; econstructor; eauto using fw_ipc_compress.
Qed.

Lemma fw_ipc_bw_ipc:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall D,
  is_dsf D F ->
  @bw_ipc V F x l F'.
Proof using.
  induction 1; intros; subst.
  { econstructor; eauto. }
  { forwards: IHfw_ipc.
      eauto using is_dsf_compress, is_repr_path.
    forwards: bw_ipc_compress; eauto. unpack.
    econstructor; eauto. }
Qed.

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

(* Iterative path compression, starting at an arbitrary vertex [x], is always
   possible. *)

(* I believe that this lemma may be useful in avoiding a chicken-and-egg
   problem. In the CFML proof of the OCaml code for iterative path
   compression, we must prove that we have enough credits for the code to
   operate. This requires arguing that the initial potential is high enough,
   using the lemma [amortized_cost_fw_ipc]. But this lemma has a hypothesis of
   the form [fw_ipc V F x l F'] -- that is, it requires proving, ahead of
   time, that iterative path compression terminates. *)

Lemma ipc_defined_preliminary:
  forall V D F,
  @is_dsf V D F ->
  forall x r,
  path F x r ->
  is_root F r ->
  exists l F',
  bw_ipc F x l F'.
Proof using.
  induction 2 using rtclosure_ind_l; intros.
  { repeat econstructor. eauto. }
  { forwards: IHrtclosure. eauto. unpack.
    do 2 eexists. eapply BWIPCStep; eauto with is_repr. }
Qed.

Lemma ipc_defined:
  forall V D F,
  @is_dsf V D F ->
  forall x,
  exists l F',
  bw_ipc F x l F'.
Proof using.
  intros.
  forwards [ r [ ? ? ]]: is_dsf_defined_is_repr x. eauto.
  eauto using ipc_defined_preliminary.
Qed.

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

(* Iterative path compression is a composition of several path compression
   steps, so it preserves the agreement between [R] and [F]. This property
   is easy to establish for [fw_ipc], and is then transported to [bw_ipc]. *)

Lemma fw_ipc_preserves_RF_agreement:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall R D,
  is_dsf D F ->
  fun_in_rel R (is_repr F) ->
  fun_in_rel R (is_repr F').
Proof using.
  induction 1; eauto 6 using is_repr_path, is_dsf_compress, compress_R_compress_agree.
Qed.

Lemma bw_ipc_preserves_RF_agreement:
  forall V F x l F',
  @bw_ipc V F x l F' ->
  forall R D,
  is_dsf D F ->
  fun_in_rel R (is_repr F) ->
  fun_in_rel R (is_repr F').
Proof using.
  eauto using fw_ipc_preserves_RF_agreement, bw_ipc_fw_ipc.
Qed.