Require Import List.
Require Import Expr Env.
Require Import Prover.
Require Import Reflection.

Set Implicit Arguments.
Set Strict Implicit.

Local Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(** * The Assumption Prover **)

Section AssumptionProver.
  Variable types : list type.
  Variable fs : functions types.

  Definition assumption_summary : Type := list (expr types).

  Definition assumptionSummarize (hyps : list (expr types)) : assumption_summary := hyps.

  Fixpoint assumptionProve (hyps : assumption_summary)
    (goal : expr types) : bool :=
    match hyps with
      | nil => false
      | exp :: b => if expr_seq_dec exp goal
        then true
        else assumptionProve b goal
    end.

  Definition assumptionLearn (sum : assumption_summary) (hyps : list (expr types)) : assumption_summary :=
    sum ++ hyps.

  Definition assumptionValid (uvars vars : env types) (sum : assumption_summary) : Prop :=
    AllProvable fs uvars vars sum.

  Lemma assumptionValid_extensible : forall u g f ue ge,
    assumptionValid u g f -> assumptionValid (u ++ ue) (g ++ ge) f.
  Proof.
    unfold assumptionValid. eauto using AllProvable_weaken.
  Qed.

  Lemma assumptionSummarizeCorrect : forall uvars vars hyps,
    AllProvable fs uvars vars hyps ->
    assumptionValid uvars vars (assumptionSummarize hyps).
  Proof.
    auto.
  Qed.

  Lemma assumptionLearnCorrect : forall uvars vars sum,
    assumptionValid uvars vars sum -> forall hyps,
    AllProvable fs uvars vars hyps ->
    assumptionValid uvars vars (assumptionLearn sum hyps).
  Proof.
    unfold assumptionLearn, assumptionValid. intuition.
    apply AllProvable_app; auto.
  Qed.

  Theorem assumptionProverCorrect : ProverCorrect fs assumptionValid assumptionProve.
    t; induction sum; t.
  Qed.

  Definition assumptionProver : ProverT types :=
  {| Facts := assumption_summary
   ; Summarize := assumptionSummarize
   ; Learn := assumptionLearn
   ; Prove := assumptionProve
   |}.
  Definition assumptionProver_correct : ProverT_correct (types := types) assumptionProver fs.
  eapply Build_ProverT_correct with (Valid := assumptionValid);
    eauto using assumptionValid_extensible, assumptionSummarizeCorrect, assumptionLearnCorrect, assumptionProverCorrect.
  Qed.

End AssumptionProver.

Definition AssumptionProver : ProverPackage :=
{| ProverTypes := nil_Repr EmptySet_type
 ; ProverFuncs := fun ts => nil_Repr (Default_signature ts)
 ; Prover_correct := fun ts fs => assumptionProver_correct fs
|}.


Require Import FP.CoreData.
Require Import FP.Classes.

Import CoreDataNotation.
Import ClassesNotation.

Instance list_GUnit {A} : GUnit (list A) := { gunit := [] }.
Instance list_GTimes {A} : GTimes (list A) := { gtimes := app }.

Fixpoint list_cofold {X w} `{! Comonad w } {A} (f:X -> w A -> A) (aW:w A) (xs:list X) : A :=
  match xs with
  | [] => coret aW
  | x::xs =>
      let aW := codo aW => list_cofold f aW xs in
      f x aW
  end.
Instance list_Foldable {X} : Foldable X (list X) :=
  { cofold := @list_cofold X }.

Fixpoint list_coiter {X w} `{! Comonad w } {A} (f:w A -> X -> A) (aW:w A) (xs:list X) : A :=
  match xs with
  | [] => coret aW
  | x::xs =>
      let aW := codo aW => f aW x in
      list_coiter f aW xs
  end.
Instance list_Iterable {X} : Iterable X (list X) :=
  { coiter := @list_coiter X }.

Fixpoint list_mbuild {X m} `{! Monad m } (fld:forall {A}, (X -> A -> A) -> A -> m A) : m (list X) :=
  fld cons nil.
Instance list_Buildable {X} : Buildable X (list X) :=
  { mbuild := @list_mbuild X }.

Fixpoint list_sequence {u} `{! Applicative u } {A}
    (xs:list (u A)) : u (list A) :=
  match xs with
  | nil => fret nil
  | x::xs' => fret cons <@> x <@> list_sequence xs'
  end.
Instance list_Traversable : Traversable list :=
  { tsequence := @list_sequence }.


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Export nondet_bool.
From iris_examples.proph Require Import eager_coin_spec.
From iris_examples.proph.lib Require Import one_shot_proph.

(* Lazy implementation of the eager specification. The value of the coin is
unknown at the time of the creation of the coin. As a consequence, we rely on
a *one-shot* prophecy variable. *)

Definition new_lazy_coin : val :=
  λ: <>, (ref NONE, NewProph).

Definition read_lazy_coin : val :=
  λ: "cp",
  let: "c" := Fst "cp" in
  let: "p" := Snd "cp" in
  match: !"c" with
    NONE => let: "r" := nondet_bool #() in
           "c" <- SOME "r";; resolve_proph: "p" to: "r";; "r"
  | SOME "b" => "b"
  end.

Section proof.
  Context `{!heapG Σ}.

  Definition val_to_bool (v : val) : bool := bool_decide (v = #true).

  Lemma val_to_bool_of_bool (b : bool) :
    val_to_bool #b = b.
  Proof.
    by destruct b.
  Qed.

  Definition lazy_coin (cp : val) (b : bool) : iProp Σ :=
    (∃ (c : loc) (p : proph_id) (v : val),
        ⌜cp = (#c, #p)%V⌝ ∗
        (c ↦ SOMEV #b ∨ (c ↦ NONEV ∗ proph1 p v ∗ ⌜b = val_to_bool v⌝)))%I.

  Lemma lazy_coin_exclusive (cp : val) (b1 b2 : bool) :
    lazy_coin cp b1 -∗ lazy_coin cp b2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (c1 p1 v1) "[-> H1]".
    iDestruct "H2" as (c2 p2 v2) "[% H2]".
    simplify_eq.
    iDestruct "H1" as "[Hc1 | [Hc1 _]]";
    iDestruct "H2" as "[Hc2 | [Hc2 _]]";
    by iDestruct (mapsto_valid_2 with "Hc1 Hc2") as %?.
  Qed.

  Lemma new_lazy_coin_spec :
    {{{ True }}}
      new_lazy_coin #()
    {{{ c b, RET c; lazy_coin c b }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_lam.
    wp_apply wp_new_proph1; first done. iIntros (p v) "Hp".
    wp_alloc c as "Hc". wp_pair.
    iApply ("HΦ" $! (#c, #p)%V).
    iExists c, p, v. iSplit; first done. iRight. by iFrame.
  Qed.

  Lemma read_lazy_coin_spec cp b :
    {{{ lazy_coin cp b }}}
      read_lazy_coin cp
    {{{ RET #b; lazy_coin cp b }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p v ->) "[Hc | [Hc [Hp ->]]]".
    - wp_lam. wp_load. wp_match. iApply "HΦ".
      iExists c, p, #(). iSplit; first done. by iLeft.
    - wp_lam. wp_load. wp_match.
      wp_apply nondet_bool_spec; first done. iIntros (r) "_".
      wp_let. wp_store.
      wp_apply (wp_resolve1 with "Hp"); first done.
      wp_pures. iIntros "->". wp_pures.
      rewrite !val_to_bool_of_bool. iApply "HΦ".
      iExists c, p, #(). iSplit; first done. by iLeft.
  Qed.

End proof.

Definition lazy_coin_spec_instance `{!heapG Σ} :
  eager_coin_spec.eager_coin_spec Σ :=
  {| eager_coin_spec.new_coin_spec := new_lazy_coin_spec;
     eager_coin_spec.read_coin_spec := read_lazy_coin_spec;
     eager_coin_spec.coin_exclusive := lazy_coin_exclusive |}.

Typeclasses Opaque lazy_coin.


Require Export StlcIso.Inst.
Require Export StlcIso.SpecSyntax.
Require Export StlcIso.SpecTyping.
Require Export StlcIso.LemmasTyping.

(* a fully annotated version of iso-recursive terms. *)
Inductive TmA : Set :=
  | ia_var (i: Ix)
  | ia_abs (τ1 τ2 : Ty) (t: TmA)
  | ia_app (τ1 τ2 : Ty) (t₁ t₂ : TmA)
  | ia_unit
  | ia_true
  | ia_false
  | ia_ite (τ : Ty) (t₁ t₂ t₃: TmA)
  | ia_pair (τ1 τ2 : Ty) (t₁ t₂: TmA)
  | ia_proj₁ (τ1 τ2 : Ty) (t: TmA)
  | ia_proj₂ (τ1 τ2 : Ty) (t: TmA)
  | ia_inl (τ1 τ2 : Ty) (t: TmA)
  | ia_inr (τ1 τ2 : Ty) (t: TmA)
  | ia_caseof (τ1 τ2 τ : Ty) (t₁ t₂ t₃: TmA)
  | ia_seq (τ : Ty) (t₁ t₂: TmA)
  | ia_fold_ (τ : Ty) (t : TmA)
  | ia_unfold_ (τ : Ty) (t : TmA).

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.
  Context {vrTm: Vr TmA}.
  Context {liftYTm: Lift Y TmA}.

  Context {vrTy: Vr Ty}.
  Context {liftYTy: Lift Y Ty}.

  Fixpoint apTmA (ζ: Sub Y) (t: TmA) {struct t} : TmA :=
    match t with
      | ia_var x           => lift (ζ x)
      | ia_abs τ₁ τ₂ t        => ia_abs τ₁ τ₂ (apTmA (ζ↑) t)
      | ia_app τ₁ τ₂ t₁ t₂       => ia_app τ₁ τ₂ (apTmA ζ t₁) (apTmA ζ t₂)
      | ia_unit            => ia_unit
      | ia_true            => ia_true
      | ia_false           => ia_false
      | ia_ite τ t₁ t₂ t₃    => ia_ite τ (apTmA ζ t₁) (apTmA ζ t₂) (apTmA ζ t₃)
      | ia_pair τ₁ τ₂ t₁ t₂      => ia_pair τ₁ τ₂ (apTmA ζ t₁) (apTmA ζ t₂)
      | ia_proj₁ τ₁ τ₂ t         => ia_proj₁ τ₁ τ₂ (apTmA ζ t)
      | ia_proj₂ τ₁ τ₂ t         => ia_proj₂ τ₁ τ₂ (apTmA ζ t)
      | ia_inl τ₁ τ₂ t           => ia_inl τ₁ τ₂ (apTmA ζ t)
      | ia_inr τ₁ τ₂ t           => ia_inr τ₁ τ₂ (apTmA ζ t)
      | ia_caseof τ₁ τ₂ τ t₁ t₂ t₃ => ia_caseof τ₁ τ₂ τ (apTmA ζ t₁) (apTmA (ζ↑) t₂) (apTmA (ζ↑) t₃)
      | ia_seq τ t₁ t₂       => ia_seq τ (apTmA ζ t₁) (apTmA ζ t₂)
      (* | fixt τ₁ τ₂ t    => fixt τ₁ τ₂ (apTmA ζ t) *)
      | ia_fold_ τ t => ia_fold_ τ (apTmA ζ t)
      | ia_unfold_ τ t => ia_unfold_ τ (apTmA ζ t)
    end.

  Global Arguments apTmA ζ !t /.

End Application.

Reserved Notation "⟪  Γ ia⊢ t : T  ⟫"
  (at level 0, Γ at level 98, t at level 98, T at level 98 ).
Inductive AnnotTyping (Γ : Env) : TmA -> Ty -> Prop :=
  | ia_WtVar {i T} :
      ⟪ i : T r∈ Γ ⟫ →
      ⟪ Γ ia⊢ ia_var i : T ⟫
  | ia_WtAbs {t τ₁ τ₂} :
    ValidTy τ₁ →
      ⟪ Γ r▻ τ₁ ia⊢ t : τ₂ ⟫ →
      ⟪ Γ ia⊢ ia_abs τ₁ τ₂ t : tarr τ₁ τ₂ ⟫
  | ia_WtApp {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ia⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ia⊢ t₂ : τ₁ ⟫ →
      ⟪ Γ ia⊢ ia_app τ₁ τ₂ t₁ t₂ : τ₂ ⟫
  | ia_WtUnit :
      ⟪ Γ ia⊢ ia_unit : tunit ⟫
  | ia_WtTrue :
      ⟪ Γ ia⊢ ia_true : tbool ⟫
  | ia_WtFalse :
      ⟪ Γ ia⊢ ia_false : tbool ⟫
  | ia_WtIte {t₁ t₂ t₃ T} :
      ⟪ Γ ia⊢ t₁ : tbool ⟫ →
      ⟪ Γ ia⊢ t₂ : T ⟫ →
      ⟪ Γ ia⊢ t₃ : T ⟫ →
      ⟪ Γ ia⊢ ia_ite T t₁ t₂ t₃ : T ⟫
  | ia_WtPair {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ia⊢ t₁ : τ₁ ⟫ →
      ⟪ Γ ia⊢ t₂ : τ₂ ⟫ →
      ⟪ Γ ia⊢ ia_pair τ₁ τ₂ t₁ t₂ : tprod τ₁ τ₂ ⟫
  | ia_WtProj1 {t τ₁ τ₂} :
      ⟪ Γ ia⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ia⊢ ia_proj₁ τ₁ τ₂ t : τ₁ ⟫
  | ia_WtProj2 {t τ₁ τ₂} :
      ⟪ Γ ia⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ia⊢ ia_proj₂ τ₁ τ₂ t : τ₂ ⟫
  | ia_WtInl {t τ₁ τ₂} :
    ValidTy τ₂ →
      ⟪ Γ ia⊢ t : τ₁ ⟫ →
      ⟪ Γ ia⊢ ia_inl τ₁ τ₂ t : tsum τ₁ τ₂ ⟫
  | ia_WtInr {t τ₁ τ₂} :
    ValidTy τ₁ →
      ⟪ Γ ia⊢ t : τ₂ ⟫ →
      ⟪ Γ ia⊢ ia_inr τ₁ τ₂ t : tsum τ₁ τ₂ ⟫
  | ia_WtCaseof {t₁ t₂ t₃ τ₁ τ₂ τ} :
      ⟪ Γ ia⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ r▻ τ₁ ia⊢ t₂ : τ ⟫ →
      ⟪ Γ r▻ τ₂ ia⊢ t₃ : τ ⟫ →
      ValidTy τ₁ → ValidTy τ₂ →
      ⟪ Γ ia⊢ ia_caseof τ₁ τ₂ τ t₁ t₂ t₃ : τ ⟫
  | ia_WtFold {t τ} :
      ⟪ Γ ia⊢ t : τ[beta1 (trec τ)] ⟫ →
      ValidTy (trec τ) →
      ⟪ Γ ia⊢ ia_fold_ τ t : trec τ ⟫
  | ia_WtUnfold {t τ} :
      ⟪ Γ ia⊢ t : trec τ ⟫ →
      ValidTy (trec τ) →
      ⟪ Γ ia⊢ ia_unfold_ τ t : τ[beta1 (trec τ)] ⟫
  | ia_WtSeq {t₁ t₂ T} :
      ⟪ Γ ia⊢ t₁ : tunit ⟫ →
      ⟪ Γ ia⊢ t₂ : T ⟫ →
      ⟪ Γ ia⊢ ia_seq T t₁ t₂ : T ⟫
where "⟪  Γ ia⊢ t : T  ⟫" := (AnnotTyping Γ t T).

Inductive PCtxA : Set :=
  | ia_phole
  | ia_pabs (τ₁ τ₂ : Ty) (C: PCtxA)
  | ia_papp₁ (τ₁ τ₂ : Ty) (C: PCtxA) (t: TmA)
  | ia_papp₂ (τ₁ τ₂ : Ty) (t: TmA) (C: PCtxA)
  | ia_pite₁ (τ : Ty) (C: PCtxA) (t₂ t₃: TmA)
  | ia_pite₂ (τ : Ty) (t₁: TmA) (C: PCtxA) (t₃: TmA)
  | ia_pite₃ (τ : Ty) (t₁ t₂: TmA) (C: PCtxA)
  | ia_ppair₁ (τ₁ τ₂ : Ty) (C: PCtxA) (t: TmA)
  | ia_ppair₂ (τ₁ τ₂ : Ty) (t: TmA) (C: PCtxA)
  | ia_pproj₁ (τ₁ τ₂ : Ty) (C: PCtxA)
  | ia_pproj₂ (τ₁ τ₂ : Ty) (C: PCtxA)
  | ia_pinl (τ₁ τ₂ : Ty) (C: PCtxA)
  | ia_pinr (τ₁ τ₂ : Ty) (C: PCtxA)
  | ia_pcaseof₁ (τ₁ τ₂ τ : Ty) (C: PCtxA) (t₂ t₃: TmA)
  | ia_pcaseof₂ (τ₁ τ₂ τ : Ty) (t₁: TmA) (C: PCtxA) (t₃: TmA)
  | ia_pcaseof₃ (τ₁ τ₂ τ : Ty) (t₁ t₂: TmA) (C: PCtxA)
  | ia_pseq₁ (τ : Ty) (C: PCtxA) (t: TmA)
  | ia_pseq₂ (τ : Ty) (t: TmA) (C: PCtxA)
  | ia_pfold (τ : Ty) (C : PCtxA)
  | ia_punfold (τ : Ty) (C : PCtxA).

Reserved Notation "⟪ ia⊢ C : Γ₀ , τ₀ → Γ , τ ⟫"
  (at level 0, C at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ia⊢  C  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").
Inductive PCtxTypingAnnot (Γ₀: Env) (τ₀: Ty) : Env → PCtxA → Ty → Prop :=
  | ia_WtPHole :
      ⟪ ia⊢ ia_phole : Γ₀, τ₀ → Γ₀, τ₀ ⟫
  | ia_WtPAbs {Γ C τ₁ τ₂} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ r▻ τ₁, τ₂ ⟫ →
      ValidTy τ₁ →
      ⟪ ia⊢ ia_pabs τ₁ τ₂ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫
  | ia_WtPAppl {Γ C t₂ τ₁ τ₂} :
    ValidTy τ₂ →
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ia⊢ t₂ : τ₁ ⟫ →
      ⟪ ia⊢ ia_papp₁ τ₁ τ₂ C t₂ : Γ₀, τ₀ → Γ, τ₂ ⟫
  | ia_WtPAppr {Γ t₁ C τ₁ τ₂} :
    ValidTy τ₁ → ValidTy τ₂ →
      ⟪ Γ ia⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ ia⊢ ia_papp₂ τ₁ τ₂ t₁ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | ia_WtPIteI {Γ C t₂ t₃ T} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ , tbool ⟫ →
      ⟪ Γ ia⊢ t₂ : T ⟫ →
      ⟪ Γ ia⊢ t₃ : T ⟫ →
      ⟪ ia⊢ ia_pite₁ T C t₂ t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | ia_WtPIteT {Γ t₁ C t₃ T} :
      ⟪ Γ ia⊢ t₁ : tbool ⟫ →
      ⟪ ia⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ Γ ia⊢ t₃ : T ⟫ →
      ⟪ ia⊢ ia_pite₂ T t₁ C t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | ia_WtPIteE {Γ t₁ t₂ C T} :
      ⟪ Γ ia⊢ t₁ : tbool ⟫ →
      ⟪ Γ ia⊢ t₂ : T ⟫ →
      ⟪ ia⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ ia⊢ ia_pite₃ T t₁ t₂ C : Γ₀ , τ₀ → Γ , T ⟫
  | ia_WtPPair₁ {Γ C t₂ τ₁ τ₂} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ Γ ia⊢ t₂ : τ₂ ⟫ →
      ⟪ ia⊢ ia_ppair₁ τ₁ τ₂ C t₂ : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | ia_WtPPair₂ {Γ t₁ C τ₁ τ₂} :
      ⟪ Γ ia⊢ t₁ : τ₁ ⟫ →
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ⟪ ia⊢ ia_ppair₂ τ₁ τ₂ t₁ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | ia_WtPProj₁ {Γ C τ₁ τ₂} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ValidTy (tprod τ₁ τ₂) →
      ⟪ ia⊢ ia_pproj₁ τ₁ τ₂ C : Γ₀, τ₀ → Γ, τ₁ ⟫
  | ia_WtPProj₂ {Γ C τ₁ τ₂} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ValidTy (tprod τ₁ τ₂) →
      ⟪ ia⊢ ia_pproj₂ τ₁ τ₂ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | ia_WtPInl {Γ C τ₁ τ₂} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ValidTy τ₂ →
      ⟪ ia⊢ ia_pinl τ₁ τ₂ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | ia_WtPInr {Γ C τ₁ τ₂} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ValidTy τ₁ →
      ⟪ ia⊢ ia_pinr τ₁ τ₂ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | ia_WtPCaseof₁ {Γ C t₂ t₃ τ₁ τ₂ τ} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫ →
      ⟪ Γ r▻ τ₁ ia⊢ t₂ : τ ⟫ →
      ⟪ Γ r▻ τ₂ ia⊢ t₃ : τ ⟫ →
      ValidTy τ₁ → ValidTy τ₂ →
      ⟪ ia⊢ ia_pcaseof₁ τ₁ τ₂ τ C t₂ t₃ : Γ₀, τ₀ → Γ, τ ⟫
  | ia_WtPCaseof₂ {Γ t₁ C t₃ τ₁ τ₂ τ} :
      ⟪ Γ ia⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ r▻ τ₁, τ ⟫ →
      ⟪ Γ r▻ τ₂ ia⊢ t₃ : τ ⟫ →
      ValidTy τ₁ → ValidTy τ₂ →
      ⟪ ia⊢ ia_pcaseof₂ τ₁ τ₂ τ t₁ C t₃ : Γ₀, τ₀ → Γ, τ ⟫
  | ia_WtPCaseof₃ {Γ t₁ t₂ C τ₁ τ₂ τ} :
      ⟪ Γ ia⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ r▻ τ₁ ia⊢ t₂ : τ ⟫ →
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ r▻ τ₂, τ ⟫ →
      ValidTy τ₁ → ValidTy τ₂ →
      ⟪ ia⊢ ia_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C : Γ₀, τ₀ → Γ, τ ⟫
  | ia_WtPFold {Γ C τ} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, τ [beta1 (trec τ)] ⟫ →
      ValidTy τ →
      ⟪ ia⊢ ia_pfold τ C : Γ₀, τ₀ → Γ, trec τ ⟫
  | ia_WtPUnfold {Γ C τ} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, trec τ ⟫ →
      ValidTy (trec τ) →
      ⟪ ia⊢ ia_punfold τ C : Γ₀, τ₀ → Γ, τ [beta1 (trec τ)] ⟫
  | ia_WtPSeq₁ {Γ C t₂ T} :
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, tunit ⟫ →
      ⟪ Γ ia⊢ t₂ : T ⟫ →
      ⟪ ia⊢ ia_pseq₁ T C t₂ : Γ₀, τ₀ → Γ, T ⟫
  | ia_WtPSeq₂ {Γ C t₁ T} :
      ⟪ Γ ia⊢ t₁ : tunit ⟫ →
      ⟪ ia⊢ C : Γ₀, τ₀ → Γ, T ⟫ →
      ⟪ ia⊢ ia_pseq₂ T t₁ C : Γ₀, τ₀ → Γ, T ⟫
where "⟪ ia⊢ C : Γ₀ , τ₀ → Γ , τ ⟫" := (PCtxTypingAnnot Γ₀ τ₀ Γ C τ).

Ltac crushTypingMatchIAH :=
  match goal with
    | [ H: ⟪ _ : _ r∈ empty ⟫         |- _ ] =>
      inversion H
    | [ H: ⟪ 0 : _ r∈ _ ⟫         |- _ ] =>
      apply getEvarInvHere in H; repeat subst
    | [ H: ⟪ (S _) : _ r∈ (_ r▻ _) ⟫ |- _ ] =>
      apply getEvarInvThere in H
    | H: ⟪ _ ia⊢ ia_var _        : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_abs _ _ _      : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_app _ _ _ _      : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_unit         : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_true         : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_false        : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_ite _ _ _    : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_pair _ _     : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_proj₁ _ _ _      : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_proj₂ _ _ _      : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_inl _ _ _        : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_inr _ _ _        : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_caseof _ _ _ _ _ _ : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_seq _ _        : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_fold_ _ _        : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ia⊢ ia_unfold_ _ _        : _ ⟫ |- _ => inversion H; clear H
    (* | H: ⟪ _ ⊢ seq _ _      : _ ⟫ |- _ => inversion H; clear H *)
    | [ wi : ⟪ ?i : _ r∈ (_ r▻ _) ⟫
        |- context [match ?i with _ => _ end]
      ] => destruct i
    | [ wi : ⟪ ?i : _ r∈ (_ r▻ _) ⟫
        |- context [(_ · _) ?i]
      ] => destruct i
    | [ |- ⟪ _ ia⊢ ia_var _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_abs _ _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_app _ _ _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_unit : _ ⟫                     ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_true : _ ⟫                     ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_false : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_ite _ _ _ : _ ⟫                ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_pair _ _ _ _ : _ ⟫                 ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_proj₁ _ _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_proj₂ _ _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_inl _ _ _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_inr _ _ _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_caseof _ _ _ _ _ _ : _ ⟫             ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_seq _ _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_fold_ _ _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ ia⊢ ia_unfold_ _ _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ ia⊢ ia_phole : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ ia⊢ ia_pabs _ _ _ : _ , _ → _ , _ ⟫       ] => econstructor
    | [ |- ⟪ ia⊢ ia_papp₁ _ _ _ _ : _ , _ → _ , _ ⟫      ] => econstructor
    | [ |- ⟪ ia⊢ ia_papp₂ _ _ _ _ : _ , _ → _ , _ ⟫      ] => econstructor
    | [ |- ⟪ ia⊢ ia_pite₁ _ _ _ _ : _ , _ → _ , _ ⟫    ] => econstructor
    | [ |- ⟪ ia⊢ ia_pite₂ _ _ _ _ : _ , _ → _ , _ ⟫    ] => econstructor
    | [ |- ⟪ ia⊢ ia_pite₃ _ _ _ _ : _ , _ → _ , _ ⟫    ] => econstructor
    | [ |- ⟪ ia⊢ ia_ppair₁ _ _ _ _ : _ , _ → _ , _ ⟫     ] => econstructor
    | [ |- ⟪ ia⊢ ia_ppair₂ _ _ _ _ : _ , _ → _ , _ ⟫     ] => econstructor
    | [ |- ⟪ ia⊢ ia_pproj₁ _ _ _ : _ , _ → _ , _ ⟫       ] => econstructor
    | [ |- ⟪ ia⊢ ia_pproj₂ _ _ _ : _ , _ → _ , _ ⟫       ] => econstructor
    | [ |- ⟪ ia⊢ ia_pinl _ _ _ : _ , _ → _ , _ ⟫         ] => econstructor
    | [ |- ⟪ ia⊢ ia_pinr _ _ _ : _ , _ → _ , _ ⟫         ] => econstructor
    | [ |- ⟪ ia⊢ ia_pcaseof₁ _ _ _ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ ia⊢ ia_pcaseof₂ _ _ _ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ ia⊢ ia_pcaseof₃ _ _ _ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ ia⊢ ia_pfold _ _ _ : _ , _ → _ , _ ⟫         ] => econstructor
    | [ |- ⟪ ia⊢ ia_punfold _ _ _ : _ , _ → _ , _ ⟫         ] => econstructor
    | [ |- ⟪ ia⊢ ia_pfold _ _ : _ , _ → _ , _ ⟫                    ] => econstructor
    | [ |- ⟪ ia⊢ ia_punfold _ _ : _ , _ → _ , _ ⟫                    ] => econstructor
    | [ |- ⟪ ia⊢ ia_pseq₁ _ _ _ : _ , _ → _ , _ ⟫                  ] => econstructor
    | [ |- ⟪ ia⊢ ia_pseq₂ _ _ _ : _ , _ → _ , _ ⟫                  ] => econstructor
  end.

Fixpoint eraseAnnot (t : TmA) : Tm :=
  match t with
  | ia_var i => var i
  | ia_abs τ₁ τ₂ t => abs τ₁ (eraseAnnot t)
  | ia_app τ₁ τ₂ t₁ t₂ => app (eraseAnnot t₁) (eraseAnnot t₂)
  | ia_unit => unit
  | ia_true => true
  | ia_false => false
  | ia_ite τ t₁ t₂ t₃ => ite (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot t₃)
  | ia_pair τ₁ τ₂ t₁ t₂ => pair (eraseAnnot t₁) (eraseAnnot t₂)
  | ia_proj₁ τ₁ τ₂ t => proj₁ (eraseAnnot t)
  | ia_proj₂ τ₁ τ₂ t => proj₂ (eraseAnnot t)
  | ia_inl τ₁ τ₂ t => inl (eraseAnnot t)
  | ia_inr τ₁ τ₂ t => inr (eraseAnnot t)
  | ia_caseof τ₁ τ₂ τ t₁ t₂ t₃ => caseof (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot t₃)
  | ia_seq τ t₁ t₂ => seq (eraseAnnot t₁) (eraseAnnot t₂)
  | ia_fold_ τ t => fold_ (eraseAnnot t)
  | ia_unfold_ τ t => unfold_ (eraseAnnot t)
  end.

Fixpoint eraseAnnot_pctx (C : PCtxA) : PCtx :=
  match C with
  | ia_phole => phole
  | ia_pabs τ₁ τ₂ t => pabs τ₁ (eraseAnnot_pctx t)
  | ia_papp₁ τ₁ τ₂ C t₂ => papp₁ (eraseAnnot_pctx C) (eraseAnnot t₂)
  | ia_papp₂ τ₁ τ₂ t₁ C => papp₂ (eraseAnnot t₁) (eraseAnnot_pctx C)
  | ia_pite₁ τ C t₂ t₃ => pite₁ (eraseAnnot_pctx C) (eraseAnnot t₂) (eraseAnnot t₃)
  | ia_pite₂ τ t₁ C t₃ => pite₂ (eraseAnnot t₁) (eraseAnnot_pctx C) (eraseAnnot t₃)
  | ia_pite₃ τ t₁ t₂ C => pite₃ (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot_pctx C)
  | ia_ppair₁ τ₁ τ₂ C t₂ => ppair₁ (eraseAnnot_pctx C) (eraseAnnot t₂)
  | ia_ppair₂ τ₁ τ₂ t₁ C => ppair₂ (eraseAnnot t₁) (eraseAnnot_pctx C)
  | ia_pproj₁ τ₁ τ₂ C => pproj₁ (eraseAnnot_pctx C)
  | ia_pproj₂ τ₁ τ₂ C => pproj₂ (eraseAnnot_pctx C)
  | ia_pinl τ₁ τ₂ C => pinl (eraseAnnot_pctx C)
  | ia_pinr τ₁ τ₂ C => pinr (eraseAnnot_pctx C)
  | ia_pcaseof₁ τ₁ τ₂ τ C t₂ t₃ => pcaseof₁ (eraseAnnot_pctx C) (eraseAnnot t₂) (eraseAnnot t₃)
  | ia_pcaseof₂ τ₁ τ₂ τ t₁ C t₃ => pcaseof₂ (eraseAnnot t₁) (eraseAnnot_pctx C) (eraseAnnot t₃)
  | ia_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C => pcaseof₃ (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot_pctx C)
  | ia_pseq₁ τ C t₂ => pseq₁ (eraseAnnot_pctx C) (eraseAnnot t₂)
  | ia_pseq₂ τ t₁ C => pseq₂ (eraseAnnot t₁) (eraseAnnot_pctx C)
  | ia_pfold τ t => pfold (eraseAnnot_pctx t)
  | ia_punfold τ C => punfold (eraseAnnot_pctx C)
  end.

Fixpoint pctxA_app (t : TmA) (C: PCtxA) {struct C} : TmA :=
  match C with
    | ia_phole                    => t
    | ia_pabs τ₁ τ₂ C             => ia_abs τ₁ τ₂ (pctxA_app t C)
    | ia_papp₁ τ₁ τ₂ C t2         => ia_app τ₁ τ₂ (pctxA_app t C) t2
    | ia_papp₂ τ₁ τ₂ t1 C         => ia_app τ₁ τ₂ t1 (pctxA_app t C)
    | ia_pite₁ τ C t₂ t₃          => ia_ite τ (pctxA_app t C) t₂ t₃
    | ia_pite₂ τ t₁ C t₃          => ia_ite τ t₁ (pctxA_app t C) t₃
    | ia_pite₃ τ t₁ t₂ C          => ia_ite τ t₁ t₂ (pctxA_app t C)
    | ia_ppair₁ τ₁ τ₂ C t₂        => ia_pair τ₁ τ₂ (pctxA_app t C) t₂
    | ia_ppair₂ τ₁ τ₂ t₁ C        => ia_pair τ₁ τ₂ t₁ (pctxA_app t C)
    | ia_pproj₁ τ₁ τ₂ C           => ia_proj₁ τ₁ τ₂ (pctxA_app t C)
    | ia_pproj₂ τ₁ τ₂ C           => ia_proj₂ τ₁ τ₂ (pctxA_app t C)
    | ia_pinl τ₁ τ₂ C             => ia_inl τ₁ τ₂ (pctxA_app t C)
    | ia_pinr τ₁ τ₂ C             => ia_inr τ₁ τ₂ (pctxA_app t C)
    | ia_pcaseof₁ τ₁ τ₂ τ C t₁ t₂ => ia_caseof τ₁ τ₂ τ (pctxA_app t C) t₁ t₂
    | ia_pcaseof₂ τ₁ τ₂ τ t₁ C t₂ => ia_caseof τ₁ τ₂ τ t₁ (pctxA_app t C) t₂
    | ia_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C => ia_caseof τ₁ τ₂ τ t₁ t₂ (pctxA_app t C)
    | ia_pseq₁ τ C t₂             => ia_seq τ (pctxA_app t C) t₂
    | ia_pseq₂ τ t₁ C             => ia_seq τ t₁ (pctxA_app t C)
    | ia_pfold τ C                => ia_fold_ τ (pctxA_app t C)
    | ia_punfold τ C              => ia_unfold_ τ (pctxA_app t C)
  end.

Fixpoint pctxA_cat (C₀ C: PCtxA) {struct C} : PCtxA :=
  match C with
    | ia_phole                    => C₀
    | ia_pabs τ₁ τ₂ C             => ia_pabs τ₁ τ₂ (pctxA_cat C₀ C)
    | ia_papp₁ τ₁ τ₂ C t          => ia_papp₁ τ₁ τ₂ (pctxA_cat C₀ C) t
    | ia_papp₂ τ₁ τ₂ t C          => ia_papp₂ τ₁ τ₂ t (pctxA_cat C₀ C)
    | ia_pite₁ τ C t₂ t₃          => ia_pite₁ τ (pctxA_cat C₀ C) t₂ t₃
    | ia_pite₂ τ t₁ C t₃          => ia_pite₂ τ t₁ (pctxA_cat C₀ C) t₃
    | ia_pite₃ τ t₁ t₂ C          => ia_pite₃ τ t₁ t₂ (pctxA_cat C₀ C)
    | ia_ppair₁ τ₁ τ₂ C t         => ia_ppair₁ τ₁ τ₂ (pctxA_cat C₀ C) t
    | ia_ppair₂ τ₁ τ₂ t C         => ia_ppair₂ τ₁ τ₂ t (pctxA_cat C₀ C)
    | ia_pproj₁ τ₁ τ₂ C           => ia_pproj₁ τ₁ τ₂ (pctxA_cat C₀ C)
    | ia_pproj₂ τ₁ τ₂ C           => ia_pproj₂ τ₁ τ₂ (pctxA_cat C₀ C)
    | ia_pinl τ₁ τ₂ C             => ia_pinl τ₁ τ₂ (pctxA_cat C₀ C)
    | ia_pinr τ₁ τ₂ C             => ia_pinr τ₁ τ₂ (pctxA_cat C₀ C)
    | ia_pcaseof₁ τ₁ τ₂ τ C t₁ t₂ => ia_pcaseof₁ τ₁ τ₂ τ (pctxA_cat C₀ C) t₁ t₂
    | ia_pcaseof₂ τ₁ τ₂ τ t₁ C t₂ => ia_pcaseof₂ τ₁ τ₂ τ t₁ (pctxA_cat C₀ C) t₂
    | ia_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C => ia_pcaseof₃ τ₁ τ₂ τ t₁ t₂ (pctxA_cat C₀ C)
    | ia_pseq₁ τ C t              => ia_pseq₁ τ (pctxA_cat C₀ C) t
    | ia_pseq₂ τ t C              => ia_pseq₂ τ t (pctxA_cat C₀ C)
    | ia_pfold τ C                => ia_pfold τ (pctxA_cat C₀ C)
    | ia_punfold τ C              => ia_punfold τ (pctxA_cat C₀ C)
  end.

Lemma eraseAnnotT {Γ t τ} : ⟪  Γ ia⊢ t : τ  ⟫ ->
                            ⟪  Γ i⊢ (eraseAnnot t) : τ  ⟫.
Proof.
  induction 1; cbn; eauto using Typing.
  all:
    repeat econstructor;
    try assumption;
    crushValidTy.
Qed.

Lemma eraseAnnot_pctxT {Γₒ τₒ Γ C τ} : ⟪ ia⊢ C : Γₒ , τₒ → Γ , τ ⟫ ->
                            ⟪  i⊢ eraseAnnot_pctx C : Γₒ , τₒ → Γ , τ  ⟫.
Proof.
  induction 1; cbn; eauto using Typing, PCtxTyping, eraseAnnotT.
  all:
    repeat econstructor;
    try assumption;
    crushValidTy.
Qed.

Lemma pctxtyping_app_annot {Γ₀ t₀ τ₀ Γ C τ} :
  ⟪ Γ₀ ia⊢ t₀ : τ₀ ⟫ → ⟪ ia⊢ C : Γ₀, τ₀ → Γ , τ ⟫ → ⟪ Γ ia⊢ pctxA_app t₀ C : τ ⟫.
Proof.
  intros wt₀ wC;
  induction wC; cbn; subst; eauto using AnnotTyping.
  all:
    repeat econstructor;
    try assumption;
    crushValidTy.
Qed.

Lemma pctxtyping_cat_annot {Γ₀ τ₀ C₁ Γ₁ τ₁ C₂ Γ₂ τ₂} :
  ⟪ ia⊢ C₁ : Γ₀, τ₀ → Γ₁ , τ₁ ⟫ →
  ⟪ ia⊢ C₂ : Γ₁, τ₁ → Γ₂ , τ₂ ⟫ →
  ⟪ ia⊢ pctxA_cat C₁ C₂ : Γ₀, τ₀ → Γ₂ , τ₂ ⟫.
Proof.
  intros wC₁ wC₂.
  induction wC₂; cbn; eauto using PCtxTypingAnnot.
Qed.

Lemma eraseAnnot_pctx_cat {C1 C2} :
  eraseAnnot_pctx (pctxA_cat C1 C2) = pctx_cat (eraseAnnot_pctx C1) (eraseAnnot_pctx C2).
Proof.
  induction C2; cbn; f_equal; assumption.
Qed.

#[export]
Hint Resolve pctxtyping_app_annot : typing.
#[export]
Hint Resolve pctxtyping_cat_annot : typing.

Ltac crushTypingMatchIAH2 :=
  match goal with
    | [ |- ⟪ _ ia⊢ pctxA_app _ _ : _ ⟫          ] => apply pctxtyping_app_annot
    | [ |- ⟪ ia⊢ pctxA_cat _ _ : _ , _ → _ , _ ⟫          ] => eapply pctxtyping_cat_annot
  end.

Ltac crushTypingIA :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     repeat crushTypingMatchIAH;
     repeat crushTypingMatchIAH2;
     eauto with ws
    ).

#[export]
Hint Extern 20 (⟪ _ ia⊢ _ : _ ⟫) =>
  crushTypingIA : typing.

#[export]
Hint Extern 20 (⟪ ia⊢ _ : _ , _ → _ , _ ⟫) =>
  crushTypingIA : typing.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e221m3_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo77:
  prime  406847205727->
  prime  15867033888061.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      15867033888061
      39
      ((406847205727,1)::nil)
      0
      19008
      12
      144)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(* Debug methods:

- idtac : to print at the tactic level

- debug auto : print everything auto does

*)
Theorem very_true : forall x : Set, x = x.
Proof.
  idtac "print me alone".
  idtac "concat this";
  idtac "with this".
  debug auto.
Qed.

(* Functions and quantifiers:

- Every function (a -> b) is actually syntactic sugar for
  (forall a:t, b)

- If the snd of the tuple is not bound by the quantifier,
  then we can treat this as a function a -> b.

- All function types are expressed with "forall".

- But function types are written with arrows only when the result
  *type* does not depend on the *value* of the argument.
*)
Check (forall n: nat, bool). (* nat -> bool : Set *)

(* Dependent types:

-  Simply: types that depend on values.
|> Theorem wow: forall e v, interp (arithemtic e) v = interp e v
    - the type of 'wow' depends on the values e, v.
*)
Check 3. (* nat *)
Check nat. (* Set *)
Check Set. (* Type *)
Check Type. (* Type *)

(* Type is actually an infinite hierarchy:

- We need this for type soundness

If we enable "display universe levels" in Coq, we see
that Type@{type 1}'s type is actually Type@{type 1+1}.

Prop is parallel to Set in the type hierarchy, because we want to keep theorem
types from program types. (There are many reasons why a program should not be
dependent on proofs about itself.)
*)
Check (forall m n, m < n). (* Prop *)
Check Prop. (* Type@{Set+1} *)


Require Export Ascii String List Arith Omega Vector List.

Module NatPrinter.
  Local Open Scope string_scope.

  Fixpoint add_to_row (x : nat) (l : list bool) : list bool :=
    match x with
      | 0 => match l with
               | nil => true::nil
               | x::xs => true::xs
             end
      | S x' => match l with
                  | nil => false::add_to_row x' nil
                  | l0::ls => l0::add_to_row x' ls
                end
    end.

  Fixpoint list_to_row (l : list nat) (g : list bool) : list bool :=
    match l with
      | nil => g
      | pt::ls => list_to_row ls (add_to_row pt g)
    end.

  Fixpoint row_to_string (lines : nat -> string) (point_disp : nat -> string) (l : list bool) : string :=
    ((lines 0)
       ++ match l with
            | nil => EmptyString
            | b::ls => (if b then point_disp 0(*"*"(*•*)*) else " ")
                         ++ (row_to_string (fun n => lines (S n)) (fun n => point_disp (S n)) ls)
          end)%string.

  (*Fixpoint repeat {T} (n : nat) (v : T) :=
    match n with
      | 0 => nil
      | S n' => v::repeat n' v
    end.

  Definition pad_right {T} (default : T) (new_len : nat) (l : list T) : list T :=
    l ++ repeat (new_len - List.length l) default.

  Definition normalize_grid {T} (g : list (list T)) (default : T) :=
    let max_length := fold_left Arith.Max.max (map (@List.length _) g) 0 in
    map (pad_right default max_length) g.

  Definition string_list_of_grid (lines : nat -> string) (grid : list (list bool)) : list string :=
    map (row_to_string lines) (normalize_grid grid false).*)

  Definition string_list_of_nats (lines : nat -> string) (point_disp : nat -> string)
             (points : list nat) : string :=
    row_to_string lines point_disp (list_to_row points nil).

  Definition string_list_of_nats_with_lines l lines :=
    (string_list_of_nats (fun x =>
                            match lines with
                              | nil => " "
                              | x0::xs => if eq_nat_dec x0 x then "|"
                                          else if in_dec eq_nat_dec x lines then ":"(*"⋮"*)
                                               else " "
                            end)
                         (fun _ => "*")
                         l).

  Fixpoint find_symbol_of_point pt symb_points :=
    match symb_points with
      | nil => "*"
      | (symb, pts)::symb_points'
        => if in_dec eq_nat_dec pt pts
           then symb
           else find_symbol_of_point pt symb_points'
    end.

  Definition string_list_of_nats_with_lines_and_points l lines symb_points :=
    string_list_of_nats (fun x =>
                           match lines with
                             | nil => " "
                             | x0::xs => if eq_nat_dec x0 x then "|"
                                         else if in_dec eq_nat_dec x lines then ":"(*"⋮"*)
                                              else " "
                           end)
                        (fun x =>
                           find_symbol_of_point x symb_points(*
                           if in_dec eq_nat_dec x oh_points then "o"
                           else if in_dec eq_nat_dec x bold_points then "●"
                                else "*"*))
                        l.

  Ltac print t := let t' := (eval lazy in t) in idtac t'.
  Ltac print_list l := print (string_list_of_nats (fun _ => "") (fun _ => "*") l).
  Ltac print_list_with_lines l lines :=
    print (string_list_of_nats_with_lines l lines).
  Ltac print_list_with_lines_and_points l lines symb_points :=
    print (string_list_of_nats_with_lines_and_points l lines symb_points).
  Goal True.
    print_list (1::5::7::15::nil).
    print_list (1::5::7::30::nil).
    print_list_with_lines (1::5::10::18::nil) (11::nil).
    print_list_with_lines (1::5::10::18::nil) (6::11::nil).
    print_list_with_lines_and_points (1::5::10::18::nil) (6::11::nil) (("o", (1::nil))::("●", (10::nil))::nil).
  Abort.
End NatPrinter.


Require Export Iron.Language.SimpleRef.SubstExpExp.
Require Export Iron.Language.SimpleRef.Exp.

(*******************************************************************)
(* Evaluation contexts for expressions.
   An evaluation context is an expression with a hole in any place
   that can take a step via our evaluatio rules. We represent
   the hole by the function that fills it. *)
Inductive exp_ctx : (exp -> exp) -> Prop :=
 | XcTop
   :  exp_ctx (fun x => x)

 | XcApp1
   :  forall x2
   ,  exp_ctx (fun xx => XApp xx x2)

 | XcApp2
   :  forall v1
   ,  value v1
   -> exp_ctx (fun xx => XApp v1 xx)

 | XcNewRef
   :  exp_ctx (fun xx => XNewRef xx)

 | XcReadRef
   :  exp_ctx (fun xx => XReadRef xx)

 | XcWriteRef1
   :  forall x2
   ,  exp_ctx (fun xx => XWriteRef xx x2)

 | XcWriteRef2
   :  forall v1
   ,  value v1
   -> exp_ctx (fun xx => XWriteRef v1 xx).

Hint Constructors exp_ctx.

(* Small Step evaluation *)
Inductive STEP  : heap -> exp -> heap -> exp -> Prop :=

 (* Evaluation in a context. *)
 | EsContext
   :  forall C h x h' x'
   ,  exp_ctx C
   -> STEP h x     h' x'
   -> STEP h (C x) h' (C x')

 (* Function application. *)
 | EsLamApp
   :  forall h t11 x12 v2
   ,  value v2
   -> STEP h (XApp (XLam t11 x12) v2)
           h (substX 0 v2 x12)

 (* Allocate a reference *)
 | EsNewRef
   :  forall h v1
   ,  value v1
   -> STEP h           (XNewRef v1)
           (snoc v1 h) (XLoc (length h))

 (* Read from a reference *)
 | EsReadRef
   :  forall l h v
   ,  get l h = Some v
   -> STEP h  (XReadRef (XLoc l))
           h  v

 (* Write to a reference *)
 | EsWriteRef
   :  forall l h v2
   ,  value v2
   -> STEP h  (XWriteRef (XLoc l) v2)
           (update l v2 h) xUnit.

Hint Constructors STEP.

(********************************************************************)
(* Well-formed heaps contain values only.
   No free variables or reducible terms in heap cells. *)
Definition wfH (h: heap)
 := Forall value h.
Hint Unfold wfH.

(* Any expression obtained from a well formed heap is a value. *)
Lemma heap_value
 :  forall l h x
 ,  wfH h
 -> get l h = Some x
 -> value x.
Proof.
 intros.
 eapply Forall_get; eauto.
Qed.
Hint Resolve heap_value.

(* Taking a single evaluation step preserves the well-formedness
   of the heap. *)
Lemma step_preserves_wfH
 :  forall h1 h2 x1 x2
 ,  wfH h1
 -> STEP h1 x1 h2 x2
 -> wfH h2.
Proof.
 intros h1 h2 x1 x2 HW HS.
 induction HS; burn using Forall_update.
Qed.

(********************************************************************)
(* Multi-step evaluation
   A sequence of small step transitions.
   As opposed to STEPSL, this version has an append constructor
   EsAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step. *)
Inductive STEPS : heap -> exp -> heap -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | EsNone
   :  forall h x
   ,  STEPS h x  h x

 (* Take a single step. *)
 | EsStep
   :  forall h1 x1 h2 x2
   ,  STEP  h1 x1 h2 x2
   -> STEPS h1 x1 h2 x2

 (* Combine two evaluations into a third. *)
 | EsAppend
   :  forall h1 x1 h2 x2 h3 x3
   ,  STEPS h1 x1 h2 x2 -> STEPS h2 x2 h3 x3
   -> STEPS h1 x1 h3 x3.

Hint Constructors STEPS.

(* Multi-step evaluation in a context.
   If an expression can be evaluated at top level, then it can
   be evaluated to the same result in any evaluation context. *)
Lemma steps_context
 :  forall C h x h' x'
 ,  exp_ctx C
 -> STEPS h x     h' x'
 -> STEPS h (C x) h' (C x').
Proof.
 intros.
 induction H0; eauto.
Qed.

(********************************************************************)
(* Left linearised multi-step evaluation
   As opposed to STEPS, this version provides a single step at a time
   and does not have an append constructor. This is convenient
   when converting a small-step evaluations to big-step, via the
   eval_expansion lemma. *)
Inductive STEPSL : heap -> exp -> heap -> exp -> Prop :=

 | EslNone
   : forall h x
   , STEPSL h x h x

 | EslCons
   :  forall h1 x1 h2 x2 h3 x3
   ,  STEP   h1 x1 h2 x2 -> STEPSL h2 x2 h3 x3
   -> STEPSL h1 x1 h3 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one. *)
Lemma stepsl_trans
 :  forall h1 x1 h2 x2 h3 x3
 ,  STEPSL h1 x1 h2 x2 -> STEPSL h2 x2 h3 x3
 -> STEPSL h1 x1 h3 x3.
Proof. intros. induction H; burn. Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions. *)
Lemma stepsl_of_steps
 :  forall h1 x1 h2 x2
 ,  STEPS  h1 x1 h2 x2
 -> STEPSL h1 x1 h2 x2.
Proof.
 intros. induction H; eauto using stepsl_trans.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Import DecidableType OrderedType OrderedTypeEx.
Set Implicit Arguments.
Unset Strict Implicit.

(** NB: This file is here only for compatibility with earlier version of
    [FSets] and [FMap]. Please use [Structures/Equalities.v] directly now. *)

(** * Examples of Decidable Type structures. *)

(** A particular case of [DecidableType] where
    the equality is the usual one of Coq. *)

Module Type UsualDecidableType := Equalities.UsualDecidableTypeOrig.

(** a [UsualDecidableType] is in particular an [DecidableType]. *)

Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U.

(** an shortcut for easily building a UsualDecidableType *)

Module Type MiniDecidableType := Equalities.MiniDecidableType.

Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType
 := Equalities.Make_UDT M.

(** An OrderedType can now directly be seen as a DecidableType *)

Module OT_as_DT (O:OrderedType) <: DecidableType := O.

(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)

Module Nat_as_DT <: UsualDecidableType := Nat_as_OT.
Module Positive_as_DT <: UsualDecidableType := Positive_as_OT.
Module N_as_DT <: UsualDecidableType := N_as_OT.
Module Z_as_DT <: UsualDecidableType := Z_as_OT.

(** From two decidable types, we can build a new DecidableType
   over their cartesian product. *)

Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.

 Definition t := prod D1.t D2.t.

 Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y).

 Lemma eq_refl : forall x : t, eq x x.
 Proof.
 intros (x1,x2); red; simpl; auto.
 Qed.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
 Qed.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
 Qed.

 Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl.
 destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition.
 Defined.

End PairDecidableType.

(** Similarly for pairs of UsualDecidableType *)

Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
 Definition t := prod D1.t D2.t.
 Definition eq := @eq t.
 Definition eq_refl := @refl_equal t.
 Definition eq_sym := @sym_eq t.
 Definition eq_trans := @trans_eq t.
 Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
 Proof.
 intros (x1,x2) (y1,y2);
 destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
 unfold eq, D1.eq, D2.eq in *; simpl;
 (left; f_equal; auto; fail) ||
 (right; intro H; injection H; auto).
 Defined.

End PairUsualDecidableType.


Require Import Kami.AllNotations.

Lemma Bool_eqb_refl2 : forall b, Bool.eqb b b = true.
Proof.
  destruct b; simpl; auto.
Defined.

Lemma Ascii_eqb_refl2 : forall c, (c =? c)%char = true.
Proof.
  intros []; simpl.
  repeat rewrite (Bool_eqb_refl2); auto.
Defined.

Lemma Ascii_eqb_eq2 : forall n m : ascii, (n =? m)%char = true <-> n = m.
Proof.
  intros.
  split; intro.
  apply Ascii.eqb_eq in H.
  exact (match ascii_dec n m with
         | left p => p
         | right ne => match (ne H) with end
         end).
  rewrite H.
  apply Ascii_eqb_refl2.
Defined.

Lemma Nat_eqb_refl2 : forall n, (n =? n)%nat = true.
Proof.
  induction n; auto.
Defined.

Lemma Nat_eqb_eq2 : forall n m : nat, (n =? m)%nat = true <-> n = m.
Proof.
  split; intro.
  apply Nat.eqb_eq in H.
  exact (match Nat.eq_dec n m with
         | left p => p
         | right ne => match (ne H) with end
         end).
  rewrite H.
  apply Nat_eqb_refl2.
Defined.

Lemma String_eqb_eq2 : forall s1 s2 : string, String.eqb s1 s2 = true <-> s1 = s2.
Proof.
  induction s1; destruct s2; simpl; split; intro; try reflexivity; try discriminate.
  - destruct (a =? a0)%char eqn:G.
    + apply Ascii_eqb_eq2 in G.
      apply IHs1 in H.
      congruence.
    + discriminate.
  - inversion H.
    rewrite Ascii.eqb_refl.
    rewrite <- H2.
    apply IHs1; reflexivity.
Defined.

Lemma Kind_decb_eq2 : forall k1 k2, Kind_decb k1 k2 = true <-> k1 = k2.
Proof.
  induction k1; intros; destruct k2; split; intro; try (reflexivity || discriminate).
  - simpl in H; apply Nat_eqb_eq2 in H; congruence.
  - inversion H; simpl; apply Nat_eqb_refl2.
  - destruct (n =? n0)%nat eqn:G.
    + simpl in H0.
      rewrite (@silly_lemma_true bool (n =? n0)%nat _ _ G) in H0 by auto.
      pose proof G.
      apply Nat_eqb_eq2 in H1.
      destruct H1.
      f_equal; extensionality i.
      apply H.
      apply andb_true_iff in H0; destruct H0.
      pose (proj1 (Fin_forallb_correct _) H0).
      rewrite (hedberg Nat.eq_dec _ eq_refl) in e.
      simpl in e.
      apply e.
      apply String_eqb_eq2.
      apply andb_true_iff in H0; destruct H0.
      pose (proj1 (Fin_forallb_correct _) H1).
      rewrite (hedberg Nat.eq_dec _ eq_refl) in e.
      simpl in e.
      apply e.
    + simpl in H0.
      rewrite (@silly_lemma_false) in H0 by auto; discriminate.
  - rewrite H0; apply Kind_decb_refl.
  - simpl in H; apply andb_true_iff in H.
    destruct H as [H1 H2]. apply Nat_eqb_eq2 in H1.
    destruct (IHk1 k2).
    pose (H H2); congruence.
  - simpl.
    apply andb_true_iff; inversion H; split.
    + apply Nat_eqb_refl2.
    + rewrite <- H2, IHk1; reflexivity.
Defined.

Definition string_dec2 : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
Proof.
  intros.
  destruct (String.eqb s1 s2) eqn:G.
  - left; apply String_eqb_eq2; auto.
  - right; abstract (intro;
    rewrite <- String_eqb_eq2 in H;
    rewrite H in G; discriminate).
Defined.

Definition Kind_dec2 : forall k1 k2 : Kind, {k1 = k2} + {k1 <> k2}.
Proof.
  intros.
  destruct (Kind_decb k1 k2) eqn: G.
  - left; apply Kind_decb_eq2 in G; congruence.
  - right.
    abstract (intro; subst;
    rewrite Kind_decb_refl in G; discriminate).
Defined.

Definition Signature_dec2 (s1 s2 : Signature) : {s1 = s2} + {s1 <> s2}.
Proof.
  destruct s1,s2.
  destruct (Kind_dec2 k k1).
  destruct (Kind_dec2 k0 k2).
  left; congruence.
  right; congruence.
  right; congruence.
Defined.

Definition string_sigb : forall x y : (string * Signature), {x = y} + {x <> y}.
Proof.
  intros [] [].
  destruct (string_dec2 s s1);
  destruct (Signature_dec2 s0 s2).
  - left; congruence.
  - right; congruence.
  - right; congruence.
  - right; congruence.
Defined.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.Bool.
Require Import ExtLib.Data.String.
Require Import ExtLib.Tactics.Consider.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Lambda.Expr.

Require Import Charge.Logics.ILogic.

Require Import Coq.Strings.String.

Require Import MirrorCharge.ModularFunc.BaseType.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Inductive base_func typ :=
  | pNat : nat -> base_func typ
  | pBool : bool -> base_func typ
  | pString : string -> base_func typ
  | pEq : typ -> base_func typ
  | pPair : typ -> typ -> base_func typ.

Class BaseFunc (typ func : Type) := {
  fNat  : nat -> func;
  fBool : bool -> func;
  fString : string -> func;

  fEq : typ -> func;
  fPair : typ -> typ -> func;

  baseS : func -> option (base_func typ)
}.

Section BaseFuncSum.
	Context {typ func : Type} {H : BaseFunc typ func}.

	Global Instance BaseFuncSumL (A : Type) :
		BaseFunc typ (func + A) := {
		  fNat n := inl (fNat n)
	    ; fBool b := inl (fBool b)
	    ; fString s := inl (fString s)
        ; fEq t := inl (fEq t)
        ; fPair t1 t2 := inl (fPair t1 t2)
        ; baseS f := match f with
        			   | inl a => baseS a
        			   | inr _ => None
        			 end
        }.

	Global Instance BaseFuncSumR (A : Type) :
		BaseFunc typ (A + func) := {
		  fNat n := inr (fNat n)
	    ; fBool b := inr (fBool b)
	    ; fString s := inr (fString s)
        ; fEq t := inr (fEq t)
        ; fPair t1 t2 := inr (fPair t1 t2)
        ; baseS f := match f with
        			   | inr a => baseS a
        			   | inl _ => None
        			 end
        }.

    Global Instance BaseFuncExpr :
    	BaseFunc typ (expr typ func) := {
    	  fNat n := Inj (fNat n);
    	  fBool b := Inj (fBool b);
    	  fString s := Inj (fString s);
    	  fEq t := Inj (fEq t);
    	  fPair t1 t2 := Inj (fPair t1 t2);
    	  baseS f := match f with
    	  			   | Inj f => baseS f
    	  			   | _     => None
    	  			 end
    }.

End BaseFuncSum.

Section BaseFuncInst.
	Context {typ : Type} {HR : RType typ}
	        {HT : BaseType typ} {HTD: BaseTypeD}.
	Context {func : Type} {H : BaseFunc typ func}.
	Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

    Variable Typ2_tyArr : Typ2 _ Fun.
    Variable Typ0_tyProp : Typ0 _ Prop.

    Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
    Let tyProp : typ := @typ0 _ _ _ _.

	Global Instance BaseFuncInst : BaseFunc typ (base_func typ) := {
	  fNat := pNat typ;
	  fBool := pBool typ;
	  fString := pString typ;
	  fEq := pEq;
	  fPair := pPair;
	  baseS f := Some f
	}.

	Definition typeof_base_func bf :=
		match bf with
		  | pNat _ => Some tyNat
		  | pBool _ => Some tyBool
		  | pString _ => Some tyString
		  | pEq t => Some (tyArr t (tyArr t tyProp))
		  | pPair t1 t2 => Some (tyArr t1 (tyArr t2 (tyPair t1 t2)))
		end.

	Definition base_func_eq (a b : base_func typ) : option bool :=
	  match a , b with
	    | pNat a, pNat b => Some (a ?[ eq ] b)
	    | pBool a, pBool b => Some (a ?[ eq ] b)
	    | pString a, pString b => Some (a ?[ eq ] b)
	    | pEq t1, pEq t2 => Some (t1 ?[ eq ] t2)
	    | pPair t1 t2, pPair t3 t4 => Some (t1 ?[ eq ] t3 &&
	      								    t2 ?[ eq ] t4)%bool
	    | _, _ => None
	  end.

    Global Instance RelDec_base_func : RelDec (@eq (base_func typ)) := {
      rel_dec a b := match base_func_eq a b with
    	  		       | Some b => b
    		 	       | None => false
    			     end
    }.

    Global Instance RelDec_Correct_ilfunc : RelDec_Correct RelDec_base_func.
    Proof.
      constructor.
      destruct x; destruct y; simpl;
      try solve [ try rewrite Bool.andb_true_iff ;
                  repeat rewrite rel_dec_correct; intuition congruence ].
    Qed.

	 Definition base_func_symD bf :=
		match bf as bf return match typeof_base_func bf with
								| Some t => typD t
								| None => unit
							  end with
	    | pNat n => eq_rect_r id n btNat
	    | pBool b => eq_rect_r id b btBool
	    | pString s => eq_rect_r id s btString
	    | pEq t =>
	       eq_rect_r id
             (eq_rect_r (fun T : Type => typD t -> T)
               (fun A B : typD t => eq_rect_r id (A = B)
                                    (typ0_cast (F:=Prop)))
               (typ2_cast t tyProp))
             (typ2_cast t (typ2 t tyProp))
        | pPair t1 t2 =>
           eq_rect_r id
             (eq_rect_r (fun T : Type => typD t1 -> T)
               (fun (A : typD t1) (B : typD t2) =>
               	     eq_rect_r id (A, B) (btPair t1 t2))
               (typ2_cast t2 (tyPair t1 t2)))
             (typ2_cast t1 (typ2 t2 (tyPair t1 t2)))
	end.

	Global Instance RSym_BaseFunc : SymI.RSym (base_func typ) := {
	  typeof_sym := typeof_base_func;
	  symD := base_func_symD;
	  sym_eqb := base_func_eq
	}.

	Global Instance RSymOk_BaseFunc : SymI.RSymOk RSym_BaseFunc.
	Proof.
		split; intros.
		destruct a, b; simpl; try apply I.
		+ consider (n ?[ eq ] n0); intuition congruence.
		+ consider (b0 ?[ eq ] b); intuition congruence.
		+ consider (s ?[ eq ] s0); intuition congruence.
		+ consider (t ?[ eq ] t0); intuition congruence.
		+ consider (t ?[ eq ] t1 && t0 ?[ eq ] t2)%bool;
		  intuition congruence.
	Qed.

End BaseFuncInst.

Section MakeBase.
	Context {typ func : Type} {H : BaseFunc typ func}.

	Definition mkNat n : expr typ func := Inj (fNat n).
	Definition mkBool b : expr typ func := Inj (fBool b).
	Definition mkString s : expr typ func := Inj (fString s).
	Definition mkEq (t : typ) (a b : expr typ func) := App (App (fEq t) a) b.
	Definition mkPair t u a b := App (App (fPair t u) a) b.

End MakeBase.