From Coq Require Import ZArith String Eqdep_dec.

From Vyper Require Import Config Calldag.
From Vyper.L40 Require Import AST Callset.

Section Descend.
Context {C: VyperConfig}.

Definition calldag := generic_calldag decl_callset false.

Lemma call_descend {call_depth_bound new_call_depth_bound current_fun_depth: nat}
                   (DepthOk : current_fun_depth < call_depth_bound)
                   (cd : calldag)
                   (this_fun_name: string)
                   (this_decl: decl)
                   (this_decl_ok: cd_declmap cd this_fun_name = Some this_decl)
                   (current_fun_depth_ok:
                      cd_depthmap cd this_fun_name = Some current_fun_depth)
                   (e: expr)
                   (CallOk: let _ := string_set_impl in
                             FSet.is_subset (expr_callset e) (decl_callset this_decl) = true)
                   (Ebound: call_depth_bound = S new_call_depth_bound)
                   {name: string}
                   {args: list expr}
                   (E: e = PrivateCall name args)
                   {depth: nat}
                   (Edepth: cd_depthmap cd name = Some depth):
  depth < new_call_depth_bound.
Proof.
subst e. cbn in CallOk.
assert(HasName: let _ := string_set_impl in FSet.has (decl_callset this_decl) name = true).
{
  cbn.
  apply (FSet.is_subset_if CallOk name).
  rewrite FSet.add_ok.
  now destruct string_dec.
}
clear CallOk. cbn in HasName.
assert (K := cd_depthmap_ok cd this_fun_name).
unfold cd_declmap in this_decl_ok.
rewrite this_decl_ok in K.
rewrite current_fun_depth_ok in K.
cbn in K.
rewrite FSet.for_all_ok in K.
assert (L := K name HasName). clear K.
subst call_depth_bound.
apply lt_n_Sm_le in DepthOk.
rewrite Edepth in L.
destruct current_fun_depth. { discriminate. }
rewrite Nat.leb_le in L.
rewrite Nat.le_succ_l in DepthOk.
apply (Nat.le_lt_trans _ _ _ L DepthOk).
Qed.

Local Lemma fun_ctx_descend_helper {cd: calldag}
                                   {name: string}
                                   {d: decl}
                                   (Edecl : cd_declmap cd name = Some d):
  cd_depthmap cd name <> None.
Proof.
assert (D := cd_depthmap_ok cd name).
unfold cd_declmap in *.
rewrite Edecl in D.
intro H.
rewrite H in D.
exact D.
Qed.

Local Lemma call_descend' {call_depth_bound new_call_depth_bound}
                          {cd: calldag}
                          {e: expr}
                          (fc: fun_ctx cd call_depth_bound)
                          (CallOk: let _ := string_set_impl in
                                      FSet.is_subset (expr_callset e)
                                                     (decl_callset (fun_decl fc))
                                       = true)
                          (Ebound: call_depth_bound = S new_call_depth_bound)
                          {name: string}
                          {args: list expr}
                          (E: e = PrivateCall name args)
                          {d: decl}
                          (Edecl: cd_declmap cd name = Some d)
                          {depth: nat}
                          (Edepth: cd_depthmap cd name = Some depth):
  (depth <? new_call_depth_bound) = true.
Proof.
exact (proj2 (Nat.ltb_lt _ _)
         (call_descend (proj1 (Nat.ltb_lt _ _) (fun_bound_ok fc))
                       cd (fun_name fc)
                       (fun_decl fc) (fun_decl_ok fc)
                       (fun_depth_ok fc) e CallOk Ebound
                       E Edepth)).
Qed.

(* The inner part of fun_ctx_descend is here separately because
   it's too difficult to destruct [cd_depthmap cd name] otherwise.
 *)
Local Definition fun_ctx_descend_inner {call_depth_bound new_call_depth_bound}
                           {cd: calldag}
                           {e: expr}
                           (fc: fun_ctx cd call_depth_bound)
                           (CallOk: let _ := string_set_impl in
                                       FSet.is_subset (expr_callset e)
                                                      (decl_callset (fun_decl fc))
                                        = true)
                           (Ebound: call_depth_bound = S new_call_depth_bound)
                           {name: string}
                           {args: list expr}
                           (E: e = PrivateCall name args)
                           {d: decl}
                           (Edecl: cd_declmap cd name = Some d)
:= match cd_depthmap cd name as maybe_depth return _ = maybe_depth -> _ with
   | None => fun Edepth => False_rect _ (fun_ctx_descend_helper Edecl Edepth)
   | Some depth => fun Edepth =>
       Some {| fun_name := name
             ; fun_depth := depth
             ; fun_depth_ok := Edepth
             ; fun_decl := d
             ; fun_decl_ok := Edecl
             ; fun_bound_ok := call_descend' fc CallOk Ebound E Edecl Edepth
            |}
   end eq_refl.

(** Make a callee context from a caller context and a call statement,
  The None result means that no declaration with the given name is found.
  No check is made that the callee context is indeed a function.
  The max stack depth bound is reduced by 1.
 *)
Definition fun_ctx_descend {call_depth_bound new_call_depth_bound}
                           {cd: calldag}
                           {e: expr}
                           (fc: fun_ctx cd call_depth_bound)
                           (CallOk: let _ := string_set_impl in
                                       FSet.is_subset (expr_callset e)
                                                      (decl_callset (fun_decl fc))
                                        = true)
                           (Ebound: call_depth_bound = S new_call_depth_bound)
                           {name: string}
                           {args: list expr}
                           (E: e = PrivateCall name args)
: option (fun_ctx cd new_call_depth_bound)
:= match cd_declmap cd name as maybe_decl return _ = maybe_decl -> _ with
   | None => fun _ =>
       (* no declaration found - could be a builtin *)
       None
   | Some d => fun Edecl => fun_ctx_descend_inner fc CallOk Ebound E Edecl
   end eq_refl.

End Descend.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^450 - 2^225 - 1
Base: 25
***)

Definition curve : CurveParameters :=
  {|
    sz := 18%nat;
    base := 25;
    bitwidth := 32;
    s := 2^450;
    c := [(1, 1); (2^225, 1)];
    carry_chains := Some [[8; 17]; [9; 0; 10; 1; 11; 2; 12; 3; 13; 4; 14; 5; 15; 6; 16; 7; 17; 8]; [9; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From iris.proofmode Require Import base tactics classes.
From Perennial.Helpers Require Import ipm.
From Perennial.base_logic Require Export invariants.
From Perennial.program_logic Require Import crash_weakestpre weakestpre.
Set Default Proof Using "Type".

(* This class holds for IrisG instances with certain properties needed to show
   the existence of a token that can be spent to strip a later around a `wpc` *)
Class later_tokG {Λ Σ} (IRISG : irisGS Λ Σ) := {
  later_tok : iProp Σ;
  later_tok_timeless : Timeless later_tok;
  later_tok_decr :
    ⊢ (∀ g ns mj D κ, global_state_interp g ns mj D κ ∗ later_tok ==∗
                                   ∃ ns', ⌜ S ns' ≤ ns ⌝%nat ∗ global_state_interp g ns' mj D κ)%I;
  later_tok_incr :
    ⊢ (∀ g ns mj D κ, global_state_interp g ns mj D κ ==∗ global_state_interp g (S ns) mj D κ ∗ later_tok)%I;
  num_laters_per_step_exp:
              ∀ n1 n2, n1 < n2 → 2 + num_laters_per_step n1 + num_laters_per_step n1 ≤ num_laters_per_step n2;
  step_count_next_mono : ∀ n1 n2, n1 < n2 → step_count_next n1 < step_count_next n2;
  step_count_next_add : ∀ n1 n2, n1 < n2 → 10 + step_count_next n1 ≤ step_count_next n2;
  step_count_next_iter : ∀ n1, 10 + n1 ≤ step_count_next n1;
}.

Arguments later_tok {_ _ _ _}.

Section res.

Context `{IRISG: !irisGS Λ Σ, generationGS Λ Σ}.
Context `{LT: !later_tokG IRISG}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types Φc : iProp Σ.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.

Lemma num_laters_per_step_lt : ∀ n1 n2, n1 < n2 → num_laters_per_step n1 < num_laters_per_step n2.
Proof using LT.
  intros ?? ?%num_laters_per_step_exp. lia.
Qed.

Lemma num_laters_per_step_lt2 : ∀ n1 n2, n1 < n2 → S (num_laters_per_step n1) < num_laters_per_step n2.
Proof using LT.
  intros ?? ?%num_laters_per_step_exp. lia.
Qed.

Lemma num_laters_per_step_le : ∀ n1 n2, n1 < n2 → S (num_laters_per_step n1) + 2 <= S (num_laters_per_step n2).
Proof using LT.
  intros ?? ?%num_laters_per_step_exp. lia.
Qed.

Lemma later_tok_incrN n g ns mj D κ :
  global_state_interp g ns mj D κ ==∗
  global_state_interp g (n + ns) mj D κ ∗
  Nat.iter n (λ P, later_tok ∗ P) True%I.
Proof.
  induction n.
  - eauto.
  - iIntros "Hg". iMod (IHn with "[$]") as "(Hg&$)".
    by iMod (later_tok_incr with "[$]") as "($&$)".
Qed.

Lemma wpc_later_tok_use2_credits s E e Φ Φc :
  language.to_val e = None →
  later_tok -∗
  (£ 2 -∗ WPC e @ s; E {{ v, later_tok -∗ Φ v }} {{ later_tok -∗ Φc }}) -∗
  WPC e @ s; E {{ Φ }} {{ Φc }}.
Proof.
  iIntros (Hnval) "Htok Hwp".
  rewrite ?wpc_unfold /wpc_pre.
  rewrite Hnval.
  iIntros (mj).
  iSplit.
  - iIntros (q σ1 g1 ns D κ κs nt) "Hσ Hg HNC Hlc".
    iMod (later_tok_decr with "[$]") as (ns' Heq) "Hg".
    iMod (fupd2_mask_subseteq ∅ ∅) as "H"; [ set_solver+ | set_solver+ |].
    iApply (step_fupd_extra.step_fupd2N_le (S (S (S (num_laters_per_step ns')))) (S (num_laters_per_step ns))).
    { assert (Hlt: ns' < ns) by lia.
      apply num_laters_per_step_lt2 in Hlt. lia.
    }
    iModIntro. simpl. iModIntro. iNext.
    iModIntro. simpl. iModIntro. iNext.
    iMod "H" as "_".
    iDestruct (lc_weaken with "Hlc") as "Hlc".
    {  assert (Hlt: ns' < ns) by lia.
       apply num_laters_per_step_le in Hlt. apply Hlt. }
    iDestruct (lc_split with "Hlc") as "(Hlc&Hlc2)".
    iDestruct ("Hwp" with "Hlc2") as "Hwp".
    iDestruct ("Hwp" $! _) as "(Hwp&_)".
    iSpecialize ("Hwp" $! _ _ _ _ _ _ _ with "Hσ Hg HNC Hlc").
    iMod "Hwp".
    iMod "Hwp". iModIntro. iModIntro.
    iNext.
    iApply (step_fupd_extra.step_fupd2N_wand with "Hwp").
    iIntros "($&H)".
    iIntros. iMod ("H" with "[//]") as "(Hσ&Hg&Hwp&$)".
    iMod (later_tok_incr with "[$]") as "(Hg&Htok')".
    iFrame.
    iMod (global_state_interp_le _ ((step_count_next ns)) _ _ with "Hg") as "Hg".
    { apply Nat.le_succ_l, step_count_next_mono. lia. }
    iFrame.
    iApply (wpc0_strong_mono with "Hwp"); try reflexivity.
    iModIntro. iSplit.
    * iIntros (?) "H". iModIntro. iApply "H"; eauto.
    * iIntros "H". iModIntro. iApply "H"; eauto.
  - iIntros (g ns D κs) "Hg HC Hlc".
    iMod (later_tok_decr with "[$]") as (ns' Heq) "Hg".
    iMod (fupd2_mask_subseteq ∅ ∅) as "H"; [ set_solver+ | set_solver+ |].
    iDestruct (lc_weaken ((num_laters_per_step ns') + 2) with "Hlc") as "Hlc".
    {  assert (Hlt: ns' < ns) by lia.
       apply num_laters_per_step_le in Hlt. lia. }
    iApply (step_fupd_extra.step_fupd2N_le (S (S (num_laters_per_step ns'))) (num_laters_per_step ns)).
    { assert (Hlt: ns' < ns) by lia.
      apply num_laters_per_step_lt2 in Hlt. lia.
    }
    rewrite Nat.iter_succ. iModIntro. iModIntro. iNext.
    rewrite Nat.iter_succ. iModIntro. iModIntro. iNext.
    iMod "H".
    iDestruct (lc_split with "Hlc") as "(Hlc&Hlc2)".
    iDestruct ("Hwp" with "Hlc2") as "Hwp".
    iDestruct ("Hwp" $! _) as "(_&Hwp)".
    iMod ("Hwp" with "[$] [$] [$]") as "Hwp".
    iModIntro.
    iApply (step_fupd_extra.step_fupd2N_wand with "Hwp"). iIntros "Hwp".
    iMod "Hwp" as "(Hg&HΦc)".
    iMod (later_tok_incr with "[$]") as "(Hg&Htok')".
    iMod (global_state_interp_le _ ns _ _ with "Hg") as "Hg".
    { lia. }
    iFrame.
    iModIntro. by iApply "HΦc".
Qed.

Lemma wpc_later_tok_use2 s E e Φ Φc :
  language.to_val e = None →
  later_tok -∗
  ▷▷ WPC e @ s; E {{ v, later_tok -∗ Φ v }} {{ later_tok -∗ Φc }} -∗
  WPC e @ s; E {{ Φ }} {{ Φc }}.
Proof.
  iIntros (?) "Htok Hwp". iApply (wpc_later_tok_use2_credits with "[$]"); auto.
  iIntros "[Hlc1 Hlc2]".
  iApply fupd_wpc.
  iApply (lc_fupd_add_later with "[$]").
  iApply (lc_fupd_add_later with "[$]").
  do 2 iNext. iModIntro.
  iApply "Hwp".
Qed.

Lemma wpc_later_tok_use s E e Φ Φc :
  language.to_val e = None →
  later_tok -∗
  ▷ WPC e @ s; E {{ v, later_tok -∗ Φ v }} {{ later_tok -∗ Φc }} -∗
  WPC e @ s; E {{ Φ }} {{ Φc }}.
Proof.
  iIntros (Hnval) "Htok Hwp".
  iApply (wpc_later_tok_use2 with "[$]"); auto.
Qed.

Lemma wpc_later_tok_invest s E e Φ Φc :
  language.to_val e = None →
  later_tok -∗
  WPC e @ s; E {{ v, Nat.iter 10 (λ P, later_tok ∗ P) True%I -∗ Φ v }} {{ Φc }} -∗
  WPC e @ s; E {{ Φ }} {{ Φc }}.
Proof.
  iIntros (Hnval) "Htok Hwp".
  rewrite ?wpc_unfold /wpc_pre.
  rewrite Hnval.
  iIntros (mj).
  iSplit.
  - iIntros (q σ1 g1 ns D κ κs nt) "Hσ Hg HNC Hlc".
    iMod (later_tok_decr with "[$]") as (ns' Heq) "Hg".
    iMod (fupd2_mask_subseteq ∅ ∅) as "H"; [ set_solver+ | set_solver+ |].
    iModIntro. simpl. iModIntro. iNext. iMod "H" as "_".
    iDestruct ("Hwp" $! _) as "(Hwp&_)".
    iSpecialize ("Hwp" $! _ _ _ _ _ _ _ with "Hσ Hg HNC [Hlc]").
    { iApply (lc_weaken with "Hlc").
      assert (Hlt: ns' < ns) by lia.
      apply num_laters_per_step_lt2 in Hlt. lia. }
    iMod "Hwp".
    iApply (step_fupd_extra.step_fupd2N_le (S (num_laters_per_step ns')) (num_laters_per_step ns)
              with "[Hwp]").
    { assert (Hlt: ns' < ns) by lia.
      apply num_laters_per_step_lt in Hlt. lia.
    }
    iApply (step_fupd_extra.step_fupd2N_wand with "Hwp").
    iNext. iIntros "($&H)".
    iIntros. iMod ("H" with "[//]") as "(Hσ&Hg&Hwp&$)".
    iFrame.
    iMod (later_tok_incrN 10 with "[$]") as "(Hg&Htoks)".
    iMod (global_state_interp_le _ ((step_count_next ns)) _ _ with "Hg") as "Hg".
    { by apply step_count_next_add. }
    iFrame.
    iApply (wpc0_strong_mono with "Hwp"); try reflexivity.
    iModIntro. iSplit.
    * iIntros (?) "H". iModIntro. iApply "H"; eauto.
    * iIntros "H". iModIntro. iApply "H"; eauto.
  - iIntros (g ns D κs) "Hg HC Hlc".
    iMod (later_tok_decr with "[$]") as (ns' Heq) "Hg".
    iMod (fupd2_mask_subseteq ∅ ∅) as "H"; [ set_solver+ | set_solver+ |].
    iApply (step_fupd_extra.step_fupd2N_le (S (num_laters_per_step ns')) (num_laters_per_step ns)).
    { assert (Hlt: ns' < ns) by lia.
      apply num_laters_per_step_lt in Hlt. lia.
    }
    rewrite Nat.iter_succ. iModIntro. iModIntro. iNext.
    iMod "H". iDestruct ("Hwp" $! _) as "(_&Hwp)".
    iMod ("Hwp" with "[$] [$] [Hlc]") as "Hwp".
    { iApply (lc_weaken with "Hlc").
      assert (Hlt: ns' < ns) by lia.
      apply num_laters_per_step_lt2 in Hlt. lia. }
    iModIntro.
    iApply (step_fupd_extra.step_fupd2N_wand with "Hwp"). iIntros "Hwp".
    iMod "Hwp" as "(Hg&HΦc)".
    iMod (later_tok_incr with "[$]") as "(Hg&Htok')".
    iMod (global_state_interp_le _ ns _ _ with "Hg") as "Hg".
    { lia. }
    iFrame.
    iModIntro. eauto.
Qed.

Lemma wpc_later_tok_pure_step `{!Inhabited (state Λ)} `{!Inhabited (global_state Λ)} φ s E e1 e2 Φ Φc:
  PureExec φ 1 e1 e2 →
  φ →
  (Φc ∧ ((later_tok ∗ later_tok) -∗ WPC e2 @ s; E {{ Φ }} {{ Φc }})) -∗
  WPC e1 @ s; E {{ Φ }} {{ Φc }}.
Proof.
  iIntros (Hexec Hφ) "H".
  specialize (Hexec Hφ).
  inversion Hexec as [|? e1' e2' e3' [Hsafe ?] Hrest]. subst.
  inversion Hrest; subst.
  assert (∀ σ1 g1, reducible e1 σ1 g1).
  { intros. apply reducible_no_obs_reducible. eauto. }
  iApply wpc_lift_step.
  { unshelve (eapply reducible_not_val; eauto).
    { eapply inhabitant. }
    { eapply inhabitant. }
  }
  iSplit; last first.
  { iLeft in "H". eauto. }
  iIntros (????????) "Hs Hg".
  iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. iSplit.
  { iPureIntro. destruct s; eauto. }
  iNext. iIntros (e2' σ2' g2' efs Hstep).
  iMod (later_tok_incrN 2 with "[$]") as "(Hg&Htok)".
  iSpecialize ("H" with "[Htok]").
  { iDestruct "Htok" as "($&$&_)". }
  edestruct (pure_step_det _ _ _ _ _ _ _ Hstep) as (->&->&->&->&->).
  iFrame. iMod "Hclose".
  iMod (global_state_interp_le with "[$]") as "$".
  { etransitivity; last eapply step_count_next_iter. lia. }
  eauto.
Qed.

Lemma wp_later_tok_pure_step `{!Inhabited (state Λ)} `{!Inhabited (global_state Λ)} φ s E e1 e2 Φ:
  PureExec φ 1 e1 e2 →
  φ →
  ((later_tok ∗ later_tok) -∗ WP e2 @ s; E {{ Φ }}) -∗
  WP e1 @ s; E {{ Φ }}.
Proof.
  iIntros (Hexec Hφ) "H".
  rewrite wp_eq /wp_def.
  iApply wpc_later_tok_pure_step; auto.
Qed.

End res.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^414 - 17
Base: 51.75
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 51 + 3/4;
    bitwidth := 64;
    s := 2^414;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(**
  This file is a part of a formalisation of a subset of Core Erlang.

  In this file, we show example program equivalences in sequential Core Erlang.
*)
Require Import CTX.
Import ListNotations.

Lemma Equiv_refl :
  forall e Γ, EXP Γ ⊢ e -> e ≈[Γ]≈ e. Proof. intros. split; now apply CTX_refl. Qed.

Lemma Equiv_sym :
  forall e1 e2 Γ, e1 ≈[Γ]≈ e2 -> e2 ≈[Γ]≈ e1.
Proof.
  intros. destruct H; auto.
Qed.

Lemma Equiv_trans :
  forall e1 e2 e3 Γ, e1 ≈[Γ]≈ e2 -> e2 ≈[Γ]≈ e3
->
  e1 ≈[Γ]≈ e3.
Proof.
  intros. assert (Transitive (CTX Γ)). { apply CTX_IsPreCtxRel. }
  destruct H, H0. split.
  * eapply H1; eauto.
  * eapply H1; eauto.
Qed.

Corollary let_abs : forall e2 v x,
  EXP 1 ⊢ e2 -> VALCLOSED v ->
  e2.[v/] ≈ ELet x v e2.
Proof.
  intros. split; now apply CIU_iff_CTX, CIU_beta_value.
Qed.

Corollary let_abs_core : forall Γ e2 v x,
  EXP S Γ ⊢ e2 -> VAL Γ ⊢ v ->
  e2.[v/] ≈[Γ]≈ ELet x v e2.
Proof.
  intros. split; now apply CIU_iff_CTX, CIU_beta_value.
Qed.

Corollary beta_abs : forall {Γ e vl vals},
  VAL Γ ⊢ EFun vl e -> Forall (fun v => VAL Γ ⊢ v) vals -> length vl = length vals ->
  e.[list_subst (EFun vl e :: vals) idsubst] ≈[Γ]≈ EApp (EFun vl e) vals.
Proof.
  intros. split; now eapply CTX_beta_values.
Qed.

Ltac cpb_term :=
match goal with
| [ H : | _, EApp _ _ | _ ↓ |- _ ] => inversion H; subst; try inversion_is_value; clear H
| [ H : | _, EBIF _ _ | _ ↓ |- _ ] => inversion H; subst; try inversion_is_value; clear H
| [ H : | _, ELet _ _ _ | _ ↓ |- _ ] => inversion H; subst; try inversion_is_value; clear H
| [ H : | _, ELetRec _ _ _ _ | _ ↓ |- _ ] => inversion H; subst; try inversion_is_value; clear H
| [ H : | _, ECase _ _ _ _ | _ ↓ |- _ ] => inversion H; subst; try inversion_is_value; clear H
| [ H : | _ :: _, _ | _ ↓ |- _ ] => inversion H; subst; try inversion_is_value; clear H
end.

Ltac term_step :=
match goal with
| [ H : | ?Fs, ?e | _ ↓, H1 : ⟨ ?Fs, ?e ⟩ -[_]-> ⟨_, _⟩ |- _ ] =>
  eapply (terminates_step_any_2 _ _ _ _ H) in H1 as ?P
end.

Theorem plus_comm : forall Γ e1 e2,
  EXP Γ ⊢ e1 -> EXP Γ ⊢ e2 ->
  EBIF (ELit "+"%string) [e1; e2] ≈[Γ]≈ EBIF (ELit "+"%string) [e2; e1].
Proof.
  assert (forall e1 e2, EXPCLOSED e1 -> EXPCLOSED e2 -> CIU (EBIF (ELit "+"%string) [e1; e2]) (EBIF (ELit "+"%string) [e2; e1])). {
    split. 2: split. 1-2: constructor; eauto.
    1-2: intros; destruct i; simpl in *; [auto | destruct i; [auto | lia ] ].
    intros. destruct H2.
    do 2 cpb_term.
    apply term_eval_both in H9 as Eval1; auto.
    destruct Eval1 as [v1 [k1 [v_v1 [Eval1_1 Eval1_2]]]]. term_step.
    cpb_term.
    apply term_eval_both in H13 as Eval1; auto.
    destruct Eval1 as [v2 [k2 [v_v2 [Eval2_1 Eval2_2]]]].
    term_step.
    cpb_term.
    exists (3 + k1 + k2 + S k3). simpl.
    constructor. constructor. auto.

    eapply term_step_term.
    eapply frame_indep_nil in Eval2_1. exact Eval2_1.
    replace (S (k1 + k2 + S k3) - k2) with (S (k1 + S k3)) by lia.

    constructor; auto. 2: lia.
    eapply term_step_term.
    eapply frame_indep_nil in Eval1_1. exact Eval1_1.
    replace (k1 + S k3 - k1) with (S k3) by lia.

    constructor.
    now rewrite Z.add_comm. lia.
  }
  intros. split; eapply CIU_iff_CTX; intro; intros; simpl; apply H.
  all: apply -> subst_preserves_scope_exp; eauto.
Qed.

Corollary eval_equiv :
  forall e1 v : Exp, EXPCLOSED e1 -> ⟨ [], e1 ⟩ -->* v
->
  e1 ≈ v.
Proof.
  apply CTX_eval.
Qed.

Theorem let_delay : forall Γ e x e',
  EXP Γ ⊢ e -> EXPCLOSED e' -> | [], e' | ↓ ->
  e ≈[Γ]≈ ELet x e' (rename (fun n => S n) e).
Proof.
  intros. split; eapply CIU_iff_CTX; intro; intros; simpl; split;
    [idtac|split|idtac|split]. 2, 4: constructor.
  3, 5: rewrite renaming_is_subst.
  1, 3-4, 7: apply -> subst_preserves_scope_exp; eauto.
  1-4: apply -> subst_preserves_scope_exp; eauto.
  1-2: intro; intros; simpl; lia.
  1-2: intro; intros; inversion H3.
  * intros. destruct H4, H1.
    apply term_eval in H1. destruct H1, H1, H1.
    eapply frame_indep_nil in H5. assert (e'.[ξ] = e').
    { rewrite eclosed_ignores_sub; auto. } rewrite H6 in *.
    exists (S (x3 + S x0)). constructor.
    eapply term_step_term. simpl in H5. exact H5.
    replace (x3 + S x0 - x3) with (S x0) by lia.

    constructor; auto. 2: lia.
    rewrite renaming_is_subst, subst_comp, subst_extend, subst_comp.
    replace (ren (fun n : nat => S n) >> inl x2 .:: ξ) with (ξ) by reflexivity. auto. auto.
  * intros. destruct H4. cpb_term.
    apply term_eval_both in H10 as H10'. destruct H10' as [v [k0 [v_v [Eval1 Eval2]]]].
    term_step.
    cpb_term. exists k1.
    rewrite renaming_is_subst, subst_comp, subst_extend, subst_comp in H11.
    exact H11. now rewrite eclosed_ignores_sub.
Qed.

Theorem eta_abstraction Γ e :
  EXP Γ ⊢ e ->
  e ≈[Γ]≈ EApp (EFun [] (rename (fun n => S n) e)) [].
Proof.
  intros. split; eapply CIU_iff_CTX; intro; intros; simpl; split;
  [idtac|split|idtac|split].
  2, 4: constructor. 2, 4: do 2 constructor.
  all: try apply -> subst_preserves_scope_exp; eauto.
  3-4: intros; inversion H1.
  1-2: rewrite renaming_is_subst; apply -> subst_preserves_scope_exp; eauto.
  1-2: intro; intros; simpl; lia.
  * intros. destruct H2 as [x H2]. exists (S (S x)).
    constructor. constructor.
    rewrite renaming_is_subst, subst_comp, subst_comp, subst_extend, subst_comp.
    now replace (ren (fun n : nat => S n) >> EFun [] e.[ren (fun n : nat => S n) >> up_subst ξ] .: ξ) with ξ by reflexivity.
  * intros. destruct H2 as [x H2].
    inversion H2; subst; try inversion_is_value.
    inversion H7; subst.
    rewrite renaming_is_subst, subst_comp, subst_comp, subst_extend, subst_comp in H5.
    replace (ren (fun n : nat => S n) >> EFun [] e.[ren (fun n : nat => S n) >> up_subst ξ] .: ξ) with ξ in H5 by reflexivity. now exists k0.
Qed.

Theorem general_eta_abstraction Γ e vl vals :
  length vl = length vals -> EXP Γ ⊢ e -> Forall (fun v => VALCLOSED v) vals ->
  e ≈[Γ]≈ EApp (EFun vl (rename (fun n => S (length vl) + n) e)) vals.
Proof.
  intros. split; eapply CIU_iff_CTX; intro; intros; simpl; split;
  [idtac|split|idtac|split].
  2, 4: constructor. 2, 4: do 2 constructor.
  1,7: try apply -> subst_preserves_scope_exp; eauto.
  1-2: rewrite renaming_is_subst, subst_comp; apply -> subst_preserves_scope_exp; eauto.
  1-2: apply substcomp_scoped with (Δ := S (length vl) + Γ).
  2, 4 : now apply up_scope, upn_scope.
  1-2: intro; intros; cbn; lia.
  1-2: intros; rewrite Forall_nth in H1; apply scoped_val.
  1-2: now replace (ELit 0%Z) with ((ELit 0%Z).[ξ]) by auto; rewrite map_nth;
    rewrite map_length in H3;
    apply vclosed_sub_closed, H1.
  * intros. destruct H4 as [k H4].
    eexists. apply term_app_in_k.
    - shelve.
    - now rewrite map_length.
    - eapply Forall_map; auto. eapply Forall_impl. 2: exact H1. intros.    now apply vclosed_sub_closed.
    - repeat rewrite renaming_is_subst, subst_comp, subst_comp in *.
      fold_upn. fold_list_subst.
      replace (fun n => S (length vl + n)) with (fun n => S (length vl) + n) by auto.
      rewrite rename_upn_list_subst. exact H4.
      simpl. rewrite map_length. auto.
  * intros. destruct H4 as [k H4].
    epose proof (full_eval_app_partial (rename (fun n : nat => S (Datatypes.length vl + n)) e).[
          up_subst (upn (Datatypes.length vl) ξ)] (map (subst ξ) vals) vl F _ _).
    repeat rewrite renaming_is_subst, subst_comp, subst_comp in H5.
    fold_upn_hyp. fold_list_subst_hyp.
    replace (fun n => S (length vl + n)) with (fun n => S (length vl) + n) in H5 by auto.
    rewrite substcomp_assoc in H5.
    rewrite rename_upn_list_subst in H5.
    eexists. eapply terminates_step_any_2. exact H4.
    rewrite renaming_is_subst, subst_comp. simpl in H5. apply H5.
    simpl. rewrite indexed_to_forall in H1. rewrite indexed_to_forall.
    intros. rewrite map_nth, vclosed_ignores_sub. apply H1. rewrite map_length in H6. auto.
    apply H1. rewrite map_length in H6. auto.
    simpl. rewrite map_length. lia.
  Unshelve.
    3: rewrite map_length; lia.
    3: exact (ELit 0%Z).
    all: simpl; constructor; rewrite renaming_is_subst, subst_comp, Nat.add_0_r.
    all: apply -> subst_preserves_scope_exp; [ exact H0 | ]; apply substcomp_scoped with (Δ := Γ + S (length vl)).
    + intro. intros. simpl. lia.
    + rewrite Nat.add_comm. simpl. apply up_scope. rewrite <- (Nat.add_0_r (length vl)) at 2.
      apply upn_scope. auto.
    + intro. intros. simpl. lia.
    + rewrite Nat.add_comm. simpl. apply up_scope. rewrite <- (Nat.add_0_r (length vl)) at 2.
      apply upn_scope. auto.
Qed.

Definition naive_equivalent (e1 e2 : Exp) : Prop :=
  forall v F, FSCLOSED F /\ EXPCLOSED e1 /\ EXPCLOSED e2 /\
    (⟨ F, e1 ⟩ -->* v -> ⟨ F, e2 ⟩ -->* v).

Theorem naive_equivalent_implies_ciu :
  forall e1 e2,
  naive_equivalent e1 e2 -> CIU e1 e2.
Proof.
  unfold naive_equivalent, CIU; intros.
  split; [|split].
  1-2: apply H. 1,3: exact (ELit 0%Z). 1-2: exact [].
  intros. apply terminates_eq_terminates_sem in H1 as [v H1].
  apply H in H1. now apply ex_intro, terminates_eq_terminates_sem in H1.
Qed.

(* Definition unfold_app (l : list Var) (l2 : list Exp) (b : Exp) : Exp :=
  fold_right (fun '(x, e) Acc => ELet x e (rename (fun n => S n) Acc)) b (combine l l2). *)

Fixpoint n_vars (n : nat) : list Exp :=
match n with
| 0 => []
| S n' => EVar n' :: n_vars n'
end.

Fixpoint unfold_app (l : list Var) (l2 : list Exp) (body : Exp) : option Exp :=
match l, l2 with
| [], [] => Some body
| x::xs, e::es =>
         match (unfold_app xs (map (rename (fun n => S n)) es) body) with
         | None => None
         | Some e' => Some (ELet x e e')
         end
| _, _ => None
end.

Theorem unfold_app_length : forall xs es b,
  length xs = length es ->
  unfold_app xs es b = None -> False.
Proof.
  induction xs; intros.
  * apply eq_sym, length_zero_iff_nil in H. subst. inversion H0.
  * apply element_exist in H as H'. destruct H', H1. subst. inversion H.
    simpl in H0. break_match_hyp. inversion H0.
    eapply IHxs. 2: exact Heqo. rewrite map_length. auto.
Qed.

Theorem CIU_evaluates :
  forall e1 e2 v, EXPCLOSED e1 -> EXPCLOSED e2 ->
  ⟨[], e1⟩ -->* v -> ⟨[], e2⟩ -->* v ->
  CIU e1 e2.
Proof.
  intros.
  split. 2: split. 1-2: auto.
  intros.
  destruct H1 as [CL1 [k1 H1]], H2 as [CL2 [k2 H2]].
  apply frame_indep_nil with (Fs' := F) in H2. simpl in H2.
  apply frame_indep_nil with (Fs' := F) in H1. simpl in H1.
  destruct H4 as [k1' H4].
  eapply terminates_step_any_2 in H1. 2: exact H4.
  eapply term_step_term_plus in H2. 2: exact H1.
  now exists (k2 + (k1' - k1)).
Qed.

Theorem map_foldr_equiv :
  forall l' l x y z e f
  (VsCL : VALCLOSED l) (SCE : EXP 2 ⊢ e),
  computes x e f -> cons_to_list l = Some l' ->
  CIU (obj_map (EFun [x] e) l) (obj_foldr (EFun [y;z] (ECons (EApp (EFun [x] e) [EVar 1]) (EVar 2))) l ENil).
Proof.
  intros.
  pose proof (obj_foldr_on_meta_level l' l x y z e f VsCL SCE H H0).
  pose proof (obj_map_on_meta_level l' l x e f VsCL SCE H H0).
  eapply CIU_evaluates; eauto.
  {
    unfold obj_map. do 3 constructor; auto; simpl.
    - constructor. simpl. constructor; auto.
      cbn. constructor; auto.
      destruct i. 2: destruct i.
      all: constructor. lia.
    - do 2 constructor; auto. simpl in H3.
      destruct i. 2: destruct i. 3: destruct i. all: constructor. all: lia.
    - simpl in *. destruct i. 2: destruct i.
      constructor; simpl. now apply (proj2 (scope_ext_app 3 2 ltac:(lia))).
      now apply (proj1 (scope_ext_app 1 0 ltac:(lia))).
      lia.
  }
  {
    unfold obj_map. do 3 constructor; auto; simpl.
    - do 2 constructor; auto.
    - intros. destruct i. 2: destruct i. 3: destruct i.
      constructor. constructor. lia.
      all: auto.
      constructor. do 2 constructor. lia. simpl.
      intros. destruct i. 2: destruct i. 3: destruct i.
      1-3: do 2 constructor. all: lia.
    - do 2 constructor; auto.
    - simpl in *. destruct i. 2: destruct i. 3: destruct i.
      do 3 constructor; simpl. all: auto.
      + do 2 constructor. simpl. now apply (proj2 (scope_ext_app 6 2 ltac:(lia))).
      + intros. destruct i. do 2 constructor. all: lia.
      + now apply (proj1 (scope_ext_app 1 0 ltac:(lia))).
      + lia.
  }
Qed.

Theorem map_foldr_equiv_rev :
  forall l' l x y z e f
  (VsCL : VALCLOSED l) (SCE : EXP 2 ⊢ e),
  computes x e f -> cons_to_list l = Some l' ->
  CIU (obj_foldr (EFun [y;z] (ECons (EApp (EFun [x] e) [EVar 1]) (EVar 2))) l ENil) (obj_map (EFun [x] e) l).
Proof.
  intros.
  pose proof (obj_foldr_on_meta_level l' l x y z e f VsCL SCE H H0).
  pose proof (obj_map_on_meta_level l' l x e f VsCL SCE H H0).
  eapply CIU_evaluates; eauto.
  2: {
    unfold obj_map. do 3 constructor; auto; simpl.
    - constructor. simpl. constructor; auto.
      cbn. constructor; auto.
      destruct i. 2: destruct i.
      all: constructor. lia.
    - do 2 constructor; auto. simpl in H3.
      destruct i. 2: destruct i. 3: destruct i. all: constructor. all: lia.
    - simpl in *. destruct i. 2: destruct i.
      constructor; simpl. now apply (proj2 (scope_ext_app 3 2 ltac:(lia))).
      now apply (proj1 (scope_ext_app 1 0 ltac:(lia))).
      lia.
  }
  {
    unfold obj_map. do 3 constructor; auto; simpl.
    - do 2 constructor; auto.
    - intros. destruct i. 2: destruct i. 3: destruct i.
      constructor. constructor. lia.
      all: auto.
      constructor. do 2 constructor. lia. simpl.
      intros. destruct i. 2: destruct i. 3: destruct i.
      1-3: do 2 constructor. all: lia.
    - do 2 constructor; auto.
    - simpl in *. destruct i. 2: destruct i. 3: destruct i.
      do 3 constructor; simpl. all: auto.
      + do 2 constructor. simpl. now apply (proj2 (scope_ext_app 6 2 ltac:(lia))).
      + intros. destruct i. do 2 constructor. all: lia.
      + now apply (proj1 (scope_ext_app 1 0 ltac:(lia))).
      + lia.
  }
Qed.


(*
Pretty print for terms with bruijn indices
(it might be easier to go the other way
and print coq terms with indices)

For a complete pretty print with names
unquote and use Coqs Print Command

It is useful as debugging if a term does not type
 *)

Require Import MetaCoq.Template.All.
Require Import List String.
Require Import Ascii.
Require Import Program Arith Lia PeanoNat.
Import ListNotations MonadNotation Nat.

Definition ascii_to_string (a:ascii) : string := String a (EmptyString).
Definition natToChar (n:nat) : ascii := ascii_of_nat(48+n).

Program Fixpoint natToString (n:nat) {measure n} : string :=
  match leb n 9 with
    true =>
    ascii_to_string (natToChar n)
  | false =>
    append (natToString (Nat.div n 10)) (ascii_to_string(natToChar(Nat.modulo n 10)))
  end.
Next Obligation.
  symmetry in Heq_anonymous.
  apply leb_complete_conv in Heq_anonymous.
  pose proof (divmod_spec n 9 0 9).
  destruct divmod.
  destruct H;trivial.
  cbn. lia.
Qed.

Infix ":s" := String (at level 73).
Infix "+s" := append (at level 72).
Definition linebreak := ascii_to_string(ascii_of_nat 10).

Definition join (xs:list string) : string :=
  fold_left append xs EmptyString.

(* needed for mutual inductive types *)
Definition getInductiveName (ind:kername) (indIndex:nat) :TemplateMonad string :=
  ind <- tmQuoteInductive ind;;
  tmEval lazy match nth_error ind.(ind_bodies) indIndex with
           | None => ""
           | Some b => b.(ind_name)
              end.

Definition getConstructName (ind:kername) (indIndex:nat) (consIndex:nat) :TemplateMonad string :=
  ind <- tmQuoteInductive ind;;
  tmEval lazy match nth_error ind.(ind_bodies) indIndex with
           | None => ""
           | Some b => match nth_error b.(ind_ctors) consIndex with
                        None => ""
                      | Some (s,_,_) => s
                      end
           end.

Definition nameToString (s:name) : string :=
  match s with
    nAnon => "_"
  | nNamed s => s
  end.

Definition concatString (xs:list string) : string :=
  fold_left (fun a b => a +s b) xs "".

Fixpoint bruijn_print_aux (t:term) : TemplateMonad string :=
  match t with
  | tRel n => tmReturn("R" :s (natToString n))
  | tVar ident => tmReturn(ident)
  | tEvar n xs => tmReturn "TODO:EVAR"
  | tSort univ =>
    tmReturn ((fix f xs :=
       let g := (fun s =>
                   match s with
                   | Level.lProp => "Prop"
                   | Level.lSet => "Set"
                   | Level.Level s => "L":s s
                   | Level.Var n => "V" :s (natToString n)
                   end
                ) in
       match xs with
       | NEL.sing (s,_) => g s
       | NEL.cons (a,_) ys => (g a) +s " " +s (f ys)
       end
    ) univ)
  | tCast t ck u => s <- bruijn_print_aux t;;
                     s2 <- bruijn_print_aux u;;
                     tmReturn("(":s s +s ":" +s s2 +s")")
  | tProd n t t2 => match n with
                   | nAnon => s1 <- bruijn_print_aux t;;
                             s2 <- bruijn_print_aux t2;;
                             tmReturn("(":s append s1 (append ") -> " s2))
                   | nNamed s => s1 <- bruijn_print_aux t;;
                                s2 <- bruijn_print_aux t2;;
                                tmReturn("∀ (" +s s +s (" : "+s s1) +s "), " +s s2)
                   end
  | tLambda s t t2 => s1 <- bruijn_print_aux t;;
                    s2 <- bruijn_print_aux t2;;
                    tmReturn("λ ("+s match s with
                        nAnon => "_"
                      | nNamed s => s
                      end
                     +s " : "+s s1+s"). "+s s2)
  | tLetIn name t1 t2 t3 =>
    s1 <- bruijn_print_aux t1;;
    s2 <- bruijn_print_aux t2;;
    s3 <- bruijn_print_aux t3;;
    tmReturn("let "+s (nameToString name) +s " := "+s s1 +s " : " +s s2 +s " in "+s linebreak +s s3)
  | tApp t xs => s1 <- bruijn_print_aux t;;
      s2 <- (fix f xs :=
         match xs with
           [] => tmReturn ""
         | x::xs => s3 <- bruijn_print_aux x;;
                  s4 <- f xs;;
                  (* tmReturn(" (" +s s3 +s ")" +s s4) *)
                  tmReturn(" (" +s s3 +s ")" +s s4)
         end
           ) xs;;
      (* tmReturn("("+s"("+s s1+s")" +s s2 +s ")") *)
      tmReturn("("+s s1 +s s2 +s ")")
  | tConst kn ui => tmReturn(kn)
  | tInd ind ui => getInductiveName ind.(inductive_mind) ind.(inductive_ind)
  | tConstruct ind n ui => getConstructName ind.(inductive_mind) ind.(inductive_ind) n
  | tCase (ind,n) p c brs =>
    sc <- bruijn_print_aux c;;
    sp <- bruijn_print_aux p;;
    sb <- fold_left (fun sa x => match x with (n,t) => st <- bruijn_print_aux t;;sb <- sa;;tmReturn (sb +s " | ("+s(natToString n)+s") " +s st +s linebreak) end) brs (tmReturn "");;
    tmReturn(linebreak +s "match (P:" +s (natToString n) +s ") "+s sc +s " return " +s sp +s " with" +s linebreak +s
            sb +s
             "end")
  | tProj p t => tmReturn "TODO:Proj"
  | tFix mf n =>
    (fix f xs := match xs with
                  nil => tmReturn ""
                | mfb::xs =>
                  sr <- f xs;;
          stype <- bruijn_print_aux (mfb.(dtype));;
          sbody <- bruijn_print_aux (mfb.(dbody));;
          tmReturn (linebreak +s "(fix "+s (nameToString mfb.(dname)) +s " : " +s stype +s " := " +s linebreak +s sbody +s ") "+s sr)
                end
    ) mf
  | _ => tmReturn "TODO"
  end.

Definition bruijn_print (t:term) : TemplateMonad unit :=
  s <- bruijn_print_aux t;;
  val <- tmEval lazy s;;
  tmPrint val.


Require Import
        Coq.Vectors.Vector
        Coq.Vectors.Vector
        Coq.Lists.List
        Coq.Strings.String
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.ilist
        Fiat.Common.StringBound
        Coq.Program.Program
        Fiat.QueryStructure.Specification.Representation.Notations.

(* Notations for attributes. *)

Record Attribute :=
  { attrName : string;
    attrType : Type }.

Infix "::" := Build_Attribute : Attribute_scope.

Bind Scope Attribute_scope with Attribute.

Definition attrName_eq (cs : Attribute) (idx : string) :=
  if (string_dec (attrName cs) idx) then true else false .

(* A heading describes a tuple as a set of Attributes
   and types. *)
Record RawHeading :=
  { NumAttr : nat;
    AttrList : Vector.t Type NumAttr }.

Definition Attributes (heading : RawHeading) : Set := Fin.t (NumAttr heading).

Definition Domain (heading : RawHeading) (idx : Attributes heading) : Type :=
  Vector.nth (AttrList heading) idx.
Arguments Domain : clear implicits.

(* Notations for schemas. *)

Record Heading :=
  { HeadingRaw :> RawHeading;
    HeadingNames : Vector.t string (NumAttr HeadingRaw) }.

Definition BuildHeading
           {n}
           (attrs : Vector.t Attribute n)
  : Heading :=
  {| HeadingRaw := {| NumAttr := n;
                      AttrList := Vector.map attrType attrs |};
     HeadingNames := Vector.map attrName attrs |}.

(* Notation for schemas built from [BuildHeading]. *)

Notation "< col1 , .. , coln >" :=
  (BuildHeading (@Vector.cons _ col1%Attribute _ .. (Vector.cons _ coln%Attribute _ (Vector.nil _)) ..))
  : Heading_scope.

(* Extending Headings *)
Definition AppendRawHeading (h1 h2 : RawHeading) : RawHeading :=
  {| NumAttr := NumAttr h1 + NumAttr h2;
     AttrList := Vector.append (AttrList h1) (AttrList h2) |}.

Definition AppendHeading (h1 h2 : Heading) : Heading :=
  {| HeadingRaw := AppendRawHeading (HeadingRaw h1) (HeadingRaw h2);
     HeadingNames := Vector.append (HeadingNames h1) (HeadingNames h2) |}.

Notation " h1 ++ h2 " := (AppendHeading h1%Heading h2%Heading) : Heading_scope.


(* Check coercions in patterns *)

Inductive I : Set :=
  | C1 : nat -> I
  | C2 : I -> I.

Coercion C1 : nat >-> I.

(* Coercion at the root of pattern *)
Check (fun x => match x with
                | C2 n => 0
                | O => 0
                | S n => n
                end).

(* Coercion not at the root of pattern *)
Check (fun x => match x with
                | C2 O => 0
                | _ => 0
                end).

(* Unification and coercions inside patterns *)
Check
  (fun x : option nat => match x with
                         | None => 0
                         | Some O => 0
                         | _ => 0
                         end).

(* Coercion up to delta-conversion, and unification *)
Coercion somenat := Some (A:=nat).
Check (fun x => match x with
                | None => 0
                | O => 0
                | S n => n
                end).

(* Coercions with parameters *)
Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Inductive I' : nat -> Set :=
  | C1' : forall n : nat, listn n -> I' n
  | C2' : forall n : nat, I' n -> I' n.

Coercion C1' : listn >-> I'.
Check (fun x : I' 0 => match x with
                       | C2' _ _ => 0
                       | niln => 0
                       | _ => 0
                       end).
Check (fun x : I' 0 => match x with
                       | C2' _ niln => 0
                       | _ => 0
                       end).

(* Check insertion of coercions around matched subterm *)

Parameter A:Set.
Parameter f:> A -> nat.

Inductive J : Set := D : A -> J.

Check (fun x => match x with
                | D 0 => 0
                | D _ => 1
                end).

(* Check coercions against the type of the term to match *)
(* Used to fail in V8.1beta *)

Inductive C : Set := c : C.
Inductive E : Set := e :> C -> E.
Check fun (x : E) => match x with c => e c end.

(* Check coercions with uniform parameters (cf bug #1168) *)

Inductive C' : bool -> Set := c' : C' true.
Inductive E' (b : bool) : Set := e' :> C' b -> E' b.
Check fun (x : E' true) => match x with c' => e' true c' end.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	            Relations between UA and Adjunctions      		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export CoUniversalArrow.
Require Export Adjunction.

Set Implicit Arguments.
Unset Strict Implicit.

(* extraction d'un UA et d'un coUA a` partir d'un adjonction *)

Section adj_to_ua.

Variables (C D : Category) (F : Functor D C) (G : Functor C D) (ad : Adj F G).
Variable d : D.

(* Prouver que pour tout d, <F(d),phi(Id(F(d)))> est UA de d vers G *)

Definition Unit_ob := F d.

Definition Unit_arrow := ApAphi ad (Id (F d)).

Definition Unit_arrow_diese (c : C) (f : d --> G c) := ApAphi_inv ad f.

(* qq c:C. qq f:d->Gc. f=phi<d,Fd>(Id(Fd)) o G(phi-1<d,c>(f)) (@) *)
(* remarquons que phi<d,c>(Id(Fd) o phi-1<d,c>(f)) = f *)
(* donc (@) est une instance de Adj_eq3 *)

Lemma Unit_UAlaw1 : UA_law1 Unit_arrow Unit_arrow_diese.
Proof.
unfold UA_law1, UA_eq, Unit_arrow_diese, Unit_arrow in |- *.
intros c1 f; apply Sym.
apply Trans with (ApAphi ad (Id (F d) o ApAphi_inv ad f)).
apply Trans with (ApAphi ad (ApAphi_inv ad f)).
apply Sym; exact (Idl_inv (NTa_areIso ad (Build_POb1 d c1)) f).
apply AphiPres; apply Idl1.
apply (Adj_eq3 ad (ApAphi_inv ad f) (Id (F d))).
Qed.

(* qq c1:C. qq f:d->Gc1. qq f':Fd->c1. *)
(* phi<d,Fd>(Id(Fd)) o G(f') = f (@) *)
(* => f'=phi-1<d,c1>(f) *)
(* appliquer phi-1<d,c1> aux 2 membres de (@) *)
(* En appliquant Adj_eq5, on obtient le re'sultat souhaite' *)

Lemma Unit_UAlaw2 : UA_law2 Unit_arrow Unit_arrow_diese.
Proof.
unfold UA_law2, UA_eq, Unit_arrow_diese, Unit_arrow in |- *.
intros c1 f f' H.
apply Trans with (ApAphi_inv ad (ApAphi ad (Id (F d)) o FMor G f')).
apply Sym.
apply Trans with (ApAphi_inv ad (ApAphi ad (Id (F d))) o f').
apply (Adj_eq5 ad f' (ApAphi ad (Id (F d)))).
apply Trans with (Id (F d) o f').
apply Comp_r; apply (Idr_inv (NTa_areIso ad (Build_POb1 d (F d))) (Id (F d))).
apply Idl.
apply Aphi_invPres; apply H.
Qed.

Canonical Structure Unit' := Build_IsUA Unit_UAlaw1 Unit_UAlaw2.

Canonical Structure Unit := Build_UA Unit'.

(* Prouver que pour tout c, <G(c),phi-1(Id(G(c)))> est UA de c vers F *)

Variable c : C.

Definition CoUnit_ob := G c.

Definition CoUnit_arrow := ApAphi_inv ad (Id (G c)).

Definition CoUnit_arrow_diese (d : D) (f : F d --> c) := ApAphi ad f.

Lemma CoUnit_coUAlaw1 : CoUA_law1 CoUnit_arrow CoUnit_arrow_diese.
Proof.
unfold CoUA_law1, CoUA_eq, CoUnit_arrow_diese, CoUnit_arrow in |- *.
intros d1 f.
(* *) apply Trans with (ApAphi_inv ad (ApAphi ad f o Id (G c))).
apply Sym; apply (Adj_eq6 ad (ApAphi ad f) (Id (G c))).
(* *) apply Trans with (ApAphi_inv ad (ApAphi ad f)).
apply Aphi_invPres; apply Idr1.
apply (Idr_inv (NTa_areIso ad (Build_POb1 d1 c)) f).
Qed.

Lemma CoUnit_coUAlaw2 : CoUA_law2 CoUnit_arrow CoUnit_arrow_diese.
Proof.
unfold CoUA_law2, CoUA_eq, CoUnit_arrow_diese, CoUnit_arrow in |- *.
intros d1 f g H.
(* *) apply Trans with (ApAphi ad (FMor F g o ApAphi_inv ad (Id (G c)))).
(* *) apply Trans with (g o ApAphi ad (ApAphi_inv ad (Id (G c)))).
(* *) apply Trans with (g o Id (G c)).
apply Idr.
apply Comp_l; apply Sym.
apply (Idl_inv (NTa_areIso ad (Build_POb1 (G c) c)) (Id (G c))).
apply Sym; apply (Adj_eq4 ad g (ApAphi_inv ad (Id (G c)))).
apply AphiPres; apply H.
Qed.

Canonical Structure CoUnit' := Build_IsCoUA CoUnit_coUAlaw1 CoUnit_coUAlaw2.

Canonical Structure CoUnit := Build_CoUA CoUnit'.

End adj_to_ua.


Require Import Setoid Morphisms RelationClasses Program.Basics.
From ChargeCore.Logics Require Import ILogic IBILogic BILogic BILInsts ILInsts Pure ILEmbed.
From ChargeCore.SepAlg Require Import SepAlg.

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

Section PureBIInsts.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.
  Context {HPre : PreOrder rel}.

  Existing Instance SABIOps.
  Existing Instance SABILogic.
  Existing Instance pureop_bi_sepalg.
  Existing Instance pure_bi_sepalg.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.

  Transparent ILPre_Ops.
  Transparent SABIOps.

  Instance pure_ltrue : pure ltrue.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance pure_lfalse : pure lfalse.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance pure_land p q (Hp : pure p) (Hq : pure q) : pure (p //\\ q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lor p q (Hp : pure p) (Hq : pure q) : pure (p \\// q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_limpl p q (Hp : pure p) (Hq : pure q) : pure (p -->> q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro H.
    apply lforallL with h. apply lforallL; [reflexivity|].
    specialize (Hp h'' h); specialize (Hq h h'').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lsc p q (Hp : pure p) (Hq : pure q) : pure (p ** q).
  Proof.
    intros h h'; simpl.
    apply lexistsL; intro h''; apply lexistsL; intro h'''; apply lexistsL; intro H.
    destruct (sa_unit_ex h') as [u [Ha H1]].
    apply lexistsR with h'; apply lexistsR with u. apply lexistsR with H1.
    specialize (Hp h'' h'); specialize (Hq h''' u).
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lsi p q (Hp : pure p) (Hq : pure q) : pure (p -* q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro h'''; apply lforallR; intro H.
    destruct (sa_unit_ex h) as [u [Ha H1]].
    apply lforallL with u; apply lforallL with h; apply lforallL with H1.
    specialize (Hp h'' u); specialize (Hq h h''').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Context {C : Type} {ILC : ILogicOps C} {HCOp: EmbedOp C B} {HC: Embed C B}.

  Local Existing Instance EmbedILPreDropOp.
  Local Existing Instance EmbedILPreOp.
  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_bi_embed_drop (p : C) : pure (@embed C (ILPreFrm rel B) _ p).
  Proof.
    intros h h'; simpl; reflexivity.
  Qed.

  Instance pure_bi_embed (p : ILPreFrm rel C) (H : pure p) :
    pure (@embed (ILPreFrm rel C) (ILPreFrm rel B) _ p).
  Proof.
    intros h h'; simpl.
    specialize (H h h'). rewrite H. reflexivity.
  Qed.

End PureBIInsts.

Section PureIBIInsts.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.
  Context {HPre : PreOrder rel}.

  Existing Instance SAIBIOps.
  Existing Instance SAIBILogic.
  Existing Instance pureop_pure_ibi_sepalg.
  Existing Instance pure_ibi_sepalg.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.

  Transparent ILPre_Ops.
  Transparent SAIBIOps.

  Instance ibi_pure_ltrue : pure ltrue.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance ibi_pure_lfalse : pure lfalse.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance ibi_pure_emp : pure empSP.
  Proof.
    intros h h'; simpl; apply ltrueR.
  Qed.

  Instance ibi_pure_land p q (Hp : pure p) (Hq : pure q) : pure (p //\\ q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lor p q (Hp : pure p) (Hq : pure q) : pure (p \\// q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_limpl p q (Hp : pure p) (Hq : pure q) : pure (p -->> q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro H.
    apply lforallL with h. apply lforallL; [reflexivity|].
    specialize (Hp h'' h); specialize (Hq h h'').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lsc p q (Hp : pure p) (Hq : pure q) : pure (p ** q).
  Proof.
    intros h h'; simpl.
    apply lexistsL; intro h''; apply lexistsL; intro h'''; apply lexistsL; intro H.
    destruct (sa_unit_ex h') as [u [Ha H1]].
    apply lexistsR with h'; apply lexistsR with u. apply lexistsR with H1.
    specialize (Hp h'' h'); specialize (Hq h''' u).
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lsi p q (Hp : pure p) (Hq : pure q) : pure (p -* q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro h'''; apply lforallR; intro H.
    destruct (sa_unit_ex h) as [u [Ha H1]].
    apply lforallL with u; apply lforallL with h; apply lforallL with H1.
    specialize (Hp h'' u); specialize (Hq h h''').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Context {C : Type} {ILC : ILogicOps C} {HCOp: EmbedOp C B} {HC: Embed C B}.

  Local Existing Instance EmbedILPreDropOp.
  Local Existing Instance EmbedILPreOp.

  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_ibi_embed_drop (p : C) : pure (@embed C (ILPreFrm subheap B) _ p).
  Proof.
    intros h h'; simpl; reflexivity.
  Qed.

  Instance pure_ibi_embed (p : ILPreFrm subheap C) (H : pure p) :
    pure (@embed (ILPreFrm subheap C) (ILPreFrm subheap B) _ p).
  Proof.
    intros h h'; simpl.
    specialize (H h h'). rewrite H. reflexivity.
  Qed.

End PureIBIInsts.

Section PureEmbedFun.
  Context (T: Type).
  Context {A : Type} `{BIL: BILogic A}.
  Context {HIL : ILogic A}.
  Context {B : Type} {ILX : ILogicOps B} {HBOp: EmbedOp B A} {HB : Embed B A}.
  Context {POA : @PureOp A} {PA : Pure POA}.

  Existing Instance PureBILFunOp.
  Existing Instance PureBILFun.
  Existing Instance ILFun_Ops.
  Existing Instance ILFun_ILogic.
  Existing Instance BILFun_Ops.
  Existing Instance BILFunLogic.
  Existing Instance EmbedILFunDropOp.
  Existing Instance EmbedILFunDrop.
  Existing Instance EmbedILFunOp.
  Existing Instance EmbedILFun.

  Transparent EmbedILFunDropOp.
  Transparent EmbedILFunOp.

  Instance pure_embed_fun_drop (p : B) (H : pure (@embed B A _ p)) :
    pure (@embed B (T -> A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

  Instance pure_embed_fun (p : T -> B) (H : forall t, pure (@embed B A _ (p t))) :
    pure (@embed (T -> B) (T -> A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

End PureEmbedFun.

Section PureEmbedPre.
  Context T (ord: relation T) {HPre: PreOrder ord}.
  Context {A : Type} `{HBI: BILogic A}.
  Context {HIL : ILogic A}.
  Context {B : Type} {ILX : ILogicOps B} {HBOp: EmbedOp B A} {HB : Embed B A}.
  Context {POA : @PureOp A} {PA : Pure POA}.

  Existing Instance PureBILPreOp.
  Existing Instance PureBILPre.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.
  Existing Instance BILPre_Ops.
  Existing Instance BILPreLogic.
  Existing Instance EmbedILPreDropOp.
  Existing Instance EmbedILPreDrop.
  Existing Instance EmbedILPreOp.
  Existing Instance EmbedILPre.

  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_embed_pre_drop (p : B) (H : pure (@embed B A _ p)) :
    pure (PureOp := PureBILPreOp ord) (@embed B (ILPreFrm ord A) _ p).
  Proof.
    intros t. apply H.
  Qed.

  Instance pure_embed_pre (p : ILPreFrm ord B) (H : forall t, pure (@embed B A _ (ILPreFrm_pred p t))) :
    pure (PureOp := PureBILPreOp ord) (@embed (ILPreFrm ord B) (ILPreFrm ord A) _ p).
  Proof.
    intro t; apply H.
  Qed.

End PureEmbedPre.


(** * Some useful tools to manipulate lists of lists instead of multisets of multisets (and so to deal with the exchange rules) *)
Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.hseq.

Require Import CMorphisms.
Require Import Bool.

Require Import Lra.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Definition Allperm := (Forall2_inf (Permutation_Type (A:=Rpos * term))).

Lemma decomp_M_case : forall T1 T2 r D A,
    Permutation_Type (T1 ++ T2) (vec r A ++ D) ->
    {' (D1, D2, r1, r2) : _ &
                          prod (Permutation_Type r (r1 ++ r2))
                               ((Permutation_Type D (D1 ++ D2)) *
                                (Permutation_Type T1 (vec r1 A ++ D1)) *
                                (Permutation_Type T2 (vec r2 A ++ D2)))}.
Proof.
  intros T1 T2 r D A Hperm.
  revert T1 T2 D Hperm; induction r; intros T1 T2 D Hperm.
  - simpl in Hperm.
    split with (T1 , T2, nil, nil).
    simpl; repeat split; try Permutation_Type_solve.
  - simpl in Hperm.
    case (in_inf_app_or T1 T2 (a , A)).
    + apply Permutation_Type_in_inf with ((a, A) :: vec r A ++ D); try Permutation_Type_solve.
      left; reflexivity.
    + intros Hin.
      apply in_inf_split in Hin as [[l1 l2] Heq].
      destruct (IHr (l1 ++ l2) T2 D) as [[[[D1 D2] r1'] r2] [H1' [[H2 H3] H4]]].
      * apply Permutation_Type_cons_inv with (a, A).
        rewrite Heq in Hperm; Permutation_Type_solve.
      * split with (D1, D2, (a :: r1'), r2).
        rewrite Heq; simpl; repeat split; try Permutation_Type_solve.
    + intros Hin.
      apply in_inf_split in Hin as [[l1 l2] Heq].
      destruct (IHr T1 (l1 ++ l2) D) as [[[[D1 D2] r1'] r2] [H1' [[H2 H3] H4]]].
      * apply Permutation_Type_cons_inv with (a, A).
        rewrite Heq in Hperm; Permutation_Type_solve.
      * split with (D1, D2, r1', (a :: r2)).
        rewrite Heq; simpl; repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_ID_case : forall T D n r s t A,
    A <> HR_covar n ->
    A <> HR_var n ->
    Permutation_Type (vec s (HR_covar n) ++ vec t (HR_var n) ++ T) (vec r A ++ D) ->
    {' (Ta, Tb, Da, Db) : _ &
                          prod (Permutation_Type T (Ta ++ Tb))
                               ((Permutation_Type D (Da ++ Db)) *
                                (Permutation_Type (vec s (HR_covar n) ++ vec t (HR_var n)) Da) *
                                (Permutation_Type (vec r A) Ta) *
                                (Permutation_Type Tb Db)) }.
Proof.
  intros T D n r s t A Hnc Hnv Hperm.
  revert D r Hperm; induction s; [ induction t | ]; intros D r Hperm.
  - split with (vec r A , D, nil, D).
    repeat split; try assumption; try reflexivity.
  - simpl in *.
    assert (In_inf (a, HR_var n) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , HR_var n)).
      + apply Permutation_Type_in_inf with ((a, HR_var n) :: vec t (HR_var n) ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hnv.
        induction r; inversion i.
        * inversion H.
          apply Hnv; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHt D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, HR_var n).
      etransitivity; [ apply Hperm | ].
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, HR_var n):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
  - simpl in *.
    assert (In_inf (a, HR_covar n) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , HR_covar n)).
      + apply Permutation_Type_in_inf with ((a, HR_covar n) :: vec s (HR_covar n) ++ vec t (HR_var n) ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hnc.
        induction r; inversion i.
        * inversion H.
          apply Hnc; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHs D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, HR_covar n).
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, HR_covar n):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq : forall T D r s A B,
    A <> B ->
    Permutation_Type (vec s B ++ T) (vec r A ++ D) ->
    {' (Ta, Tb, Da, Db) : _ &
                          prod (Permutation_Type T (Ta ++ Tb))
                               ((Permutation_Type D (Da ++ Db)) *
                                (Permutation_Type (vec s B) Da) *
                                (Permutation_Type (vec r A) Ta) *
                                (Permutation_Type Tb Db)) }.
Proof.
  intros T D r s A B Hneq Hperm.
  revert D r Hperm; induction s; intros D r Hperm.
  - split with (vec r A , D, nil, D).
    repeat split; try assumption; try reflexivity.
  - simpl in *.
    assert (In_inf (a, B) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , B)).
      + apply Permutation_Type_in_inf with ((a, B) :: vec s B ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hneq.
        induction r; inversion i.
        * inversion H.
          apply Hneq; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHs D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, B).
      etransitivity; [ apply Hperm | ].
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, B):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_eq : forall T D r s A,
    Permutation_Type (vec s A ++ T) (vec r A ++ D) ->
    {' (a , b , c , T', D') : _ &
                     prod (Permutation_Type r  (a ++ b))
                          ((Permutation_Type s  (b ++ c)) *
                           (Permutation_Type T (vec a A ++ T')) *
                           (Permutation_Type D (vec c A ++ D')) *
                           (Permutation_Type T' D')) }.
Proof.
  intros T D r s A Hperm.
  revert D r Hperm; induction s; intros D r Hperm.
  + split with (r, nil, nil, D , D).
    repeat split; try Permutation_Type_solve.
  + simpl in Hperm.
    case (in_inf_app_or (vec r A) D (a , A)).
    * apply Permutation_Type_in_inf with ((a, A) :: vec s A ++ T); [apply Hperm | ].
      left; reflexivity.
    * intro Hin.
      assert { r' & Permutation_Type r (a :: r')}.
      { clear - Hin.
        induction r.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with r; simpl; reflexivity.
          + specialize (IHr Hin) as [r' Hperm].
            split with (a0 :: r').
            Permutation_Type_solve. }
      destruct X as [r' Hperm'].
      destruct (IHs D r') as [ [[[[a1 b1] c1] T'] D'] [H1 [[[H2 H3] H4] H5]]].
      { apply Permutation_Type_cons_inv with (a, A).
        transitivity (vec r A ++ D); try Permutation_Type_solve.
        change ((a, A) :: vec r' A ++ D) with (vec (a :: r') A ++ D).
        apply Permutation_Type_app; try reflexivity.
        apply vec_perm; apply Hperm'. }
      split with (a1 , a :: b1, c1, T' , D').
      repeat split; try Permutation_Type_solve.
    * intro Hin.
      destruct (Add_inf_inv _ _ Hin) as [D' Hadd].
      apply Permutation_Type_Add_inf in Hadd.
      destruct (IHs D' r) as [ [[[[a1 b1] c1] T'] D''] [H1 [[[H2 H3] H4] H5]]].
      { apply Permutation_Type_cons_inv with (a, A).
        Permutation_Type_solve. }
      split with (a1, b1, a :: c1 , T', D'').
      repeat split; try Permutation_Type_solve.
Qed.


(**********************************************************************************
 * uniisem.v                                                                      *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(* semantics of unityped lambda calculus in recursive domain *)

Require Import PredomAll.
Require Import Fin unii uniirec.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Export RD.

(*=SemEnv *)
Fixpoint SemEnv E : cpoType := match E with O => One | S E => SemEnv E * VInf end.
Fixpoint SemVar E (v : Fin E) : SemEnv E =-> VInf :=
  match v with
  | FinZ _   => pi2
  | FinS _ v => SemVar v << pi1
  end.
(*=End *)

Canonical Structure nat_cpoType := Eval hnf in discrete_cpoType nat.
Canonical Structure bool_cpoType := Eval hnf in discrete_cpoType bool.

Lemma zeroCase_mon : monotonic (fun (n:nat_cpoType) => match n with | O => @in1 _ (One:cpoType) _ tt | S m => @in2 _ _ (discrete_cpoType nat) m end).
move => x y. case. move => e ; rewrite e. clear x e. by case: y.
Qed.

Definition zeroCasem : ordCatType (discrete_cpoType nat) ((One:cpoType) + nat_cpoType) :=
  Eval hnf in mk_fmono zeroCase_mon.

Lemma zeroCase_cont : continuous zeroCasem.
move => c. simpl. have e:lub c = c 0. by []. rewrite e. simpl.
by apply: (Ole_trans _ (le_lub _ O)).
Qed.

(*=zeroCase *)
Definition zeroCase : nat_cpoType =-> (One:cpoType) + nat_cpoType :=
  Eval hnf in mk_fcont zeroCase_cont.
(*=End *)

Lemma zeroCase_simplS: forall n, zeroCase (S n) = @in2 _ _ (discrete_cpoType nat) n.
intros n ; auto.
Qed.

Lemma zeroCase_simplO: zeroCase O = @in1 _ (One:cpoType) _ tt.
auto.
Qed.

Lemma SimpleB_mon (A B :Type) (C:ordType) (op : A -> B -> C:Type) : monotonic (fun p:discrete_ordType A * discrete_ordType B => op (fst p) (snd p)).
case => x0 y0. case => x1 y1. case ; simpl. move => L L'.
have e:x0 = x1 by []. have e':y0 = y1 by []. rewrite e. by rewrite e'.
Qed.

Definition SimpleBOpm (A B :Type) (C:ordType) (op : A -> B -> C:Type) : discrete_ordType A * discrete_ordType B =-> C :=
  Eval hnf in mk_fmono (SimpleB_mon op).

Lemma SimpleB_cont (A B:Type) (C:cpoType) (op : A -> B -> C:Type) :
   @continuous (discrete_cpoType A * discrete_cpoType B) C (SimpleBOpm op).
move => c. simpl. apply: (Ole_trans _ (le_lub _ 0)). simpl.
by [].
Qed.

Definition SimpleBOp (A B:Type) (C:cpoType) (op : A -> B -> C:Type) : discrete_cpoType A * discrete_cpoType B =-> C :=
  Eval hnf in mk_fcont (SimpleB_cont op).

(*=SemValExp *)
Fixpoint SemVal E (v:Value E) : SemEnv E =-> VInf :=
match v return SemEnv E =-> VInf with
| INT i => in1 << const _ i
| VAR m => SemVar m
| LAMBDA e => in2 << exp_fun (kleisli (eta << RD.Roll) << SemExp e << Id >< RD.Unroll)
end with SemExp E (e:Exp E) : SemEnv E =-> RD.VInf _BOT :=
match e with
| VAL v => eta  << SemVal v
| APP v1 v2 => kleisli (eta << RD.Unroll) << ev <<
    <| [| @const _ (exp_cppoType _ _) PBot , Id|] << SemVal v1, RD.Roll << SemVal v2 |>
| LET e1 e2 => ev << <| exp_fun (KLEISLIR (SemExp e2)), SemExp e1 |>
| OP op v0 v1 => kleisli (eta << in1 << SimpleBOp op) << uncurry (Smash _ _) <<
                  <| [| eta, const _ PBot|] << SemVal v0, [| eta, const _ PBot|] << SemVal v1|>
| IFZ v e1 e2 => ev <<
  [| [| exp_fun (SemExp e1 << pi2), exp_fun (SemExp e2 << pi2)|] << zeroCase ,
     @const _ (exp_cppoType _ _) PBot |]  ><  Id  <<  <|SemVal v, Id|>
end.
(*=End *)

Lemma Operator2_strictL A B C (f:A * B =-> C _BOT) d : Operator2 f PBot d =-= PBot.
apply: Ole_antisym ; last by apply: leastP.
unlock Operator2. simpl. by do 2 rewrite kleisli_bot.
Qed.

Lemma Operator2_strictR A B C (f:A * B =-> C _BOT) d : Operator2 f d PBot =-= PBot.
apply: Ole_antisym ; last by apply: leastP.
unlock Operator2. simpl.
apply: (Ole_trans (proj2 (fmon_eq_elim (kleisli_comp2 _ _) d))).
apply: DLless_cond. move => c X.
case: (kleisliValVal X) => a [e P]. rewrite -> e. clear d e X.
simpl in P. rewrite -> kleisli_bot in P.
by case: (PBot_incon (proj2 P)).
Qed.

Add Parametric Morphism E (e:Exp E) : (SemExp e)
with signature (@tset_eq _ : SemEnv E -> SemEnv E -> Prop) ==> (@tset_eq _ : VInf _BOT -> VInf _BOT -> Prop)
as SemExp_eq_compat.
intros e0 e1 eeq. by apply (fmon_stable (SemExp e)).
Qed.

Add Parametric Morphism E (v:Value E) : (SemVal v)
with signature (@tset_eq _ : SemEnv E -> SemEnv E -> Prop) ==> (@tset_eq _ : VInf -> VInf -> Prop)
as SemVal_eq_compat.
intros e0 e1 eeq. by apply (fmon_stable (SemVal v)).
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C BC ABC Bprime Cprime BCprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Bprime O /\ (wd_ BC O /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E Bprime /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime Cprime /\ (col_ O Eprime Bprime /\ col_ O Eprime BCprime))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.