Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relations.

Require Import compcert.exportclight.Clightdefs.
Require Import compcert.lib.Axioms.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.lib.Maps.
Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Memdata.
Require Import compcert.common.Memtype.
Require Import compcert.common.Memory.
Require Export sepcomp.Address.

Lemma range_dec: forall a b c: Z, {a <= b < c}+{~(a <= b < c)}.
Proof. intros. destruct (zle a b). destruct (zlt b c). left; split; auto.
  right;  omega. right; omega.
Qed.

Require Export msl.eq_dec.

Instance EqDec_ident: EqDec ident := ident_eq.

Instance EqDec_byte: EqDec byte := Byte.eq_dec.

Instance EqDec_type: EqDec type := type_eq.
Instance EqDec_int: EqDec int := Int.eq_dec.
Instance EqDec_int64: EqDec int64 := Int64.eq_dec.
Instance EqDec_float: EqDec float := Float.eq_dec.
Instance EqDec_float32: EqDec float32 := Float32.eq_dec.

Instance EqDec_memval: EqDec memval.
Proof.
 hnf; repeat decide equality; apply eq_dec.
Defined.

Instance EqDec_val: EqDec val.
Proof.
hnf. decide equality; apply eq_dec.
Defined.

Instance EqDec_quantity: EqDec quantity.
Proof.
hnf. decide equality.
Defined.

Definition access_at (m: mem) (loc: address) (k: perm_kind): option permission :=
   PMap.get (fst loc) (Mem.mem_access m) (snd loc) k.

Lemma perm_access: forall m b ofs k p,
    Mem.perm m b ofs k p <-> (Mem.perm_order'' (access_at m (b,ofs) k) (Some p)).
Proof. reflexivity. Qed.

Lemma access_perm: forall m b ofs k p,
  access_at m (b, ofs) k = Some p ->
  Mem.perm m b ofs k p.
Proof.
intros.
unfold Mem.perm, Mem.perm_order'.
unfold access_at in H. simpl in H.
rewrite H; auto.
constructor.
Qed.

Lemma access_cur_max: forall m a,
           Mem.perm_order'' (access_at m a Max)  (access_at m a Cur).
Proof.
 destruct a as [b z].
 destruct (access_at m (b,z) Cur) eqn:Hc.
 rewrite <- perm_access.
 apply (Mem.perm_cur_max m b z).
 rewrite perm_access. rewrite Hc. constructor.
 destruct (access_at m (b, z) Max); constructor.
Qed.

Lemma invalid_noaccess: forall m b ofs k,
     ~Mem.valid_block m b -> access_at m (b, ofs) k = None.
Proof. intros; apply Mem.nextblock_noaccess. assumption. Qed.

Lemma access_empty: forall a k, access_at Mem.empty a k = None.
Proof.
  intros. unfold access_at, Mem.empty; simpl. rewrite PMap.gi. reflexivity.
Qed.

Transparent Mem.alloc.

Theorem alloc_access_other:
  forall m1 lo hi m2 b, Mem.alloc m1 lo hi = (m2, b) ->
  forall b' ofs k,
  b'<>b \/ (ofs < lo \/ ofs >= hi) ->
  access_at m1 (b', ofs) k = access_at m2 (b', ofs) k.
Proof.
 intros.
pose proof (Mem.nextblock_noaccess m1 b ofs k).
pose proof (Mem.alloc_result _ _ _ _ _ H).
unfold access_at; inversion H; clear H; subst; simpl.
destruct (eq_block b' (Mem.nextblock m1)).
destruct H0; try contradiction.
subst b'.
rewrite PMap.gss.
destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; apply H1; apply Plt_strict.
rewrite PMap.gso by auto. auto.
Qed.

Theorem alloc_access_same:
  forall m1 lo hi m2 b, Mem.alloc m1 lo hi = (m2, b) ->
  forall ofs k,
  lo <= ofs < hi -> access_at m2 (b,ofs) k = Some Freeable.
Proof.
 intros.
 inversion H; clear H; subst. unfold access_at; simpl.
 rewrite PMap.gss.
destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
Qed.

Opaque Mem.alloc.
Transparent Mem.free.

Lemma access_free:
  forall m1 b lo hi,
  (forall ofs, lo <= ofs < hi -> access_at m1 (b,ofs) Cur = Some Freeable) ->
  { m2: mem | Mem.free m1 b lo hi = Some m2 }.
Proof.
 intros.
 unfold Mem.free.
 destruct (Mem.range_perm_dec m1 b lo hi Cur Freeable).
 eauto.
 contradiction n; clear n.
 hnf; intros. unfold Mem.perm. unfold access_at in H.
 simpl in H; rewrite H by auto. constructor.
Qed.

Lemma free_access:
  forall m1 b lo hi m2, Mem.free m1 b lo hi = Some m2 ->
  (forall ofs, lo <= ofs < hi ->
      access_at m1 (b,ofs) Cur = Some Freeable /\ access_at m2 (b,ofs) Max = None).
Proof.
 intros.
 unfold Mem.free in H.
 destruct (Mem.range_perm_dec m1 b lo hi Cur Freeable); inversion H; clear H; subst.
 specialize (r _ H0).
 hnf in r.
 unfold access_at. simpl.
 destruct ((Mem.mem_access m1) !! b ofs Cur); try contradiction.
 assert (p=Freeable) by (destruct p; inversion r; auto). subst p.
 split; auto.
 simpl. rewrite PMap.gss.
 destruct (zle lo ofs), (zlt ofs hi); try omega. reflexivity.
Qed.

Lemma free_access_other:
  forall m1 bf lo hi m2, Mem.free m1 bf lo hi = Some m2 ->
  forall b ofs k,
  b <> bf \/ ofs < lo \/ hi <= ofs ->
  access_at m1 (b,ofs) k = access_at m2 (b,ofs) k.
Proof.
 intros.
 unfold Mem.free in H.
 destruct (Mem.range_perm_dec m1 bf lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 destruct (eq_block b bf).
 subst bf; rewrite PMap.gss.
 destruct H0. contradiction H; auto.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 rewrite PMap.gso by auto. reflexivity.
Qed.

Opaque Mem.free.

Lemma access_drop_1:
  forall m b lo hi p m', Mem.drop_perm m b lo hi p = Some m' ->
  (forall ofs, lo <= ofs < hi ->
     forall k,
     access_at m (b, ofs) k = Some Freeable /\ access_at m' (b, ofs) k = Some p).
Proof.
 intros.
 unfold Mem.drop_perm in H.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 rewrite PMap.gss.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 split; auto.
 specialize (r _ H0). hnf in r. destruct ( (Mem.mem_access m) !! b ofs Cur) eqn:?; try contradiction.
 assert (p0=Freeable) by (destruct p0; inv r; auto). subst.
 pose proof (Mem.access_max m b ofs).
 rewrite Heqo in H.
 destruct k; auto.
 destruct ((Mem.mem_access m) !! b ofs Max); inv H; auto.
Qed.

Lemma access_drop_2:
  forall m b lo hi p,
  (forall ofs, lo <= ofs < hi -> access_at m (b,ofs) Cur = Some Freeable) ->
  { m' | Mem.drop_perm m b lo hi p = Some m' }.
Proof.
 intros.
 unfold Mem.drop_perm.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable).
 eauto.
 contradiction n; hnf; intros.
 specialize (H _ H0).
 unfold access_at in *.  hnf. simpl in *; rewrite H. constructor.
Qed.

Lemma access_drop_3:
  forall m b lo hi p m', Mem.drop_perm m b lo hi p = Some m' ->
  forall b' ofs k, b' <> b \/ ofs < lo \/ hi <= ofs ->
    access_at m (b', ofs) k = access_at m' (b',ofs) k.
Proof.
 intros.
 unfold Mem.drop_perm in H.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 destruct (eq_block b' b).
 subst. rewrite PMap.gss.
 destruct H0.
 contradiction H; auto.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 rewrite PMap.gso by auto.
 auto.
Qed.

Lemma storebytes_access:
 forall m1 b ofs bytes m2 (STORE: Mem.storebytes m1 b ofs bytes = Some m2),
  access_at m1 = access_at m2.
Proof.
intros.
apply extensionality ;intros [b' z].
apply extensionality ;intro k.
apply Mem.storebytes_access in STORE.
unfold access_at; f_equal; auto.
Qed.

Lemma store_access:
 forall chunk m1 b ofs v m2 (STORE: Mem.store chunk m1 b ofs v = Some m2),
  access_at m1 = access_at m2.
Proof.
intros.
apply extensionality; intros [b' z'].
apply extensionality ;intro k.
unfold access_at. apply Mem.store_access in STORE. rewrite STORE; auto.
Qed.

Lemma perm_order'_dec_fiddle:
  forall y x, y = Some x ->
     proj_sumbool (Mem.perm_order'_dec y Nonempty) = true.
Proof.
intros. subst. simpl.
unfold Mem.perm_order_dec. destruct x; reflexivity.
Qed.

Lemma access_at_valid_pointer:
  forall m b ofs p, access_at m (b,ofs) Cur = Some p ->
   Mem.valid_pointer m b ofs = true.
Proof.
intros.
unfold access_at, Mem.valid_pointer in *.
simpl in *.
apply perm_order'_dec_fiddle with p.
auto.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import definition.
Require Import Tactiques.
Require Import Axiomes.
Require Export Lemmes_generaux.
Require Import Lemmes.
Require Import Psatz.
Require Import powerRZ_complements.
Require Import Rbase_operations.
Require Import Rbase_doubles_inegalites.
Require Import Rbase_inegalites.

Lemma addition_correct :
 forall (x y : R) (xc yc : Reelc),
 encadrement xc x ->
 encadrement yc y -> encadrement (addition_reelc xc yc) (x + y).

Proof.
unfold encadrement in |- *.
intros x y xc yc H H1 n.
unfold addition_reelc in |- *.
generalize gauss_correct.
intros z; generalize (z (xc (n + 1) + yc (n + 1))%Z); clear z; intros.
elim H0; intros; clear H0.
apply
 Rlt_2_le_lt
  with
    (IZR (xc (n + 1)%Z - 1 + (yc (n + 1)%Z - 1)) * / INR B)
    (IZR (xc (n + 1)%Z + 1 + (yc (n + 1)%Z + 1)) * / INR B).
apply Rlt_2_Rmult_Rinv.
apply INR_B_non_nul.
do 2 rewrite plus_IZR.
unfold B_powerRZ in |- *.
rewrite Rmult_assoc;
 replace (powerRZ (INR B) n * INR B) with (powerRZ (INR B) (Z.succ n)).
2: apply powerRZ_Zs; apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
generalize (H (Z.succ n)) (H1 (Z.succ n)); unfold B_powerRZ in |- *; intros;
 clear H H1.
rewrite Rmult_plus_distr_r.
apply Rlt_2_monotony.
rewrite <- Z_R_minus; rewrite plus_IZR; auto.
rewrite <- Z_R_minus; rewrite plus_IZR; auto.
replace (IZR (xc (n + 1)%Z - 1 + (yc (n + 1)%Z - 1)))
 with (IZR (xc (n + 1)%Z + yc (n + 1)%Z) - 2).
rewrite Rmult_comm; rewrite Rmult_minus_distr_l.
apply Rle_trans with (/ INR B * IZR (xc (n + 1)%Z + yc (n + 1)%Z) - 1 * / 2).
rewrite Rmult_comm; apply Rle_sub_compatibility.
rewrite Rplus_comm; rewrite Rsub_sym; rewrite <- Rplus_assoc.
replace (1 + - (1 * / 2)) with (1 * / 2).
rewrite Rplus_comm; auto.
field; apply Rgt_not_eq; lra.
apply Rle_sub_r.
apply Rle_mult_inv.
lra.
rewrite Rmult_assoc; apply Rle_Rinv_monotony.
apply INR_B_non_nul.
rewrite RIneq.Rmult_1_r.
replace (2*2) with (INR 4) by (simpl; ring).
generalize B_sup_4; apply le_INR.
do 2 rewrite plus_IZR; do 2 rewrite <- Z_R_minus; simpl; ring.
apply
 Rle_lt_trans with (/ INR B * IZR (xc (n + 1)%Z + yc (n + 1)%Z) + 1 * / 2).
RingReplace (xc (n + 1) + 1 + (yc (n + 1) + 1))%Z
 (xc (n + 1) + yc (n + 1) + (1 + 1))%Z.
rewrite plus_IZR; rewrite Rmult_plus_distr_r; rewrite Rmult_comm.
rewrite Rplus_comm; apply Rge_le; rewrite Rplus_comm; apply Rle_ge;
 apply Rplus_le_compat_r.
RingReplace (IZR (1 + 1)) 2.
apply Rle_mult_inv.
lra.
rewrite Rmult_comm; rewrite <- Rmult_assoc.
apply Rmult_le_reg_l with (INR B).
apply INR_B_non_nul.
rewrite <- Rmult_assoc; rewrite RIneq.Rmult_1_r.
rewrite Rmult_comm; rewrite <- Rmult_assoc.
replace (/ INR B * INR B) with 1.
rewrite Rmult_comm; rewrite RIneq.Rmult_1_r.
replace (2*2) with (INR 4) by (simpl; ring).
generalize B_sup_4; apply le_INR.
apply Rinv_l_sym.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
rewrite Rmult_comm; apply Rlt_add_compatibility3.
rewrite Rsub_sym; rewrite Rplus_comm; rewrite Rplus_assoc.
replace (1 + - (1 * / 2)) with (1 * / 2).
apply Rlt_add_compatibility2; auto.
field; apply Rgt_not_eq; apply Rlt_gt; lra.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import TableAux.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_create_init_present_spec (level: Z64) (ll_table: Pointer) (index: Z64) (map_addr: Z64) (llt_pte: Z64) (pte: Pointer) (g_rtt: Pointer) (adt: RData) : option RData :=
    match level, llt_pte, index, map_addr with
    | VZ64 level, VZ64 llt_pte, VZ64 index, VZ64 map_addr =>
      rely is_int64 llt_pte; rely is_int64 map_addr; rely is_int64 index;
      if level =? 3 then
        let pa := __entry_to_phys llt_pte 2 in
        rely is_int64 pa;
        let pte_val := Z.lor (Z.lor (IPA_STATE_TO_PTE IPA_STATE_PRESENT) pa) PGTE_S2_PAGE in
        rely is_int64 pte_val; rely is_int64 (pte_val + GRANULE_SIZE * PGTES_PER_TABLE);
        rely (peq (base pte) buffer_loc);
        rely (peq (base ll_table) buffer_loc);
        rely (peq (base g_rtt) ginfo_loc);
        when rtt_gidx == (buffer (priv adt)) @ (offset pte);
        when llt_gidx == (buffer (priv adt)) @ (offset ll_table);
        rely is_gidx llt_gidx; rely is_gidx rtt_gidx;
        rely prop_dec (rtt_gidx = offset g_rtt);
        rely prop_dec (llt_gidx <> rtt_gidx);
        let gn_llt := (gs (share adt)) @ llt_gidx in
        let gn_rtt := (gs (share adt)) @ rtt_gidx in
        rely prop_dec (glock gn_llt = Some CPU_ID);
        rely prop_dec (glock gn_rtt = Some CPU_ID);
        rely g_tag (ginfo gn_llt) =? GRANULE_STATE_TABLE;
        rely g_tag (ginfo gn_rtt) =? GRANULE_STATE_TABLE;
        rely GRANULE_ALIGNED map_addr;
        let ipa_gidx := __addr_to_gidx map_addr in
        match fill_table (Z.to_nat PGTES_PER_TABLE) (g_data (gnorm gn_rtt)) 0 pte_val GRANULE_SIZE with
        | (table', _, _) =>
          let grtt' := gn_rtt {gnorm : (gnorm gn_rtt) {g_data : table'}}
                              {ginfo: (ginfo gn_rtt) {g_refcount: (g_refcount (ginfo gn_rtt)) + 512}} in
          let gllt' := gn_llt {gnorm: (gnorm gn_llt) {g_data: (g_data (gnorm gn_llt)) # index == 0}} in
          Some adt {share : (share adt) {gs : ((gs (share adt)) # llt_gidx == gllt') # rtt_gidx == grtt'}
                                        {tlbs: fun cpu gidx => if gidx =? ipa_gidx then -1 else tlbs (share adt) cpu gidx}}
        end
      else None
    end.

End Spec.


Require Import ExtLib.Core.Type.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.MonadLaws.
Require Import ExtLib.Data.PreFun.
Require Import ExtLib.Data.Fun.

Set Implicit Arguments.
Set Strict Implicit.

(** Currently not ported due to universes *)

(*
Section with_m.
  Variable m : Type -> Type.
  Variable Monad_m : Monad m.

  Variable meq : forall {T}, type T -> type (m T).
  Variable meqOk : forall {T} (tT : type T), typeOk tT -> typeOk (meq tT).

  Variable MonadLaws_m : @MonadLaws m Monad_m meq.

  Variable T : Type.
  Variable type_T : type T.
  Variable typeOk_T : typeOk type_T.

  Lemma proper_eta
  : forall T U (f : T -> U)
           (type_T : type T)
           (type_U : type U),
      proper f ->
      proper (fun x => f x).
  Proof.
    intros; do 3 red; intros.
    eapply H. assumption.
    Qed.

  Goal forall x : T, proper x ->
    equal (bind (ret x) (fun x => ret x)) (ret x).
  Proof.
    intros.
    etransitivity.
    { eapply bind_of_return; eauto.
      eapply proper_eta. eapply ret_proper; eauto. }
    { eapply ret_proper; eauto.
      eapply equiv_prefl; eauto. }
  Qed.

  Goal forall x : T, proper x ->
    equal (bind (ret x) (fun x => ret x)) (ret x).
  Proof.
    intros.
    etransitivity.
    { eapply bind_of_return; eauto.
      eapply proper_eta. eapply ret_proper; eauto. }
    { eapply ret_proper; eauto.
      eapply equiv_prefl; eauto. }
  Qed.

End with_m.
*)


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

(***
Modulus : 2^416 - 2^208 - 1
Base: 52
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 52;
    bitwidth := 64;
    s := 2^416;
    c := [(1, 1); (2^208, 1)];
    carry_chains := Some [[3; 7]; [4; 0; 5; 1; 6; 2; 7; 3]; [4; 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.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e336m17_11limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffExcept.
Require Import Arith.
Require Import Bool.
Require Import Exception.
Require Import ESoundE.

Open Scope string_scope.

Section Test_Section.

  Definition D := BType :+: AType.

  Definition E := Bool :+: Arith :+: ExceptE D.

  Definition V := StuckValue :+: BotValue :+: BoolValue :+: NatValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.

  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{Exception_ME : Exception ME unit}.
  Context {Fail_ME : FailMonad ME}.

  Context {ME_eq_dec : forall (A : Set) (mte : ME A),
    (exists a, mte = return_ a) \/ (mte = fail) \/ (mte = throw tt)}.
  Context {Reasonable_ME : Reasonable_Monad ME}.
  Context {fail_neq_throw : forall (A B C : Set) (ma : ME A) (mb : ME B),
    (ma >>= fun _ => fail (M := ME)) <> mb >>= fun _ => throw (A := C) tt}.

  Definition WFV := (WFValue_VB D V unit) ::+:: (WFValue_VI V D unit).
  Definition WFVM := (WFValueM_base D V MT ME unit WFV) ::+:: (WFValueM_Except D V MT ME unit).

  Instance eq_DType_eq_alg : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D)).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance eq_DType_neq_alg : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D)).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T : Set, FAlgebra EvalName T (evalMR V ME) E.
  Proof.
    intros; eauto with typeclass_instances.
    repeat apply FAlgebra_Plus;
      eauto 150 with typeclass_instances.
  Defined.

  Lemma eval_Sound :
    forall (e : Exp E) (T : DType D),
      fmap (@proj1_sig _ _) (typeof D E MT (proj1_sig e)) = return_ (proj1_sig T) ->
      (exists v : Value V,
        evalM V E ME (proj1_sig e) = return_ (M := ME) v /\
        WFValueC D V _ WFV tt v T) \/
      exists t, evalM V E ME (proj1_sig e) = throw (M := ME) t.
  Proof.
    apply eval_Except_Sound with (WFVM' := WFVM);
      eauto 10 with typeclass_instances.
    intros; repeat apply @P2Algebra_Plus.
    eapply Bool_eval_soundness'' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Arith_eval_soundness'' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Except_eval_soundness'';
      eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Soundness for 'Arith :+: Bool :+: Exceptions' Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import
  Coq.Lists.List.

Generalizable All Variables.

Import ListNotations.

(****************************************************************************
 * hlist: Type heterogeneous list indexed by a list.
 ****************************************************************************)

Inductive hlist : list Type -> Type :=
  | HNil : hlist []
  | HCons : forall t ts, t -> hlist ts -> hlist (t :: ts).

Arguments HNil : default implicits.
Arguments HCons : default implicits.

Lemma cons_head_eq : forall A (x0 : A) x1 y0 y1,
  x0 :: y0 = x1 :: y1 -> x0 = x1.
Proof.
  intros.
  inversion H.
  intuition.
Defined.

Lemma cons_tail_eq : forall A (x0 : A) x1 y0 y1,
  x0 :: y0 = x1 :: y1 -> y0 = y1.
Proof.
  intros.
  inversion H.
  intuition.
Defined.

Import EqNotations.

Program Definition hlist_head `(l : hlist (t :: ts)) : t :=
  match l in hlist d return d = t :: ts -> t with
  | HNil => fun _ => False_rect _ _
  | HCons x _ => fun H => rew (cons_head_eq _ _ _ _ _ H) in x
  end eq_refl.

Program Definition hlist_tail `(l : hlist (t :: ts)) : hlist ts :=
  match l in hlist d return d = t :: ts -> hlist ts with
  | HNil => fun _ => False_rect _ _
  | HCons _ xs => fun H => rew (cons_tail_eq _ _ _ _ _ H) in xs
  end eq_refl.


From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.monad.idxval Require Import pival_dist pival extrema.
From discprob.prob Require Import prob countable finite stochastic_order.

Record pidist_couplingP {A1 A2} (Is1: pidist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) : Type :=
  mkCoupling { pc_witness :> pidist {xy: A1 * A2 | P (fst xy) (snd xy)};
     pc_proj1: eq_pidist Is1 (x ← pc_witness; mret (fst (sval x)));
     pc_proj2: eq_pidist Is2 (x ← pc_witness; mret (snd (sval x)));
     }.
Require Import Reals Psatz Omega.

Definition lsupport {A1 A2 Is1 Is2 P} (Icouple: pidist_couplingP Is1 Is2 P) (y: A2) :=
  { x : A1 |  ∃ I Hpf i, pival.In I Icouple ∧ ival.ind I i = (exist _ (x, y) Hpf)
                         ∧ ival.val I i > 0 }.
Definition rsupport {A1 A2 Is1 Is2 P} (Icouple: pidist_couplingP Is1 Is2 P) (x: A1) :=
  { y : A2 |  ∃ I Hpf i, pival.In I Icouple ∧ ival.ind I i = (exist _ (x, y) Hpf)
                         ∧ ival.val I i > 0 }.

Lemma pidist_coupling_sym {A1 A2} (Is1: pidist A1) (Is2: pidist A2) P
      (Ic: pidist_couplingP Is1 Is2 P): pidist_couplingP Is2 Is1 (λ x y, P y x).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (mbind _ Ic). intros ((x&y)&HP).
    refine (mret (exist _ (y, x) _)); auto. }
  * setoid_rewrite Hp2. setoid_rewrite pidist_assoc; apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite pidist_left_id => //=. reflexivity.
  * setoid_rewrite Hp1. setoid_rewrite pidist_assoc; apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite pidist_left_id => //=. reflexivity.
Qed.

Lemma pidist_coupling_eq {A} (Is1 Is2: pidist A)
      (Ic: pidist_couplingP Is1 Is2 (λ x y, x = y)): eq_pidist Is1 Is2.
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply pidist_bind_congr; first by reflexivity.
  intros ((x&y)&Heq) => //=. rewrite //= in Heq; subst; reflexivity.
Qed.

Lemma pidist_coupling_ext {A B} (Is1 Is1': pidist A) (Is2 Is2': pidist B) (P P': A → B → Prop) :
  eq_pidist Is1 Is1' →
  eq_pidist Is2 Is2' →
  (∀ x y, P x y ↔ P' x y) →
  pidist_couplingP Is1 Is2 P →
  pidist_couplingP Is1' Is2' P'.
Proof.
  intros Heq1 Heq2 HP [pc_wit Hproj1 Hproj2].
  unshelve (econstructor).
  - refine (x ← pc_wit; mret (exist _ (proj1_sig x) _)).
    { destruct x as (?&?). eapply HP => //=. }
  - rewrite -Heq1 Hproj1. rewrite pidist_assoc.
    eapply pidist_bind_congr; first reflexivity.
    intros ((x&y)&HPxy). rewrite pidist_left_id => //=; reflexivity.
  - rewrite -Heq2 Hproj2. rewrite pidist_assoc.
    eapply pidist_bind_congr; first reflexivity.
    intros ((x&y)&HPxy). rewrite pidist_left_id => //=; reflexivity.
Qed.

Lemma pidist_coupling_eq_inv {A} (Is1 Is2: pidist A):
      eq_pidist Is1 Is2 →
      pidist_couplingP Is1 Is2 (λ x y, x = y).
Proof.
  intros Heq.
  unshelve (econstructor).
  - refine (x ← Is1; mret (exist _ (x, x) _)) => //=.
  - rewrite pidist_assoc. rewrite -[a in eq_pidist a _]pidist_right_id.
    eapply pidist_bind_congr; first reflexivity.
    intros a. rewrite pidist_left_id => //=.
    reflexivity.
  - rewrite Heq. rewrite pidist_assoc. rewrite -[a in eq_pidist a _]pidist_right_id.
    eapply pidist_bind_congr; first reflexivity.
    intros a. rewrite pidist_left_id => //=.
    reflexivity.
Qed.

Lemma pidist_coupling_Ex_min {A1 A2} f g (Is1 : pidist A1) (Is2: pidist A2)
      (Ic: pidist_couplingP Is1 Is2 (λ x y, f x ≤ g y)):
  ex_Ex_extrema f Is1 →
  Rbar_le (Ex_min f Is1) (Ex_min g Is2).
Proof.
  intros Hex.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply Ex_min_bind_le.
  *  rewrite /mbind/base.mbind in Hp1 *. rewrite -Hp1 //.
  * intros (?&?). rewrite ?Ex_min_mret => //=.
Qed.

Lemma pidist_coupling_Ex_max {A1 A2} f g (Is1 : pidist A1) (Is2: pidist A2)
      (Ic: pidist_couplingP Is1 Is2 (λ x y, f x ≤ g y)):
  ex_Ex_extrema g Is2 →
  Rbar_le (Ex_max f Is1) (Ex_max g Is2).
Proof.
  intros Hex.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply Ex_max_bind_le.
  *  rewrite /mbind/base.mbind in Hp2 *. rewrite -Hp2 //.
  * intros (?&?). rewrite ?Ex_max_mret => //=.
Qed.

Lemma pidist_coupling_bind {A1 A2 B1 B2} (f1: A1 → pidist B1) (f2: A2 → pidist B2)
      Is1 Is2 P Q (Ic: pidist_couplingP Is1 Is2 P):
  (∀ x y, P x y → pidist_couplingP (f1 x) (f2 y) Q) →
  pidist_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (xy ← Ic; _). destruct xy as ((x&y)&HP).
    exact (Hfc _ _ HP).
  }
  - setoid_rewrite Hp1; setoid_rewrite pidist_assoc;
      apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite pidist_left_id => //=.
    destruct (Hfc x y); auto.
  - setoid_rewrite Hp2; setoid_rewrite pidist_assoc;
      apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite pidist_left_id => //=.
    destruct (Hfc x y); auto.
Qed.

Lemma pidist_coupling_mret {A1 A2} x y (P: A1 → A2 → Prop):
  P x y →
  pidist_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret (exist _ (x, y) HP)); setoid_rewrite pidist_left_id => //=; reflexivity.
Qed.

Lemma pidist_coupling_plus {A1 A2} p Hpf Is1 Is2 Is1' Is2' (P: A1 → A2 → Prop):
  pidist_couplingP Is1 Is2 P →
  pidist_couplingP Is1' Is2' P →
  pidist_couplingP (pidist_plus p Hpf Is1 Is1') (pidist_plus p Hpf Is2 Is2') P.
Proof.
  intros [Ic Hproj1 Hproj2].
  intros [Ic' Hproj1' Hproj2'].
  exists (pidist_plus p Hpf Ic Ic').
  - setoid_rewrite Hproj1. setoid_rewrite Hproj1'.
    symmetry; apply pidist_plus_bind.
  - setoid_rewrite Hproj2. setoid_rewrite Hproj2'.
    symmetry; apply pidist_plus_bind.
Qed.

Lemma pidist_coupling_union {A1 A2} Is1 Is2 Is1' Is2' (P: A1 → A2 → Prop):
  pidist_couplingP Is1 Is2 P →
  pidist_couplingP Is1' Is2' P →
  pidist_couplingP (pidist_union Is1 Is1') (pidist_union Is2 Is2') P.
Proof.
  intros [Ic Hproj1 Hproj2].
  intros [Ic' Hproj1' Hproj2'].
  exists (pidist_union Ic Ic').
  - setoid_rewrite Hproj1. setoid_rewrite Hproj1'.
    symmetry; apply pidist_union_bind.
  - setoid_rewrite Hproj2. setoid_rewrite Hproj2'.
    symmetry; apply pidist_union_bind.
Qed.

Lemma pidist_coupling_join {Idx1} {A1 A2} (i1: Idx1)
      (Iss1: Idx1 → pidist A1) (Is2: pidist A2) (P: A1 → A2 → Prop):
  (∀ i1', pidist_couplingP (Iss1 i1') Is2 P) →
  pidist_couplingP (pidist_join i1 Iss1) Is2 P.
Proof.
  intros Ics.
  exists (pidist_join i1 (λ i, Ics i)).
  - setoid_rewrite pidist_join_bind. split.
    * intros I (i&Hin).
      destruct (Ics i) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj1 as (Hle1a&Hle1b).
      destruct (Hle1a _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
      exists i; eauto. rewrite Heqi => //=.
    * intros I (i&Hin).
      destruct (Ics i) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj1 as (Hle1a&Hle1b).
      destruct (Hle1b _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
      exists i; eauto.
  - setoid_rewrite pidist_join_bind. split.
    * intros I Hin.
      destruct (Ics i1) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj2 as (Hle1a&Hle1b).
      destruct (Hle1a _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
      exists i1; eauto. rewrite Heqi => //=.
    * intros I (i&Hin).
      destruct (Ics i) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj2 as (Hle1a&Hle1b).
      destruct (Hle1b _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal45.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal45_theorem0_63_Nat_beq_refl/goal45_lfind_orig.ml"  Coq.Init.Datatypes.orb adtind.goal45.eqb.
Success.


(** * Mapping predicates over [StringLike] things *)
Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Basics.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Parsers.StringLike.LastChar.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Local Arguments min !_ !_.
Local Arguments minus !_ !_.

Section is_after_last_char_such_that.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition is_after_last_char_such_that
             (*(might_be_empty : Prop)*)
             (str : String)
             (n : nat)
             P
    := forall_chars (drop n str) (fun ch => ~P ch)
       /\ for_last_char (take n str) P (*/\ 0 < min n (length str))
           \/ (might_be_empty /\ min n (length str) = 0))*).

  Lemma unfold_is_after_last_char_such_that str n P
  : is_after_last_char_such_that str n P
    <-> (forall_chars (drop n str) (fun ch => ~P ch)
         /\ for_last_char (take n str) P).
  Proof.
    reflexivity.
  Qed.

  Lemma after_last_char_such_that_nil
        (str : String)
        (n : nat)
        P
        (Hlen : length str = 0)
  : is_after_last_char_such_that str n P.
  Proof.
    unfold is_after_last_char_such_that.
    split; [ apply forall_chars_nil | apply for_last_char_nil ];
    rewrite ?take_length, ?drop_length;
    try apply Min.min_case_strong; omega.
  Qed.

  Lemma after_last_char_such_that_0
        (*might_be_empty : Prop*)
        (str : String)
        P
  : is_after_last_char_such_that (*might_be_empty*) str 0 P
    <-> forall_chars str (fun ch => ~P ch).
  Proof.
    unfold is_after_last_char_such_that.
    rewrite drop_0.
    split.
    { intros; destruct_head and.
      assumption. }
    { split; [ assumption | ].
      apply for_last_char_nil.
      rewrite take_length; reflexivity. }
  Qed.

  Lemma after_last_char_such_that_after_end
        (*{might_be_empty : Prop}*)
        {str : String}
        {P}
        {n}
        (Hle : length str <= n)
  : is_after_last_char_such_that (*might_be_empty*) str n P
    <-> for_last_char str P(* /\ (might_be_empty \/ 0 < length str))*).
  Proof.
    unfold is_after_last_char_such_that.
    rewrite take_long by omega.
    split; intro;
    destruct_head_hnf and;
    destruct_head_hnf or;
    destruct_head_hnf and; repeat split; trivial;
      try rewrite Min.min_idempotent in *;
      try solve [ left; assumption
                | right; omega
                | apply for_last_char_nil; omega
                | apply forall_chars_nil; rewrite ?drop_length, ?take_length; try apply Min.min_case_strong; intros; omega
                | destruct (length str);
                  try solve [ left; repeat split; eauto; omega
                            | right; repeat split; eauto; omega ] ].
  Qed.

  Lemma after_last_char_such_that_end
        (*{might_be_empty : Prop}*)
        {str : String}
        {P}
  : is_after_last_char_such_that (*might_be_empty*) str (length str) P
    <-> for_last_char str P(* /\ (might_be_empty \/ 0 < length str))*).
  Proof.
    apply after_last_char_such_that_after_end; reflexivity.
  Qed.

  Lemma is_after_last_char_such_that_drop
        (*(might_be_empty : Prop)*)
        (str : String)
        (n : nat)
        P
  : is_after_last_char_such_that (*might_be_empty*) str (S n) P
    -> is_after_last_char_such_that (*might_be_empty*) (drop 1 str) n P(* \/ ((*might_be_empty /\*) length str <= 1))*).
  Proof.
    revert dependent str; induction n as [|n IHn]; intros;
      unfold is_after_last_char_such_that in *;
      [
      | specialize (IHn (drop 1 str));
        rewrite (forall_chars__split _ _ 1) ];
      repeat match goal with
             | _ => assumption
             | _ => intro
             | _ => progress destruct_head and
             | _ => progress destruct_head iff
             | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
             | _ => progress simpl in *
             | [ H : ?x < ?y |- _ \/ (_ /\ ?y <= ?x) ] => left

             | [ H : ?x = 0 |- context[?x] ] => rewrite H
             | _ => apply forall_chars_nil; rewrite ?take_length, ?drop_length; reflexivity
             | _ => omega
             | [ H : ?A /\ ?B -> ?C |- _ ] => specialize (fun x y => H (conj x y))
             | [ H : _ -> ?A /\ ?B -> ?C |- _ ] => specialize (fun a x y => H a (conj x y))
             | [ H : _ |- _ ] => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?take_drop, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r in H
             | _ => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?take_drop, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r
             | _ => progress destruct_head or
             | [ |- _ /\ _ ] => split
             | [ |- _ <-> _ ] => split
             | _ => left; repeat split; trivial; omega
             | _ => right; repeat split; trivial; omega

             | [ H : for_last_char ?str ?P |- for_last_char (drop ?n ?str) ?P ]
               => eapply for_last_char__add_drop; eexact H

             | [ H : for_last_char (drop _ _) _ |- _ ]
               => rewrite <- for_last_char__drop in H by (rewrite ?take_length; apply Min.min_case_strong; omega)
             | [ |- forall_chars (drop _ (take _ _)) _ ]
               => rewrite drop_take, <- minus_Sn_m, minus_diag by omega; simpl;
                    apply (proj1 (forall_chars_take _ _))
             | [ H : forall_chars (drop ?n ?str) ?P |- forall_chars (drop (S ?n) ?str) ?P ]
               => rewrite <- (drop_drop str 1 n); apply (proj1 (forall_chars_drop _ _)); assumption
             end.
  Qed.

  Global Instance is_after_last_char_such_that_Proper
  : Proper ((*impl ==> *)beq ==> eq ==> pointwise_relation _ iff ==> impl) is_after_last_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_after_last_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel impl.
    setoid_subst_rel (pointwise_relation Char iff).
    assumption.
  Qed.

  Global Instance is_after_last_char_such_that_Proper_flip
  : Proper ((*flip impl ==> *)beq ==> eq ==> pointwise_relation _ iff ==> flip impl) is_after_last_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_after_last_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel (pointwise_relation Char iff).
    unfold flip in *.
    setoid_subst_rel impl.
    assumption.
  Qed.

  Global Instance is_after_last_char_such_that_Proper_iff
  : Proper ((*iff ==> *)beq ==> eq ==> pointwise_relation _ iff ==> iff) is_after_last_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_after_last_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel iff.
    setoid_subst_rel (pointwise_relation Char iff).
    reflexivity.
  Qed.

  Lemma is_after_last_char_such_that_eq_nat_iff
        (*(might_be_empty : Prop)*)
        (str : String)
        (n n' : nat)
        P
        (H0 : is_after_last_char_such_that (*might_be_empty*) str n P)
        (H1 : is_after_last_char_such_that (*might_be_empty*) str n' P)
  : n = n' \/ (n >= length str /\ n' >= length str).
  Proof.
    revert dependent n'; revert dependent str; induction n; intros;
      [ destruct n'; intros;
        [ left; reflexivity
        | ]
      | destruct n'; intros;
        [ right; intros
        | ] ];
      [ unfold is_after_last_char_such_that in *;
        repeat match goal with
               | _ => assumption
               | [ H : and _ _ |- _ ] => destruct H
               | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
               | [ H : _ |- _ ] => rewrite drop_0 in H
               | [ H : forall_chars _ _, H' : for_last_char _ _ |- ?T ]
                 => apply (forall_chars_for_last_char_overlap (R := T) H H'); solve [ omega | tauto | exfalso; tauto ]
               | [ H : ?x = 0 |- context[?x] ] => rewrite H
               | _ => omega
               | _ => progress destruct_head and
               | [ H : context[_ - 0] |- _ ] => rewrite Nat.sub_0_r in H
               | _ => progress destruct_head or
               | [ |- _ /\ _ ] => split
               | [ |- 0 = S _ \/ _ ] => right
               | [ H : for_last_char (take 0 _) _ |- _ ] => clear H
               | [ H : forall_chars ?str ?P, H' : forall_chars (drop _ ?str) ?P |- _ ] => clear H'
               | [ H : forall_chars ?str ?P, H' : forall_chars (take _ ?str) ?P |- _ ] => clear H'
               | _ => right; repeat split; solve [ assumption | omega ]
               | [ H : forall_chars ?str ?P, H' : for_last_char (take (S ?n) ?str) ?P' |- ?R ]
                 => rewrite forall_chars_take in H; specialize (H n); apply forall_chars__impl__for_last_char in H
               | [ H : for_last_char ?s ?P, H' : for_last_char ?s ?P' |- ?T' ]
                 => destruct (fun pf => for_last_char_combine (T := T') pf H H'); [ cbv beta; tauto | | ];
                    clear H H'
               | [ H : length (take _ _) = 0 |- _ ] => rewrite take_length in H
               | [ H : min ?x ?y = 0 |- _ ] => revert H; apply (Min.min_case_strong x y)
               | _ => intro
               end..
      | let H := fresh in
        edestruct IHn as [H|H];
        [ solve [ eauto using is_after_last_char_such_that_drop ]..
        | left; omega
        | right; rewrite drop_length in H; destruct_head and; omega ] ].
  Qed.
End is_after_last_char_such_that.

Global Opaque is_after_last_char_such_that.

Definition find_after_last_char_such_that' {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
           (P : Char -> bool)
           (len : nat)
           (str : String)
  : nat
  := nat_rect
       (fun _ => nat)
       0
       (fun len' otherwise
        => match get len' str with
             | Some ch => if P ch
                          then S len'
                          else otherwise
             | None => otherwise
           end)
       len.

Lemma find_after_last_char_such_that'_S {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (P : Char -> bool)
      (len : nat)
      (str : String)
  : find_after_last_char_such_that' P (S len) str
    = let v := S (find_after_last_char_such_that' P len (drop 1 str)) in
      match get 0 str with
        | Some ch => match find_after_last_char_such_that' P len (drop 1 str) with
                       | 0 => if P ch then 1 else 0
                       | _ => v
                     end
        | None => 0
      end.
Proof.
  cbv zeta.
  revert str; induction len as [|len IHlen]; intros.
  { reflexivity. }
  { simpl in *.
    rewrite IHlen; clear IHlen.
    repeat match goal with
             | [ |- appcontext[get ?n'] ]
               => not constr_eq n' 0; rewrite (get_drop (n := n'))
             | [ H : appcontext[get ?n'] |- _ ]
               => not constr_eq n' 0; setoid_rewrite (get_drop (n := n')) in H
           end.
    replace (get 0 (drop len (drop 1 str))) with (get 0 (drop (S len) str))
      by (rewrite drop_drop; do 2 f_equal; omega).
    destruct (get 0 str) eqn:Hg0.
    { destruct (get 0 (drop (S len) str)) eqn:Hg1; [ | reflexivity ].
      edestruct P; reflexivity. }
    { apply no_first_char_empty in Hg0.
      rewrite has_first_char_nonempty
        by (rewrite drop_length, Hg0; reflexivity).
      reflexivity. } }
Qed.

Definition find_after_last_char_such_that {Char} {HSLM} {HSL} str P
  := @find_after_last_char_such_that' Char HSLM HSL P (length str) str.

Lemma find_after_last_char_such_that_drop {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (str : String)
      (P : Char -> bool)
  : find_after_last_char_such_that str P
    = let v := S (find_after_last_char_such_that (drop 1 str) P) in
      match get 0 str with
        | Some ch => match find_after_last_char_such_that (drop 1 str) P with
                       | 0 => if P ch then 1 else 0
                       | _ => v
                     end
        | None => 0
      end.
Proof.
  unfold find_after_last_char_such_that.
  destruct (length str) eqn:Hlen.
  { rewrite has_first_char_nonempty by assumption; simpl; reflexivity. }
  { rewrite find_after_last_char_such_that'_S; simpl.
    rewrite drop_length, Hlen; simpl.
    rewrite Nat.sub_0_r.
    reflexivity. }
Qed.

Lemma is_after_last_char_such_that__find_after_last_char_such_that {Char} {HSLM HSL} {HSLP : @StringLikeProperties Char HSLM HSL} str P
      (*might_be_empty*)
      (H : exists n, is_after_last_char_such_that (*might_be_empty*) str n (fun ch => is_true (P ch)))
: is_after_last_char_such_that (*might_be_empty*) str (@find_after_last_char_such_that Char HSLM HSL str P) (fun ch => is_true (P ch)).
Proof.
  destruct H as [n H].
  rewrite unfold_is_after_last_char_such_that in H |- *.
  destruct H as [H0 H1].
  generalize dependent str.
  induction n as [|n IHn]; intros.
  { cut (find_after_last_char_such_that str P = 0);
    [ intro Heq; rewrite Heq; split; assumption
    | ].
    rewrite drop_0 in H0.
    unfold find_after_last_char_such_that, find_after_last_char_such_that'.
    induction (length str) as [|len IHlen]; simpl;
    [ reflexivity | rewrite IHlen; clear IHlen ].
    rewrite forall_chars_get in H0.
    specialize (H0 len).
    edestruct get; [ | reflexivity ].
    specialize (H0 _ eq_refl).
    edestruct P; simpl in *; intuition. }
  { specialize (IHn (drop 1 str)).
    rewrite !drop_drop, !take_drop, !Nat.add_1_r in IHn.
    specialize_by assumption.
    specialize_by ltac:(apply for_last_char__add_drop; assumption).
    rewrite find_after_last_char_such_that_drop; simpl.
    destruct (get 0 str) eqn:Hg0.
    { destruct (find_after_last_char_such_that (drop 1 str) P) eqn:Hf.
      { destruct_head and.
        destruct (P c) eqn:Hp.
        { split; try assumption; [].
          rewrite <- for_last_char_singleton; [ | apply get_0 ]; eassumption. }
        { rewrite drop_0.
          split; [ | apply for_last_char_nil; rewrite take_length; reflexivity ].
          apply (forall_chars__split _ _ 1); split; try assumption; [].
          rewrite <- forall_chars_singleton; [ | apply get_0; eassumption ].
          congruence. } }
      { destruct_head and; split; try assumption; [].
        rewrite for_last_char__drop; [ eassumption | ].
        rewrite take_length; simpl.
        destruct (length str) as [|[|]] eqn:Hlen;
          [ exfalso
          | exfalso
          | ].
        { rewrite has_first_char_nonempty in Hg0 by assumption; congruence. }
        { move Hf at bottom.
          unfold find_after_last_char_such_that in Hf.
          rewrite drop_length, Hlen in Hf.
          simpl in Hf.
          congruence. }
        { simpl; omega. } } }
    { rewrite drop_0.
      apply no_first_char_empty in Hg0.
      split; [ apply forall_chars_nil | apply for_last_char_nil ];
      rewrite ?take_length, Hg0; reflexivity. } }
Qed.


(* Lifted functions.
   By Jesper Bengtson, revised by Andrew W. Appel.
*)

Structure Lift := mkLift {
         lift_S: Type;
         lift_T: Type;
         lift_prod : Type;
         lift_last: Type;
         lifted:> Type;
         lift_curry: lift_T -> lift_prod -> lift_last;
         lift_uncurry_open: ((lift_S -> lift_prod) -> (lift_S -> lift_last)) -> lifted
}.

Definition Tend (S: Type) (A: Type) :=
    mkLift S A unit A
          (S -> A)
          (fun f _ => f)
          (fun f => f (fun _: S => tt)).

Global Set Warnings "-projection-no-head-constant".
Canonical Structure Tarrow (A: Type) (H: Lift) :=
    mkLift (lift_S H)
      (A -> lift_T H)
      (prod A (lift_prod H))
      (lift_last H)
      ((lift_S H -> A) -> lifted H)
      (fun f x => match x with (x1,x2) => lift_curry H (f x1) x2 end)
      (fun f x => lift_uncurry_open H (fun y: lift_S H -> lift_prod H => f (fun z => (x z, y z)))).
Set Warnings "projection-no-head-constant".

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

Definition lift S {A B} (f : A -> B) (a : S -> A) (x: S) : B := f (a x).

Definition liftx {H: Lift} (f: lift_T H) : lifted H :=
  lift_uncurry_open H (lift (lift_curry H f)).
Arguments liftx H f : simpl never.

(* NOTE: We want unfold_lift to unfold EVERYTHING related to lifting, but NOTHING else.
  Thus we have avoided using any library functions to implement lifting, so that
  we can unfold all of it without interfering with other things the user might be doing. *)

Tactic Notation "unfold_lift" :=
  unfold liftx;
  repeat match goal with(* This unfolds instances of Tend *)
  | |- context [lift_uncurry_open (?F _)] => unfold F
  | |- context [Tarrow _ (?F _)] => unfold F
  end;
  cbv delta [Tarrow Tend lift_S lift_T lift_prod lift_last lifted lift_uncurry_open lift_curry lift] beta iota.

Tactic Notation "unfold_lift" "in" hyp(H) :=
  unfold liftx  in H;
  repeat match type of H with(* This unfolds instances of Tend *)
  | context [lift_uncurry_open (?F _)] => unfold F in H
  | context [Tarrow _ (?F _)] => unfold F in H
  end;
  cbv delta [Tarrow Tend lift_S lift_T lift_prod lift_last lifted lift_uncurry_open lift_curry lift] beta iota in H.

Tactic Notation "unfold_lift" "in" "*" :=
  unfold liftx in *;
  repeat match goal with (* This unfolds instances of Tend *)
             | H: context [lift_uncurry_open (?F _)] |- _ => unfold F in H
             | |- context [Tarrow _ (?F _)] => unfold F
             end;
  cbv delta [Tarrow Tend lift_S lift_T lift_prod lift_last lifted lift_uncurry_open lift_curry lift] beta iota in *.

(* The reason for writing   liftx(x : _) instead
  of just (liftx x)  is to get the case  `(fun v => ..v...) to work *)
Module LiftNotation.
Notation "'`' x" := (liftx x) (at level 10, x at next level). (* use level 10 for compatibility with coq/Theories/Program/Utils.v *)
Notation "'`(' x ')'" := (liftx (x : _)).
End LiftNotation.

(*  EXAMPLES OF USE

Parameter environ : Type.

Canonical Structure LiftEnviron := Tend environ.

Definition foo (v : nat) := (v=O).
Check (`foo).
Check (`(fun v => v=O)).

(* Infix "-.>" := Tarrow (at level 80, right associativity).  (* The
      only purpose of this Infix is to make the error message slightly prettier,
      but they're not bad even without it. *) *)
(* Notation  "x '-.>[' y ] " := (Tarrow x (LiftEnviron y)) (at level 80, right associativity).  *)

Check `plus.
Check (`(plus 4)).

(* Goal (lifted (nat -.> (nat -.> LiftEnviron nat)) = ((environ -> nat) -> (environ -> nat) -> (environ -> nat))).
reflexivity.
Qed.
*)

Parameter f: environ -> nat.
Check (`plus f).
Check (`plus f f).
Check (`(@cons nat)).
Check (`(@cons nat) (`plus f f) `nil).
Check (`(@cons _) (`plus f f) `nil).     (* HA!  This line would not have worked using typeclasses for Lift;
            it does work using canonical structures *)
(* Check (`cons (`plus f f) `nil).     (* this line fails, which is OK; however, using the old 'coerce' appoach,
                                                           this would have worked.  *) *)

Example test_plus (s : environ) : (`plus `(4) `3) s = (`(7)) s.
  simpl.  (* doesn't unfold the backtick; this is a good thing, I think. *)
 unfold_lift. (* optional -- proof works with or without it *)
  reflexivity.
Qed.

Example test_plus' (s : environ) : (`plus `(4) `3) s = (`(7)) s.
  simpl.  (* doesn't unfold the backtick; this is a good thing, I think. *)
  reflexivity.
Qed.

Definition natfun := nat -> nat.
Opaque natfun.

Definition add : nat -> natfun := plus.

Goal forall rho, `add `(3) rho = (fun y => plus 3 y).
 intro rho.
 simpl.  (* doesn't unfold the backtick; this is a good thing, I think. *)
 unfold_lift. (* optional -- see what happens! *)
 reflexivity.
Qed.

(* Goal `add `3 = `plus `3.   (* This fails.  Indeed, it should fail.
       But the error message is reasonably informative! *)  *)

END EXAMPLES OF USE *)


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5eqsynthconj1 : forall  (lv0 : natural), (@eq natural (mult lv0 Zero) (mult Zero (Succ lv0))).
Admitted.
QuickChick conj5eqsynthconj1.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Infrastructure.

Lemma sub_tvar_inv:forall E U (X:atom),
    sub E U X ->
    exists Y, U = typ_fvar Y.
Proof with auto.
  intros.
  dependent induction H...
  exists X...
  exists X0...
  inversion H1.
Qed.

Lemma WF_type: forall E T,
    WF E T -> type T.
Proof with auto.
  intros.
  induction H...
  apply type_all with (L:=L)...
  apply type_mu with (L:=L)...
Qed.

Lemma WF_weakening: forall E1 E2 T E,
    WF (E1 ++ E2) T ->
    WF (E1 ++ E ++ E2) T.
Proof with eauto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub T1)] ++ E1) ++ E ++ E2).
    apply H1...
  -
    apply WF_rec with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply H0...
    intros.
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply H2...
Qed.

Lemma WF_narrowing : forall V U T E F X,
  WF (F ++ X ~ bind_sub V ++ E) T ->
  WF (F ++ X ~ bind_sub U ++ E) T.
Proof with eauto.
  intros.
  dependent induction H;try solve [analyze_binds H;eauto]...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X0, bind_sub T1)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H1 with (V0:=V)...
  -
    apply WF_rec with (L:=L);intros...
    rewrite_alist (([(X0, bind_sub typ_top)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H0 with (V0:=V)...
    rewrite_alist (([(X0, bind_sub typ_top)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H2 with (V0:=V)...
Qed.

Lemma subst_tt_open_tt_twice: forall X X0 A A0,
    X <> X0 -> type A0 ->
      (subst_tt X A0 (open_tt A (typ_label X0 (open_tt A X0)))) =
      (open_tt (subst_tt X A0 A) (typ_label X0 (open_tt (subst_tt X A0 A) X0))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma  subst_tt_rt_type : forall E A B X,
    WF E A  ->
    rt_type  B ->
    WF E B ->
    rt_type  (subst_tt X A B).
Proof with auto.
  intros.
  induction H0...
  dependent destruction H1...
  simpl...
Qed.

Lemma  subst_tt_rt_type' : forall E A B X,
    (* WF E A  -> *)
    rt_type  B ->
    WF E B ->
    rt_type  (subst_tt X A B).
Proof with auto.
  intros.
  induction H...
  dependent destruction H0...
  simpl...
Qed.

Lemma subst_tt_collect: forall T E i X A,
    i `notin` collectLabel T ->
    rt_type T ->
    WF E T ->
    i `notin` collectLabel (subst_tt X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply notin_union in H.
  destruct H.
  apply notin_union.
  split...
Qed.

Lemma subst_tt_collect2: forall T E i X A,
    i `in` collectLabel T ->
    rt_type T ->
    WF E T ->
    i `in` collectLabel (subst_tt X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma subst_tt_collect3: forall T E i X A,
    i `in` collectLabel (subst_tt X A T) ->
    rt_type T ->
    WF E T ->
    i `in` collectLabel T.
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma subst_tt_wf : forall E A B X,
    WF E A ->
    WF E B ->
    WF E (subst_tt X A B).
Proof with auto.
  intros.
  generalize dependent A.
  induction H0;intros;simpl...
  -
    destruct (X0==X)...
    apply WF_var with (U:=U)...
  -
    apply WF_all with (L:=L \u fv_tt A \u {{X}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing with (V:=T1)...
    apply H1...
    add_nil.
    apply WF_weakening...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u fv_tt A \u {{X}});intros...
    rewrite subst_tt_open_tt_var...
    apply H0...
    add_nil.
    apply WF_weakening...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    apply H2...
    add_nil.
    apply WF_weakening...
    apply WF_type in H3...
  -
    constructor...
    apply subst_tt_rt_type with (E:=E)...
    eapply subst_tt_collect...
    eauto.
Qed.

Lemma binds_map_free: forall F X  Y U  P,
    In (X, bind_sub U) F ->
    X <> Y ->
    In (X, bind_sub (subst_tt Y P U)) (map (subst_tb Y P) F).
Proof with auto.
  induction F;intros...
  apply in_inv in H.
  destruct H...
  -
    destruct a.
    inversion H;subst.
    simpl...
  -
    simpl...
Qed.

Lemma subst_tb_wf : forall F Q E Z P T,
  WF (F ++ Z ~ Q ++ E) T ->
  WF E P ->
  WF (map (subst_tb Z P) F ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub T1 ++ F) ++ E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H0 with (Q0:=Q)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H2 with (Q0:=Q)...
    apply WF_type in H3...
  -
    constructor...
    { apply subst_tt_rt_type with (E:=(F ++ (Z ~ Q) ++ E))...
      rewrite_env (nil ++ (F ++ Z~Q) ++ E)...
      apply WF_weakening... }
    { eapply subst_tt_collect... }
Qed.

Lemma subst_tb_wf2 : forall F Q E Z P T,
  WF (F ++ Z ~ Q ++ E) T ->
  WF (Z ~ Q ++ E) P ->
  WF (map (subst_tb Z P) F ++ Z~Q ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub T1 ++ F) ++ (Z,Q):: E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ (Z,Q)::E).
    apply H0 with (Q0:=Q)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ (Z,Q)::E).
    apply H2 with (Q0:=Q)...
    apply WF_type in H3...
  -
    constructor...
    { apply subst_tt_rt_type with (E:=(F ++ (Z ~ Q) ++ E))...
      rewrite_env (nil ++ F ++ (Z~Q ++ E))...
      apply WF_weakening... }
    { eapply subst_tt_collect... }
Qed.

Lemma subst_tb_wf3 : forall F  E Z P T S,
  WF (F ++ Z ~ bind_sub S ++ E) T ->
  WF E P ->
  WF (map (subst_tb Z S) F ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z S U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing with (V:=subst_tt Z S T1)...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub T1 ++ F) ++ E).
    apply H1 with (S0:=S)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H0 with (S0:=S)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H2 with (S0:=S)...
    apply WF_type in H3...
  -
    constructor...
    { apply subst_tt_rt_type with (E:=(F ++ (Z ~ bind_sub S) ++ E))...
      rewrite_env (nil ++ (F ++ (Z~ bind_sub S)) ++ E)...
      apply WF_weakening... }
    { eapply subst_tt_collect... }
Qed.

Lemma WF_renaming: forall E1 E2 X Y A T,
    WF (E1 ++ X ~ bind_sub T ++ E2) A ->
    Y \notin {{X}} \u fv_tt A ->
    WF (map (subst_tb X Y) E1 ++ Y ~ bind_sub T ++ E2) (subst_tt X Y A).
Proof with auto.
  intros.
  dependent induction H;simpl in *...
  -
    destruct (X0==X)...
    apply WF_var with (U:=T)...
    analyze_binds H...
    apply WF_var with (U:=subst_tt X Y U)...
    apply In_lemmaL.
    apply  binds_map_free...
    apply WF_var with (U:=U)...
  -
    apply WF_all with (L:=L \u {{X}} \u {{Y}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub T1 ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H1...
    solve_notin.
  -
    apply WF_rec with (L:=L \u {{X}} \u {{Y}});intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub typ_top ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H0...
    solve_notin.
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub typ_top ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H2...
    solve_notin.
  -
    constructor...
    { apply subst_tt_rt_type'
      with (E:=(E1 ++ (X ~ bind_sub T) ++ E2))... }
    { eapply subst_tt_collect... eauto. }
Qed.

Lemma sub_regular : forall E A B,
    sub E A B -> wf_env E /\ WF E A /\ WF E B.
Proof with auto.
  intros.
  induction H;destruct_hypos...
  -
    repeat split...
    apply WF_var with (U:=U)...
  -
    repeat split...
    + apply WF_all with (L:=L);intros...
      rewrite_env (nil ++ X ~ bind_sub S1 ++ E).
      eapply WF_narrowing with (V:=S2)...
      eapply H2...
    + apply WF_all with (L:=L);intros...
      eapply H2...
  -
    split.
    pick fresh X.
    specialize_x_and_L X L.
    destruct_hypos.
    dependent destruction H2...
    split...
    +
      apply WF_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
      eapply H2...
    +
      apply WF_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
      eapply H2...
Qed.

Ltac get_well_form :=
    repeat match goal with
    | [ H : sub _ _ _ |- _ ] => apply sub_regular in H;destruct_hypos
           end.

Ltac get_type :=
    repeat match goal with
           | [ H : sub _ _ _ |- _ ] => get_well_form
           | [ H : WF _ _ |- _ ] => apply WF_type in H
           end.

Lemma Reflexivity: forall E A,
    WF E A ->
    wf_env E ->
    sub E A A.
Proof with auto.
  intros.
  induction H...
  -
    constructor...
    apply WF_var with (U:=U)...
  -
    apply sa_all with (L:=L \u dom E \u fv_env E \u fl_env E)...
  -
    apply sa_rec with (L:=L \u dom E \u fv_env E \u fl_env E)...
  -
    constructor...
    { simpl...
      apply KeySetProperties.FM.Subset_refl... }
    { intros.
      simpl in *.
      inversion H. }
  -
    dependent induction H2...
    +
      constructor...
      { apply KeySetProperties.FM.Subset_refl... }
      intros.
      simpl in *...
      destruct (i==i0)...
      { inversion H2.
        inversion H4...
        subst... }
      { inversion H2... }
    +
      constructor...
      { apply KeySetProperties.FM.Subset_refl... }
      apply IHWF2 in H0.
      dependent destruction H0.
      intros.
      simpl in *.
      destruct (i==i1)...
      { inversion H9.
        inversion H10.
        subst... }
      { apply H8 with (i:=i1)... }
Qed.

Lemma Sub_weakening: forall E1 E2 A B E,
    sub (E1 ++ E2) A B ->
    wf_env (E1 ++ E ++ E2) ->
    sub (E1 ++ E ++ E2) A B.
Proof with eauto using WF_weakening.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply sa_all with (L:=L \u dom E1 \u dom E2 \u dom E \u fv_env (E1++E++E2) \u fl_env (E1++E++E2))...
    intros.
    rewrite_alist (([(X, bind_sub S2)] ++ E1) ++ E ++ E2).
    apply H2...
    get_well_form.
    rewrite_alist ([(X, bind_sub S2)] ++ E1 ++ E ++ E2)...
  -
    apply sa_rec with (L:=L \u dom E1 \u dom E2 \u dom E \u fv_env (E1++E++E2) \u fl_env (E1++E++E2));intros...
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2)...
    apply WF_weakening...
    apply H...
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply WF_weakening...
    apply H0...
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply H2...
    rewrite_alist ([(X, bind_sub typ_top)] ++ E1 ++ E ++ E2)...
Qed.

Lemma uniq_from_wf_env : forall E,
  wf_env E ->
  uniq E.
Proof.
  intros E H; induction H; auto.
Qed.

Lemma in_binds: forall x a U x0,
    a `in` dom (x ++ (a, bind_sub U) :: x0).
Proof with auto.
  induction x;intros...
  simpl...
  simpl...
  destruct a...
Qed.

Lemma union_subset_6: forall A B C,
    A [<=] B ->
    A [<=] union B C.
Proof with auto.
  intros.
  unfold "[<=]" in *.
  intros.
  apply H in H0...
Qed.

Lemma union_subset_7: forall A B C,
    union A B [<=] C ->
    A [<=] C /\ B [<=] C.
Proof with auto.
  intros.
  unfold "[<=]" in *.
  split;intros...
Qed.

Lemma fv_open_tt_notin: forall T S (X:atom),
    X \notin fv_tt T ->
    fv_tt T [<=] S ->
    fv_tt (open_tt T X) [<=] add X S.
Proof with auto.
  intros.
  unfold open_tt.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply AtomSetProperties.subset_add_2;apply KeySetProperties.subset_empty]...
  -
    destruct (n0==n);simpl...
    unfold "[<=]".
    intros...
    apply AtomSetNotin.D.F.singleton_iff in H1...
    apply KeySetProperties.subset_empty.
  -
    apply AtomSetProperties.subset_add_2...
  -
    apply notin_union in H.
    apply union_subset_7 in H0.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
  -
    apply notin_union in H.
    apply union_subset_7 in H0.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
  -
    apply notin_union in H.
    apply union_subset_7 in H0.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
Qed.

Lemma fv_open_tt_notin_inv: forall T S (X:atom),
    X \notin fv_tt T ->
    fv_tt (open_tt T X) [<=] add X S ->
    fv_tt T [<=] S.
Proof with auto.
  intro T.
  unfold open_tt in *.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    unfold "[<=]" in *.
    intros...
    apply AtomSetNotin.D.F.singleton_iff in H1...
    subst.
    assert (a0 `in` singleton a0) by auto.
    specialize (H0 a0 H1)...
    apply AtomSetImpl.add_3 in H0...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
  -
    apply IHT with (X:=X) (n:=(Datatypes.S n))...
  -
    apply IHT with (X:=X) (n:=n)...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
Qed.

Lemma dom_split_2: forall E T a,
    E [<=] add a T ->
    a \notin E ->
    E [<=] T.
Proof with auto.
  intros.
  unfold "[<=]" in *.
  intros.
  assert (Ht:=H1).
  apply H in Ht.
  apply KeySetProperties.FM.add_iff in Ht...
  destruct Ht...
  subst...
  assert (False).
  apply H0...
  destruct H2.
Qed.

Lemma fl_open_tt_notin_inv: forall T S (X:atom),
    X \notin fv_tt T \u fl_tt T ->
    fl_tt (open_tt T X) [<=] add X S ->
    fl_tt T [<=] S.
Proof with auto.
  intro T.
  unfold open_tt in *.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
  -
    apply IHT with (X:=X) (n:=(Datatypes.S n))...
  -
    apply KeySetProperties.union_subset_3...
    apply union_subset_7 in H0.
    destruct H0.
    unfold "[<=]" in *.
    intros.
    assert (Ht:=H2).
    apply H0 in H2.
    apply AtomSetProperties.FM.singleton_iff in Ht.
    subst.
    apply AtomSetImpl.add_3 in H2...
    apply IHT with (X:=X) (n:=n)...
    apply union_subset_7 in H0.
    destruct_hypos...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply dom_split_2 in H0...
    apply union_subset_7 in H1...
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
Qed.

Lemma WF_imply_dom: forall E A,
    WF E A ->
    fv_tt A [<=] dom E.
Proof with auto.
  intros.
  induction H;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    unfold binds in H...
    unfold "[<=]".
    intros.
    apply KeySetFacts.singleton_iff in H0.
    subst.
    apply in_split in H.
    destruct_hypos.
    rewrite H...
    apply in_binds...
  -
    apply KeySetProperties.union_subset_3...
  -
    apply KeySetProperties.union_subset_3...
    pick fresh X.
    specialize_x_and_L X L.
    apply fv_open_tt_notin_inv in H1...
  -
    pick fresh X.
    specialize_x_and_L X L.
    apply fv_open_tt_notin_inv in H0...
  -
    apply KeySetProperties.union_subset_3...
Qed.

Lemma wf_env_cons: forall E1 E2,
    wf_env (E1++E2) ->
    wf_env E2.
Proof with auto.
  induction E1;intros...
  destruct a...
  dependent destruction H...
Qed.

Lemma fv_env_ls_dom: forall E,
    wf_env E ->
    fv_env E [<=] dom E.
Proof with auto.
  induction E;intros;simpl in *...
  -
    apply AtomSetProperties.subset_empty...
  -
    destruct a.
    destruct b.
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
Qed.

Lemma notin_from_wf_env: forall E1 X T E2,
    wf_env (E1 ++ (X, bind_sub T) :: E2) ->
    X \notin fv_tt T \u dom E2 \u dom E1 \u fv_env E2.
Proof with auto.
  induction E1;intros...
  -
    dependent destruction H...
    apply WF_imply_dom in H0...
    apply fv_env_ls_dom in H...
  -
    dependent destruction H...
    simpl in *...
    apply IHE1 in H...
    simpl in *...
    apply IHE1 in H...
Qed.

Lemma WF_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_sub U) E ->
  WF E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  -
    inversion BindsTacVal;subst.
    add_nil.
    apply WF_weakening...
  -
    add_nil.
    apply WF_weakening...
 -
    add_nil.
    apply WF_weakening...
Qed.

Lemma notin_partial: forall X E1 E2,
    X \notin E2 ->
    E1 [<=] E2 ->
    X \notin E1.
Proof with auto.
  unfold "[<=]".
  intros...
Qed.


(** Porting the OCaml version of the forcing translation plugin.

    Some notes:
    - the Yoneda embedding is removed from the translation and should be provided by
      the user, if required;
    - porting the OCaml code required to change de Bruijn indices to start from 0,
      and not from 1 as in the Coq's kernel (hopefully, fixed everywhere);
    - only the translation for the negative fragment is supported for now. *)

Require Import List Arith Nat.
Require Import Template.monad_utils Template.Ast
        Template.Template Template.LiftSubst.
Require Import Forcing.TFUtils.
Import ListNotations MonadNotation.

Local Open Scope string_scope.

(** We add a composition and an identity as a part of a categorical structe that must
    be provided by a user, since the Yoneda embedding is not a part of
    the plugin anymore (instead, it could be done externally by a
    user) *)

Record category : Type :=
  mkCat { cat_obj : term;
          (** Objects. Must be of type [Type]. *)

          cat_hom : term;
          (** Morphisms. Must be of type [cat_obj -> cat_obj -> Type]. *)

          cat_id : term;
          (** Identity. Must be of the type [forall {a : cat_obj}, cat_hom a a]  *)

          cat_comp : term;
          (** Composition. Must be of the type
              [forall {a b c : cat_obj}, cat_hom b c -> cat_hom a b -> cat_hom a c] *)
        }.

Definition makeCat obj hom id_ comp :=
  {| cat_obj := tConst obj [];
     cat_hom := tConst hom [];
     cat_id := tConst id_ [];
     cat_comp := tConst comp [];
  |}.

Quote Definition cat_def := Eval compute in category.

Definition obj_name := nNamed "R".
Definition knt_name := nNamed "k".

(** We assume that there is a hidden topmost variable [p : Obj] in the context *)

Definition pos_name := nNamed "p".
Definition hom_name := nNamed "α".

(** Optimization of cuts *)
(* TODO: for now it is just ordinary tApp; could be changed if we need it later *)

Definition mkOptApp t args := tApp t args.
(* The original OCaml inplementation  *)
(* let mkOptApp (t, args) = *)
(*   let len = Array.length args in *)
(*   try *)
(*     let (_, t) = Term.decompose_lam_n len t in *)
(*     Vars.substl (CArray.rev_to_list args) t *)
(*   with _ -> *)
(* mkApp (t, args) *)

(** Forcing translation *)
Inductive forcing_condition :=
| fcVar : forcing_condition
| fcLift : forcing_condition.

Record forcing_context :=
  mkFCtxt { f_context : list forcing_condition;
            f_category : category;
            f_translator : tsl_table;
            (* A map associating to all source constant a forced constant *)
          }.

(* WARNING: tRel indices start from 0 in Tempalte Coq and *not* from 1 as for mkRel in the kernel  *)
Fixpoint last_internal fctx :=
  match fctx with
  | [] => 0
  | fcVar :: fctx => 1 + last_internal fctx
  | fcLift :: fctx => 1
  end.

Definition last_condition fc :=
  last_internal fc.(f_context).

Fixpoint gather_morphisms_internal i n fctx :=
  if (Nat.eqb n 0) then []
  else match fctx with
       | [] => []
       | fcVar :: fctx => gather_morphisms_internal (i + 1) (n - 1) fctx
       | fcLift :: fctx => i :: gather_morphisms_internal (i + 2) n fctx
       end.

Definition gather_morphisms (n : nat) (fctx : forcing_context) : list nat :=
  gather_morphisms_internal 1 n (f_context fctx).

(* TODO: Not sure if this is correct, think about de Bruijn indices.  *)
Definition morphism_var n fctx :=
  let morphs := gather_morphisms n fctx in
  let last := tRel (last_condition fctx) in
  let cat := (f_category fctx) in
  let fold_with (accu : term) (i : nat) :=
      tApp cat.(cat_comp) [(tRel i); accu] in
  let init := tApp cat.(cat_id) [last]
  in
  List.fold_left fold_with morphs init.

(* The original OCaml code *)
(* let morphism_var n fctx = *)
(*   let morphs = gather_morphisms n fctx in *)
(*   let last = mkRel (last_condition fctx) in *)
(*   let fold accu i = *)
(*     trns fctx.category dummy dummy last (mkRel i) accu *)
(*   in *)
(* List.fold_left fold (refl fctx.category last) morphs *)

(* Some examples to play with  *)
Definition Obj := Type.
Definition Hom := (fun x y => x -> y).
Definition Id_hom := @id.
Definition Comp := @Coq.Program.Basics.compose.

Definition test_cat : category :=
  makeCat "Obj" "Hom" "Id_hom" "Comp".

Definition test_fctx :=
  {| f_context := [fcLift; fcLift];
     f_category := test_cat;
     f_translator := []|}.

Eval compute in gather_morphisms 1 test_fctx.
Eval compute in morphism_var 1 test_fctx.

Definition get_var_shift n fctx :=
  let fix get n fctx :=
    if (Nat.eqb n 0 )then 0
    else match fctx with
    | [] => n
    | fcVar :: fctx => 1 + get (n - 1) fctx
    | fcLift :: fctx => 2 + get n fctx
         end
  in
  get n (f_context fctx).

(* TODO: use the same style for the record projections everywhere *)

Definition extend (fctx : forcing_context) : list context_decl * forcing_context :=
  let cat := fctx.(f_category) in
  let last := last_condition fctx in
  let ext :=
      [ Build_context_decl
          hom_name
          None
          (tApp cat.(cat_hom) [(tRel (1 + last)); (tRel 0)]);
          (* replaced mkRel 1 with tRel 0, see comments for [last_condition] *)
        Build_context_decl
          pos_name
          None
          cat.(cat_obj) ]
  in
  (ext, {| f_context := fcLift :: fctx.(f_context);
           f_category := cat;
           f_translator := fctx.(f_translator)|}).

Definition add_variable fctx :=
  {| f_context := fcVar :: fctx.(f_context);
     f_category := fctx.(f_category);
     f_translator := fctx.(f_translator)|}.

(** Handling of globals *)

Definition translate_var fctx n :=
  let p := tRel (last_condition fctx) in
  let f := morphism_var n fctx in
  let m := get_var_shift n fctx in
  tApp (tRel m) [p; f ].

(* TODO: deal with this definition when we add support for inductive definitions *)
(* Definition get_inductive (fctx : forcing_context) (ind : inductive) := *)
(*   let gr := IndRef ind in *)
(*   let gr_ := lookup_default fctx.(f_translator) gr in *)
(*   match gr_ with *)
(*   | IndRef ind_ => ind_ *)
(*   | _ => ind *)
(*   end. *)

Definition should_not_be_ind := tVar "Should not be an application of an inductive type constructor".

(** A stub for the actual evar_map definition *)
Definition evar_map := unit.

Module Environ.
  (** Stub for global environment Environ *)

  Definition rel_declaration := unit.

  Definition env := unit.

  Definition rel_context (e : env) : list rel_declaration := [].
End Environ.

Definition apply_global (env : Environ.env) (sigma : evar_map) gr (u : universe_instance) fctx :=
  (** FIXME -- a comment from the OCaml source code *)
  (* The parameter [u] is never used in the definition *)
  let p' := lookup_default fctx.(f_translator) gr in
  (* let (sigma, c) := Evd.fresh_global env sigma p' in *)
  let last := last_condition fctx in
  match gr with
  | IndRef _ => (sigma, should_not_be_ind)
  | _ => (sigma, tApp p' [ tRel last ])
  end.

(** Forcing translation core *)

Definition not_supported := tVar "Not supported".

Definition is_prop (s : universe) :=
  match s with
  | [(Level.lProp, false)] => true
  | _ => false
  end.

Definition id_translate sigma c : unit * term :=
  (sigma, c).

Definition otranslate_type (tr : Environ.env -> forcing_context -> evar_map -> term -> unit * term)
           (env : Environ.env) (fctx : forcing_context) (sigma : evar_map) (t : term)
  : unit * term :=
  let (sigma, t_) := tr env fctx sigma t in
  let last := tRel (last_condition fctx) in
  let t_ := mkOptApp t_ [ last; tApp fctx.(f_category).(cat_id) [last]] in
(sigma, t_).

Definition otranslate_boxed (tr : unit -> forcing_context -> evar_map -> term -> unit * term)
           (env : Environ.env) (fctx : forcing_context) (sigma : evar_map) (t : term)
  : unit * term :=
  let (ext, ufctx) := extend fctx in
  let (sigma, t_) := tr env ufctx sigma t in
  let t_ := it_mkLambda_or_LetIn t_ ext in
(sigma, t_).

Fixpoint otranslate (env : Environ.env) (fctx : forcing_context)
         (sigma : evar_map) (c : term) {struct c} : evar_map * term :=
  match c with
  | tRel n =>
    let ans := translate_var fctx n in
    (sigma, ans)
| tSort s =>
  let (ext0, fctx) := extend fctx in
  let (ext, fctx) := extend fctx in
  let (sigma, s') :=
      if is_prop s then (sigma, s)
    else
      (* TODO: Not sure how to deal with the universe variable generation *)
      (* Evd.new_sort_variable Evd.univ_flexible sigma *)
      (* Probably, use an empty list as a universe param *)
      (* For now, we just return the original universe, as it is given in the paper *)
      (sigma, s)
  in
  (* let sigma := Evd.set_leq_sort env sigma s s' in *)
  let tpe := it_mkProd_or_LetIn (tSort s') ext in
  let lam := it_mkLambda_or_LetIn tpe ext0 in
  (sigma, lam)
| tCast c k t =>
  let (sigma, c_) := otranslate env fctx sigma c in
  let (sigma, t_) := otranslate_type otranslate env fctx sigma t in
  let ans := tCast c_ k t_ in
  (sigma, ans)
| tProd na t u =>
  let (ext0, fctx) := extend fctx in
  (** Translation of t *)
  let (sigma, t_) :=
      (* inlining otranslate_boxed_type *)
      let (ext, ufctx) := extend fctx in
      (* which, in turn, requires to inline otranslate_type *)
      let (sigma, t_) := otranslate env ufctx sigma t in
      let last := tRel (last_condition fctx) in
      let t_ := mkOptApp t_ [ last; tApp fctx.(f_category).(cat_id) [last]] in

      let t_ := it_mkProd_or_LetIn t_ ext in
      (sigma, t_) in
      (* let (sigma, t_) := otranslate_boxed_type env fctx sigma t in *)
  (** Translation of u *)
  let ufctx := add_variable fctx in
  let (sigma, u_) := otranslate_type otranslate env ufctx sigma u in
  (** Result *)
  let ans := tProd na t_ u_ in
  let lam := it_mkLambda_or_LetIn ans ext0 in
  (sigma, lam)
| tLambda na t u =>
  (** Translation of t *)
  let (sigma, t_) :=
      (* inlining otranslate_boxed_type *)
      let (ext, ufctx) := extend fctx in
      (* which, in turn, requires to inline otranslate_type *)
      let (sigma, t_) := otranslate env ufctx sigma t in
      let last := tRel (last_condition fctx) in
      let t_ := mkOptApp t_ [ last; fctx.(f_category).(cat_id)] in

      let t_ := it_mkProd_or_LetIn t_ ext in
      (sigma, t_) in

  (* let (sigma, t_) := otranslate_boxed_type env fctx sigma t in *)
  (** Translation of u *)
  let ufctx := add_variable fctx in
  let (sigma, u_) := otranslate env ufctx sigma u in
  let ans := tLambda na t_ u_ in
  (sigma, ans)
| tLetIn na c t u =>
  let (sigma, c_) :=
      otranslate_boxed otranslate env fctx sigma c in
  let (sigma, t_) :=
      (* inlining otranslate_boxed_type *)
      let (ext, ufctx) := extend fctx in
      (* which, in turn, requires to inline otranslate_type *)
      let (sigma, t_) := otranslate env ufctx sigma t in
      let last := tRel (last_condition fctx) in
      let t_ := mkOptApp t_ [ last; fctx.(f_category).(cat_id)] in

      let t_ := it_mkProd_or_LetIn t_ ext in
      (sigma, t_) in
  (* let (sigma, t_) := otranslate_boxed_type env fctx sigma t in *)
  let ufctx := add_variable fctx in
  let (sigma, u_) := otranslate env ufctx sigma u in
  (sigma, tLetIn na c_ t_ u_)
(* Comment out the case for inductive types for now *)
(* | tApp t args when isInd t => *)
(*   let (ind, u) := destInd t in *)
(*   otranslate_ind env fctx sigma ind u args *)
| tApp t args =>
  let (sigma, t_) := otranslate env fctx sigma t in
  let fold sigma u := otranslate_boxed otranslate env fctx sigma u in
  (* implementing a specialised version of fold_map' from ftUtils as a nested fix *)
  let fix fold_map_fix a args :=
               match args with
               | [] => (a, [])
               | hd :: tl =>
                 let (a_, c_) := fold sigma hd in
                 let (a__, cs) := fold_map_fix a_ tl in
                 (a__, c_ :: cs)
               end in
  let (sigma, args_) := fold_map_fix sigma args in

  (* the original OCaml code *)
  (* let fold sigma u = otranslate_boxed env fctx sigma u in *)
  (* let (sigma, args_) = CArray.fold_map fold sigma args in *)
  let app := tApp t_ args_ in
  (sigma, app)
| tVar id => (sigma, not_supported)
  (* apply_global env sigma (VarRef id) Univ.Instance.empty fctx *)
| tConst p u =>  apply_global env sigma (ConstRef p) u fctx
| tInd ind u =>
  (* Comment out the case for inductive types for now *)
  (sigma, not_supported)
  (* otranslate_ind env fctx sigma ind u [||] *)
| tConstruct c u _ => (sigma, not_supported)
  (* apply_global env sigma (ConstructRef c) u fctx *)
| tCase ci r c p => (sigma, not_supported)
(* Comment out this case as well, since inductive types are not yet supported by this translation *)
   (* let ind_ = get_inductive fctx ci.ci_ind in *)
   (* let ci_ = Inductiveops.make_case_info env ind_ ci.ci_pp_info.style in *)
   (* let (sigma, c_) = otranslate env fctx sigma c in *)
   (* let fix_return_clause env fctx sigma r = *)
   (*   (** The return clause structure is fun indexes self => Q *)
   (*       All indices must be boxed, but self only needs to be translated *) *)
   (*   let (args, r_) = decompose_lam_assum r in *)
   (*   let ((na, _, self), args) = match args with h :: t -> (h, t) | _ -> assert false in *)
   (*   let fold (sigma, fctx) (na, o, u) =  *)
   (*    (** For every translated index, the corresponding variable is added *)
   (*        to the forcing context *) *)
   (*     let (sigma, u_) = otranslate_boxed_type env fctx sigma u in *)
   (*     let fctx = add_variable fctx in *)
   (*     (sigma, fctx), (na, o, u_) *)
   (*   in *)
   (*   let (sigma, fctx), args = CList.fold_map fold (sigma, fctx) args in *)
   (*   let (sigma, self_) = otranslate_type env fctx sigma self in *)
   (*   let fctx_ = add_variable fctx in *)
   (*   let (sigma, r_) = otranslate_type env fctx_ sigma r_ in *)
   (*   let (ext, ufctx) = extend fctx in *)
   (*   let selfid = Id.of_string "self" in *)
   (*   let r_ = Reductionops.nf_betadeltaiota env Evd.empty r_ in  *)
   (*   let r_ = Vars.substnl [it_mkLambda_or_LetIn (mkVar selfid) ext] 1 (Vars.lift 1 r_) in *)
   (*   let r_ = Reductionops.nf_beta Evd.empty r_ in  *)
   (*   let r_ = Vars.subst_var selfid r_ in *)
   (*   let r_ = it_mkLambda_or_LetIn r_ ((na, None, self_) :: args) in  *)
   (*   (sigma, r_)        *)
   (* in *)
   (* let (sigma, r_) = fix_return_clause env fctx sigma r in *)
   (* let fold sigma u = otranslate env fctx sigma u in *)
   (* let (sigma, p_) = CArray.fold_map fold sigma p in *)
   (* (sigma, mkCase (ci_, r_, c_, p_)) *)
| tFix _ _ => (sigma, not_supported)
| tCoFix _ _ => (sigma, not_supported)
| tProj _ _ => (sigma, not_supported)
| tMeta _ => (sigma, not_supported)
| tEvar _ _ => (sigma, not_supported)
  end.

Definition empty translator cat lift env :=
  let ctx := Environ.rel_context env in
  let empty := {| f_context := []; f_category := cat; f_translator := translator; |} in
  let empty := List.fold_right (fun _ fctx => add_variable fctx) empty ctx in
  let fix flift fctx n :=
      match n with
      | O => fctx
      | S n' => flift (snd (extend fctx)) n'
      end
  in
  flift empty (match lift with None => 0 | Some n => n end).

(** The toplevel option allows to close over the topmost forcing condition *)

Definition translate (toplevel : bool) lift translator cat env sigma c :=
  let empty := empty translator cat lift env in
  let (sigma, c) := otranslate env empty sigma c in
  let ans := if toplevel then tLambda pos_name cat.(cat_obj) c else c in
  (sigma, ans).

Definition translate_simple (toplevel : bool) (cat : category) (c : term) : term :=
  let (_, c_) := translate toplevel None [] cat tt tt c in c_.

Definition translate_type (toplevel : bool) lift translator cat env sigma c :=
  let empty := empty translator cat lift env in
  let (sigma, c) := otranslate_type otranslate env empty sigma c in
  let ans := if toplevel then tProd pos_name cat.(cat_obj) c else c in
  (sigma, ans).

Definition translate_type_simple (toplevel : bool) (cat : category) (c : term) : term :=
  let (_, c_) := translate_type toplevel None [] cat tt tt c in c_.


Require Export SpecSemantics.
Require Export BoilerplateSyntax.
Set Implicit Arguments.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma DTyping_bind_lengthExt {Γ ds Δ} (wd : DTyping Γ ds Δ) :
  bind ds = lengthExt Δ.
Proof.
  induction wd; simpl; auto.
  - rewrite IHwd, lengthExt_append; simpl.
    reflexivity.
Qed.

Lemma shift_etvar_typing {Γ1 t T} (wt : Typing Γ1 t T) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → Typing Γ2 (tshiftTm c t) (tshiftTy c T).
Proof.
  induction wt using ind_typing with
  (P0 := fun Γ1 ds Δ wtd =>
           ∀ {c Γ2}, shift_etvar c Γ1 Γ2 →
             DTyping Γ2 (tshiftDecls c ds) (tshiftExt c Δ)); simpl; intros;
    try rewrite tshiftTy_tsubstTy_comm;
    try rewrite tshiftExt_append; econstructor;
    eauto using shift_etvar_wftyp, shift_etvar_lookup_evar, weakenshift_etvar.
Qed.

Lemma shift_evar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
 ∀ {c Γ2}, shift_evar c Γ1 Γ2 → Typing Γ2 (shiftTm c t) T.
Proof.
  induction wt using ind_typing with
  (P0 := fun Γ1 ds Δ wtd =>
           ∀ {c Γ2}, shift_evar c Γ1 Γ2 →
             DTyping Γ2 (shiftDecls c ds) Δ); simpl; intros;
    econstructor; try erewrite DTyping_bind_lengthExt;
    eauto using shift_evar_lookup_evar, shift_evar_wftyp, weakenshift_evar.
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Inductive subst_etvar : nat → Ty → Env → Env → Prop :=
  | tse_here {Γ : Env} {T} :
      wfTy Γ T →
      subst_etvar O T (etvar Γ) Γ
  | tse_var {Γ1 : Env} {Γ2 : Env} {T' T} {X} :
      subst_etvar X T' Γ1 Γ2 →
      subst_etvar X T' (evar Γ1 T) (evar Γ2 (tsubstTy X T' T))
  | tse_etvar {Γ1 : Env} {Γ2 : Env} {X T'} :
      subst_etvar X T' Γ1 Γ2 →
      subst_etvar (S X) T' (etvar Γ1) (etvar Γ2).
Hint Constructors subst_etvar.

Lemma weaken_subst_etvar {Γ1 Γ2 : Env} {Δ : Ext} {X T'} :
  subst_etvar X T' Γ1 Γ2 →
  subst_etvar X T' (extend Γ1 Δ) (extend Γ2 (tsubstExt X T' Δ)).
Proof.
  revert X T' Γ1 Γ2; induction Δ; simpl; intros; try constructor; auto.
Qed.
Hint Resolve weaken_subst_etvar.

Lemma subst_etvar_lookup_etvar {Γ1 Γ2 : Env} {X T' Y} :
  subst_etvar X T' Γ1 Γ2 → lookup_etvar Γ1 Y →
  wfTy Γ2 (tsubstIndex X T' Y).
Proof.
  intros esub gb; revert Γ2 X esub.
  induction gb; intros; dependent destruction esub; simpl;
    auto using wf_tvar, weakening_etvar_wftyp, weakening_var_wftyp.
Qed.
Hint Resolve subst_etvar_lookup_etvar.

Lemma subst_etvar_wftyp_ind {Γ1 Γ2 : Env} {X T' T} :
  subst_etvar X T' Γ1 Γ2 → wfTy Γ1 T → wfTy Γ2 (tsubstTy X T' T).
Proof.
  intros esub st; revert Γ2 X T' esub.
  induction st; simpl; intros; eauto using wfTy, subst_etvar_lookup_etvar.
Qed.

Lemma subst_etvar_lookup_evar {Γ1 : Env} {Γ2 : Env} {X x T' T} :
  subst_etvar X T' Γ1 Γ2 → lookup_evar Γ1 x T →
  lookup_evar Γ2 x (tsubstTy X T' T).
Proof.
  intros sube gv; revert x T gv.
  induction sube; intros; dependent destruction gv; simpl;
    try rewrite tsubstTy_tshiftTy_reflection;
    try rewrite tsubstTy_tshiftTy_comm; try constructor; auto.
Qed.

Inductive subst_evar : Subst → Tm → Env → Env → Prop :=
  | se_here {Γ : Env} {t T} :
      Typing Γ t T →
      subst_evar sub_here t (evar Γ T) Γ
  | se_var {Γ1 Γ2 : Env} {T t} {x} :
      subst_evar x t Γ1 Γ2 →
      subst_evar (sub_var x) t (evar Γ1 T) (evar Γ2 T)
  | se_etvar {Γ1 Γ2 : Env} {x} {t} :
      subst_evar x t Γ1 Γ2 →
      subst_evar (sub_tvar x) t (etvar Γ1) (etvar Γ2).
Hint Constructors subst_evar.

Lemma weaken_subst_evar {Γ1 Γ2 : Env} {Δ : Ext} {x} {t} :
  subst_evar x t Γ1 Γ2 →
  subst_evar (weakenSubst (lengthExt Δ) x) t (extend Γ1 Δ) (extend Γ2 Δ).
Proof.
  revert x Γ1 Γ2.
  induction Δ; simpl; intros; try constructor; auto.
Qed.

Lemma subst_evar_lookup_etvar {Γ1 Γ2 : Env} {x t Y} :
  subst_evar x t Γ1 Γ2 → lookup_etvar Γ1 Y → lookup_etvar Γ2 Y.
Proof.
  intros sube gv; revert Y gv.
  induction sube; intros; dependent destruction gv; simpl;
    try constructor; auto.
Qed.

Lemma subst_evar_wftyp_ind {Γ1 Γ2 : Env} {x t T} :
  subst_evar x t Γ1 Γ2 → wfTy Γ1 T → wfTy Γ2 T.
Proof.
  intros esub st; revert Γ2 x t esub.
  induction st; simpl; eauto using subst_evar_lookup_etvar, wfTy.
Qed.

Lemma subst_evar_lookup_evar {Γ1 Γ2 : Env} {x t y T} :
  subst_evar x t Γ1 Γ2 → lookup_evar Γ1 y T → Typing Γ2 (substIndex x t y) T.
Proof.
  intros esub gv; revert Γ2 x esub.
  induction gv; intros; dependent destruction esub; simpl;
    eauto using T_Var, shift_evar_typing, shift_etvar_typing.
Qed.

Lemma subst_evar_typing_dtyping_ind :
  ∀ Γ1,
  (∀ {t T} (wt : Typing Γ1 t T),
    ∀ {x t' Γ2}, subst_evar x t' Γ1 Γ2 →
                 Typing Γ2 (substTm x t' t) T) ∧
  (∀ {ds Δ} (wtd : DTyping Γ1 ds Δ),
    ∀ {x t' Γ2}, subst_evar x t' Γ1 Γ2 →
                 DTyping Γ2 (substDecls x t' ds) Δ).
Proof.
  apply ind_typing_dtyping; simpl; intros; eauto using subst_evar_lookup_evar;
    try rewrite (DTyping_bind_lengthExt d); econstructor;
    eauto using subst_evar_wftyp_ind, weaken_subst_evar.
Qed.

Lemma subst_evar_typing_ind {Γ1 t T} (wt : Typing Γ1 t T) :
  ∀ {x t' Γ2}, subst_evar x t' Γ1 Γ2 → Typing Γ2 (substTm x t' t) T.
Proof. apply subst_evar_typing_dtyping_ind; auto. Qed.

Lemma subst_evar_typing {Γ : Env} {s S t T} :
  Typing Γ s S → Typing (evar Γ S) t T → Typing Γ (substTm sub_here s t) T.
Proof.
  intros wt_s wt_t; apply (subst_evar_typing_ind wt_t).
  constructor; auto.
Qed.

Lemma subst_evar_dtyping {Γ : Env} {s S ds Δ} :
  Typing Γ s S → DTyping (evar Γ S) ds Δ →
  DTyping Γ (substDecls sub_here s ds) Δ.
Proof.
  intros wt_s wt_ds.
  apply (proj2 (subst_evar_typing_dtyping_ind _) _ _ wt_ds).
  constructor; auto.
Qed.

Lemma subst_etvar_typing_dtyping_ind :
  ∀ Γ1,
  (∀ {t T} (wt : Typing Γ1 t T),
    ∀ {X T' Γ2}, subst_etvar X T' Γ1 Γ2 →
                 Typing Γ2 (tsubstTm X T' t) (tsubstTy X T' T)) /\
  (∀ {ds Δ} (wtd : DTyping Γ1 ds Δ),
    ∀ {X T' Γ2}, subst_etvar X T' Γ1 Γ2 →
                 DTyping Γ2 (tsubstDecls X T' ds) (tsubstExt X T' Δ)).
Proof.
  apply ind_typing_dtyping; simpl; intros;
    try rewrite tsubstTy_tsubstTy_comm;
    try rewrite tsubstExt_append; econstructor;
    eauto using subst_etvar_lookup_evar, subst_etvar_wftyp_ind.
Qed.

Lemma subst_etvar_typing :
  (∀ {Γ1 t T} (wt : Typing Γ1 t T),
    ∀ {X T' Γ2}, subst_etvar X T' Γ1 Γ2 →
                 Typing Γ2 (tsubstTm X T' t) (tsubstTy X T' T)).
Proof.
  apply subst_etvar_typing_dtyping_ind.
Qed.


Require Export Utf8.
Require Export Program.Basics.
Require Export FunctionalExtensionality.
Require Import Coq.Arith.Even.

Create HintDb soundness.

Ltac inv H := inversion H; subst; clear H.
Ltac inj H := injection H; intros; subst.

Notation "f '$' x" := (f x)
  (at level 20, right associativity, only parsing).

Notation "f ∘ g" := (compose g f).
Definition id := fun {A : Type} (a : A) => a.

Inductive Identity (A : Type) : Type := identity : A → Identity A.
Arguments identity {A} a.

Lemma id_refl : forall {A : Type} (x : A), id x = x.
Proof. reflexivity. Qed.
Lemma id_compose_left : forall {A B} (f : A -> B), id ∘ f = f.
Proof. reflexivity. Qed.
Lemma id_compose_right : forall {A B} (f : A -> B), f ∘ id = f.
Proof. reflexivity. Qed.

Hint Rewrite @id_refl @id_compose_left @id_compose_right : soundness.

Definition flip {A B C : Type} (f : A → B → C) (x : B) (y : A) : C :=
  f y x.

Ltac ext := let x := fresh "x" in extensionality x.

Ltac unmatch x :=
  match x with
  | context [match ?y with _ => _ end] => unmatch y
  | _ => destruct x eqn:?
  end.

(* The destr tactic gets rid of let bindings in the goal, match constructs in
 * the goal and equality between pairs in the context *)
Ltac destr :=
  match goal with
  | [ |- context [match ?x with _ => _ end]] => unmatch x
  | [ |- context [let (_, _) := ?x in _]] => destruct x eqn:?
  | H : (_ , _) = (_, _) |- _ => inv H
  | H : _ /\ _ |- _ => destruct H
  | H : match ?x with _ => _ end |- _ => destruct x eqn:?
  | |- _ ∧ _ => split
  end.

Ltac simplify := simpl in *; intros; repeat ext; try destr;
  destruct_all unit.

(* We have some recursive typeclasses instances, for example Monad M ->
 * Monad (MaybeT M). As typeclass instances search by default is depth first
 * and unbounded, we set an upperbound here to avoid infinite loops *)
Global Set Typeclasses Depth 10.

Class top_op (A:Type) : Type := top : A.
Notation "⊤" := top (at level 40).

Inductive toplift (A: Type) :=
  | Top : top_op (toplift A)
  | NotTop : A → toplift A.
Arguments Top {A}.
Arguments NotTop {A}.
Notation "t +⊤" := (toplift t) (at level 39).

Inductive botlift (A:Type) : Type :=
  | Bot
  | NotBot (x:A).
Arguments Bot {A}.
Arguments NotBot {A}.
Notation "t +⊥" := (botlift t) (at level 39).

Section top_bot_coercions.
  Context {A : Type}.

  Definition A_to_top (a : A) : (A+⊤) := NotTop a.
  Coercion A_to_top : A >-> toplift.

  Definition A_to_bot (a : A) : (A+⊥) := NotBot a.
  Coercion A_to_bot : A >-> botlift.
End top_bot_coercions.

Class SubType (sub : Type) (super : Type) : Type := {
  inject : sub → super;
  project : super → option sub
}.

Instance subtype_l : ∀ {A B}, SubType A (A + B) := {
  inject := inl;
  project := λ s, match s with | inl x => Some x | _ => None end
}.

Instance subtype_r : ∀ {A B}, SubType B (A+B) := {
  inject := inr;
  project := λ s, match s with | inr x => Some x | _ => None end
}.

Instance subtype_trans_r : ∀ {A B C} `{SubType A B}, SubType A (C + B) := {
  inject := inject ∘ inr;
  project := λ s, match s with | inr x => project x | _ => None end
}.

Instance subtype_trans_l {A B C} `{S : SubType A B} : SubType A (B + C).
Proof. destruct S as [inject project]. split.
  - exact (λ a, inl (inject a)).
  - exact (λ bc, match bc with
                 | inr _ => None
                 | inl b => project b
                 end).
Defined.

Instance subtype_top_r : ∀ A, SubType A (A+⊤) := {
  inject := NotTop;
  project := λ a, match a with
                  | Top => None
                  | NotTop x => Some x
                  end;
}.

Instance subtype_bot_r : ∀ A, SubType A (A+⊥) := {
  inject := NotBot;
  project := λ a, match a with
                  | Bot => None
                  | NotBot x => Some x
                  end;
}.

Instance subtype_top_l {A B} `{SubType A B} :
  SubType (A+⊤) (B+⊤).
Proof. destruct H as [inject project]. split.
  exact (λ a : (A+⊤), match a with
                      | Top => Top
                      | NotTop x => NotTop( inject x)
                      end).
  exact (λ b : (B+⊤), match b with
                      | Top => None
                      | NotTop x => match (project x) with
                                    | Some x' => Some (NotTop x')
                                    | None => None
                                    end
                      end).
Defined.

Notation "℘ A" := (A → Prop) (at level 0, only parsing).
Definition union {U : Type} (A B : U → Prop) : U → Prop :=
  λ u : U, A u ∨ B u.
Infix "∪" := union (at level 40).

Definition intersection {U : Type} (A B : U → Prop) : U → Prop :=
  λ u : U, A u ∧ B u.
Infix "∩" := intersection (at level 40).

Definition subset {U : Type} (A B : U → Prop) : Prop :=
  ∀ u : U, A u → B u.
Infix "⊆" := subset (at level 40).