Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.common.Memory.

Require Import MSets.MSetPositive.
Import PositiveSet. Module PSet:= PositiveSet. (*For positive-indexed sets*)

Require Import Coq.Classes.Morphisms.
Require Import Relation_Definitions.
Require Import Coq.Classes.RelationClasses.

(** *  HEAP *)

Section ParametricInVal.
  Context {val:Type}. (*Val is the type of contents in the heap*)

  (* Address are pairs of 'blocks' and ofsets*)
  (* Blocks represent objects in Clight *)
  Definition address:= (positive * Int.int)%type.

  (*Address is decidable*)
  Lemma address_dec: forall ad1 ad2: address, {ad1 = ad2} + {ad1 <> ad2}.
  Proof.
    destruct ad1 as [b1 ofs1];
      destruct ad2 as [b2 ofs2].
    destruct (AST.ident_eq b1 b2);
      destruct (Int.eq_dec ofs1 ofs2);
      subst; auto; right;
        intros HH; inversion HH; subst;
          congruence.
  Qed.
  Definition add_eq (a1 a2:address):bool:=
    match a1, a2 with
    | (b1, ofs1), (b2, ofs2) =>
      Pos.eqb b1 b2 &&  Int.eq ofs1 ofs2
    end.

  (*Heap maps address to memory locations*)
  Definition heap:= address -> option val.
  Definition empty_heap:heap := fun _ => None.

  (* Heaps are equivalente if pointwise equivalent*)
  Definition heap_equiv: relation (address -> option val) := pointwise_relation _ Logic.eq.
  Global Instance Equivalenc_heap_equiv: Equivalence heap_equiv:= _.

  Definition remove_heap (h:heap) (add:address): heap:=
    fun add' =>  if add_eq add add' then None else h add'.

  Global Instance Proper_remove_heap: Proper ( heap_equiv ==> Logic.eq ==> heap_equiv) remove_heap.
  Proof.
    intros ? ? ? ? ? ? id; subst.
    cbv delta [remove_heap] beta.
    destruct (add_eq y0 id); auto.
  Qed.

  Definition upd_heap (h:heap) (add:address) (v:val) : heap:=
    fun add' =>  if add_eq add add' then Some v else h add'.

  Definition update_heap (h:heap) (add:address) (value:option val) : heap:=
    match value with
    | None => remove_heap h add
    | Some v =>  upd_heap h add v
    end.

  Global Instance Proper_update_heap: Proper ( heap_equiv ==> Logic.eq ==> Logic.eq ==> heap_equiv) update_heap.
  Proof.
    intros ? ? ? ? ? ? ? ? ? id; subst.
    destruct y1 as [v_ty|]; simpl.
    - cbv delta [update_heap upd_heap] beta.
      destruct (add_eq y0 id); auto.
    - eapply Proper_remove_heap; auto.
  Qed.

  Lemma int_eq_iff:
    forall i i0,
      Int.eq i i0 = true <-> i = i0.
    intros; split;
      intros; subst;
        try apply Int.eq_true; auto.
    pose proof (Int.eq_spec i i0).
    rewrite H in H0; auto.
  Qed.
  Lemma int_neq_iff:
    forall i i0,
      Int.eq i i0 = false <-> i <> i0.
    intros; split;
      intros; subst;
        try apply Int.eq_false; auto.
    pose proof (Int.eq_spec i i0).
    rewrite H in H0; auto.
  Qed.

  Lemma add_deq_true: forall a1 a2,
      a1 = a2 <->
      add_eq a1 a2 = true.
  Proof.
    intros a1 a2; destruct a1, a2.
    unfold add_eq.
    rewrite andb_true_iff,Pos.eqb_eq, int_eq_iff.
    split; intros H; inversion H; subst; auto.
  Qed.

  Lemma upd_heap_gss:
    forall (h : heap) (v : val) (addr : address),
      upd_heap h addr v addr <> None.
  Proof. intros.
         unfold upd_heap; simpl.
         assert (HH:addr = addr) by reflexivity.
         apply (add_deq_true) in HH.
         rewrite HH. intros; discriminate.
  Qed.

  Lemma add_deq_false: forall a1 a2,
      a1 <> a2 <->
      add_eq a1 a2 = false.
  Proof.
    intros a1 a2; destruct a1, a2.
    unfold add_eq.
    rewrite andb_false_iff, Pos.eqb_neq, int_neq_iff.
    split; intros H.
    - apply Classical_Prop.not_and_or; intros []; subst.
      apply H; auto.
    - apply Classical_Prop.or_not_and in H.
      intros HH; apply H; inversion HH; auto.
  Qed.

  (* Tactic that does case analysis over add_dec*)
  (* Practical for things like 'if add_dec a b' then _ else _*)
  Ltac destruct_add_dec:=
    match goal with
    | [ |- context [add_eq ?a1 ?a2] ] =>
      match goal with
      | [ H: a1 = a2 |- _ ] =>
        let H0 := fresh "HH" in
        assert (H0:=H);
        apply add_deq_true in H0; rewrite H0; clear H0
      | [ H: a2 = a1 |- _ ] =>
        symmetry in H;
        let H0 := fresh "HH" in
        assert (H0:=H);
        apply add_deq_true in H0; rewrite H0; clear H0
      | [ H: a1 <> a2 |- _ ] =>
        let H0 := fresh "HH" in
        assert (H0:=H);
        apply add_deq_false in H0; rewrite H0; clear H0
      | [ H: a2 <> a1 |- _ ] =>
        let H0 := fresh "HH" in
        assert (H0: a1 <> a2) by
            (let H1 := fresh "H" in intros H1; apply H; auto);
        apply add_deq_false in H0; rewrite H0; clear H0
      | _ =>
        let H := fresh "H" in
        let H0 := fresh "HH" in
        destruct (address_dec a1 a2) as [H | H];
        assert (H0:=H);
        [apply (add_deq_true) in H0| apply (add_deq_false) in H0];
        rewrite H0; clear H0
      end
    end.

  Lemma heap_gro:
    forall id h id',
      id <> id' ->
      (remove_heap h id') id = h id.
  Proof.
    cbv delta[find remove_heap] beta; intros.
    let H0 := fresh "HH" in
    assert (H0:=H).
    apply add_deq_false in HH.
    destruct_add_dec; auto.
  Qed.
  Lemma heap_grs:
    forall id e,
      (remove_heap e id) id = None.
  Proof.
    cbv delta[find remove_heap] beta; intros.
    destruct_add_dec; auto.
    congruence.
  Qed.
  Lemma heap_gss:
    forall e id v_ty,
      (update_heap e id v_ty) id = v_ty.
  Proof.
    intros.
    destruct v_ty; simpl.
    - cbv delta[upd_heap] beta.
      destruct_add_dec; auto.
      congruence.
    - rewrite heap_grs; reflexivity.
  Qed.
  Lemma heap_gso:
    forall e id id' v_ty,
      id <> id' ->
      (update_heap e id v_ty) id' = e id'.
  Proof.
    intros.
    destruct v_ty; simpl.
    - cbv delta[upd_heap] beta.
      destruct_add_dec; auto.
    - rewrite heap_gro; auto.
  Qed.

  Lemma heap_redundant_update:
    forall e i v_ty v_ty',
      heap_equiv (update_heap (update_heap e i v_ty) i v_ty')
                 (update_heap e i v_ty').
  Proof.
    intros ? ? ? ? id.
    destruct v_ty', v_ty; simpl;
      unfold update_heap, upd_heap, remove_heap;
      destruct_add_dec; auto.
  Qed.
  Lemma heap_update_comm:
    forall e i j v_ty v_ty',
      i <> j ->
      heap_equiv (update_heap (update_heap e i v_ty) j v_ty')
                 (update_heap (update_heap e j v_ty') i v_ty).
  Proof.
    intros ? ? ? ? ? NEQ id.
    destruct v_ty', v_ty; simpl;
      unfold update_heap, upd_heap, remove_heap;
      repeat destruct_add_dec; subst; auto.
    contradict NEQ; auto.
    contradict NEQ; auto.
    contradict NEQ; auto.
  Qed.

  Lemma heap_pointless_update:
    forall e k v_ty,
      e k = v_ty ->
      heap_equiv (update_heap e k v_ty) e.
  Proof.
    intros ? ? ? ? id.
    destruct v_ty; simpl;
      unfold update_heap, upd_heap, remove_heap;
      repeat destruct_add_dec; subst; auto.
  Qed.

End ParametricInVal.


Require Import String List.
Import ListNotations.

From ASUB Require Import Nterm Language GenM Utils Names.

Inductive substScope := SubstScope : list string -> list nterm -> substScope.
Inductive substTy : Type :=
| SubstRen : list nterm -> substTy
| SubstSubst : list nterm -> substTy
| SubstEq : list nterm -> (string -> Binder -> nterm -> GenM.t nterm) -> substTy.

Definition ss_terms (is_wellscoped: bool) (ss: substScope) :=
  if is_wellscoped
  then match ss with SubstScope _ xs => xs end
  else [].

Definition ss_terms_all (ss: substScope) :=
  match ss with SubstScope _ xs => xs end.

Definition ss_names (ss: substScope) :=
  match ss with SubstScope names _ => names end.

Definition sty_terms (st: substTy) :=
  match st with
  | SubstRen nts => nts
  | SubstSubst nts => nts
  | SubstEq nts _ => nts
  end.


Require Export parser.
Require Export refine.

Definition P3: IA := parse
"IA [IDLE_T, HP_F_T, CONR_S_T, DA_S_T, DISC_S_T, HP_S_T, DISC_F_T, DA_F_T, CONRS_F_T] (IDLE_T)
 [T_HPDATA_req_F, T_CONN_resp_F, T_DATA_req_F, T_DISC_req_F, T_HPDATA_req_S,
  T_DISC_req_S, T_DATA_req_S, T_CONN_req_S]
 [T_HPDATA_ind_S, T_CONN_conf_S, T_DATA_ind_S, T_DISC_ind_S, T_HPDATA_ind_F,
  T_DISC_ind_F, T_DATA_ind_F, T_CONN_ind_F] [e]
 [ IDLE_T->(T_HPDATA_req_F)HP_F_T, HP_F_T->(T_HPDATA_ind_S)IDLE_T,
   IDLE_T->(T_CONN_resp_F)CONRS_F_T, CONRS_F_T->(T_CONN_conf_S)IDLE_T,
   IDLE_T->(T_DATA_req_F)DA_F_T, DA_F_T->(T_DATA_ind_S)IDLE_T,
   IDLE_T->(T_DISC_req_F)DISC_F_T, DISC_F_T->(T_DISC_ind_S)IDLE_T,
   IDLE_T->(T_HPDATA_req_S)HP_S_T, HP_S_T->(T_HPDATA_ind_F)IDLE_T,
   IDLE_T->(T_DISC_req_S)DISC_S_T, DISC_S_T->(T_DISC_ind_F)IDLE_T, DISC_S_T->(e)IDLE_T,
   IDLE_T->(T_DATA_req_S)DA_S_T, DA_S_T->(T_DATA_ind_F)IDLE_T,
   IDLE_T->(T_CONN_req_S)CONR_S_T, CONR_S_T->(T_CONN_ind_F)IDLE_T
 ]".

(* SME-NI: true *)

Definition P3_hid: IA :=
 IAutomaton.hiding P3
   (ASet.GenActs [&"T_HPDATA_req_F", &"T_HPDATA_req_S", &"T_HPDATA_ind_S", &"T_HPDATA_ind_F"]).

Definition P3_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement P3 (&"tau") (ASet.GenActs [&"T_HPDATA_req_F", &"T_HPDATA_req_S"]) )
 (ASet.GenActs [&"T_HPDATA_ind_S", &"T_HPDATA_ind_F"]).

Eval compute in :> P3_hid.
Eval compute in :> P3_rep.
Eval compute in SMENI_refinement P3_rep P3_hid.


Require Export Coq.Lists.ListSet.
Require Export Coq.Classes.SetoidDec.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export formulatheory_def.
Require Export formulatheory_proofs.
Require Export formulatheory_int.
Import FormulaTheory.

Program Instance FormulaTheory_Ins: FormulaTheory Formula Name FM :=
  {
  names:= names_func;
  wfTree:= wfTree_func;
  names_:= ns_func;
  wt:= wt_func;
  wtFormulae:= wfFormulae_func;
  satisfies:= satisfies_func;
  my_set_add := my_set_add_func;
  my_set_remove := my_set_remove_func;

}.  Next Obligation.
{ (*name_dec*)
  apply name_dec_axiom.

} Qed.
  Next Obligation.
{ (*formNames*)
  induction f.
    + simpl in H0. contradiction.
    + simpl in H0. contradiction.
    + simpl in H, H0. intuition. rewrite H1 in H. apply H.
    + simpl in H, H0. intuition.
    + simpl in H. destruct H. intuition. simpl in H0.
    apply set_union_elim in H0. inversion H0.
      - apply H2. apply H4.
      - apply set_diff_elim1 in H4. apply H3. apply H4.
    + simpl in H. destruct H. simpl in H0. apply set_union_elim in H0.
      inversion H0.
      - apply IHf1. apply H. apply H2.
      - apply set_diff_elim1 in H2. apply IHf2.
        * apply H1.
        * apply H2.

} Qed.
  Next Obligation.
{ (*formNames2*)
  unfold not.
  induction f.
    + simpl; tauto.
    + simpl; tauto.
    + simpl in H. unfold not in H0. intros.
      simpl in H1. intuition. apply H0. rewrite <- H2. apply H.
    + simpl; tauto.
    + simpl. intros. simpl in H. destruct H. apply set_union_elim in H1.
      inversion H1.
      - apply IHf1.
        * apply H.
        * apply H3.
      - apply set_diff_elim1 in H3. apply IHf2.
        * apply H2.
        * apply H3.
   + simpl. intros. simpl in H. destruct H. apply set_union_elim in H1.
      inversion H1.
      - apply IHf1.
        * apply H.
        * apply H3.
      - apply set_diff_elim1 in H3. apply IHf2.
        * apply H2.
        * apply H3.

} Qed.
  Next Obligation.  { (*satisfies1*)
    induction f.
  + simpl; reflexivity.
  + simpl; reflexivity.
  + simpl. simpl in H. unfold not in H. intuition. apply H1 in H0.
    - contradiction.
    - rewrite n. rewrite n0. reflexivity.
  + simpl. intros. apply not_compat. apply IHf. apply H.
  + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize IHf1. specialize IHf2.
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
 + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize IHf1. specialize IHf2.
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
} Qed.
  Next Obligation.
{ (*satisfies2*)
   induction f.
  + simpl; reflexivity.
  + simpl; reflexivity.
  + simpl. simpl in H. unfold not in H. intuition. apply H1 in H0.
    - contradiction.
    - rewrite n. rewrite n0. reflexivity.
  + simpl. intros. apply not_compat. apply IHf. apply H.
  + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize IHf1. specialize IHf2.
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
 + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize IHf1. specialize IHf2.
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
} Qed.
  Next Obligation.
{ (*wtFormSameFeature*)
 induction f.
    + auto.
    + auto.
    + simpl. simpl in H0. unfold ns_func in H.
    rewrite H in H0. apply H0.
    + auto.
    + induction abs, con. simpl. destruct H0. intuition.
    + induction abs, con. simpl. destruct H0. intuition.
} Qed.


(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Soundness of the Focusing system
*)

Require Export TriSystem.
Require Export SequentCalculi.
Require Export Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

#[local] Hint Resolve Nat.le_max_r Nat.le_max_l : core .

Theorem Soundness : forall B n  M A ,
    lexpPos M ->
    n |-F- B ; M ; A  -> exists m, m |-- B ; M ++ (Arrow2LL A).
  intros B n M  A MPos.
  Proof.

    generalize dependent B.
    generalize dependent M.
    generalize dependent A.
    induction n using strongind;
      intros A M MPos B H1.
    + inversion H1;subst;eexists;simpl.
      ++ (* init1 *)
        eapply sig2h_init.
        eauto.
      ++ (* init2 *)
        rewrite H.
        eapply sig2h_copy with (F:= A0 ⁻);auto.
        eapply sig2h_init.
        eauto.
      ++ (* one *)
        eapply sig2h_one;auto.
      ++ (* top *)
        eapply sig2h_top.
        eauto.

    (** INDUCTIVE CASES *)
    + inversion H1;subst.
      ++ (* tensor *)
        apply H in H3;auto.
        apply H in H4;auto.
        inversion H3 as [n1 H3'].
        inversion H4 as [n2 H4'].
        simpl in H3'.
        simpl in H4'.
        eexists.
        simpl.
        rewrite H2.
        eapply sig2h_tensor with (N:=M0) (M:=N) (F:=F) (G:=G);simpl.
        solve_permutation.
        assert(N ++ [F] =mul= F ::N) as __Hmset1__ by (rewrite union_comm_app; reflexivity).
        rewrite __Hmset1__ in H3'.
        eassumption.
        assert(M0 ++ [G] =mul= G ::M0) as __Hmset2__  by (rewrite union_comm_app; reflexivity).
        rewrite __Hmset2__  in H4'.
        eassumption.
        eapply LPos2; eassumption.
        eapply LPos3; eassumption.
      ++ (* oplus *)
        apply H in H2;auto.
        inversion H2.
        eexists.
        simpl. simpl in H0.
        eapply sig2h_plus1 with (F:=F) (M:=M).
        solve_permutation.
        rewrite union_comm_app in H0.
        eauto.

      ++ (* oplus2 *)
        apply H in H2;auto.
        inversion H2.
        eexists.
        simpl. simpl in H0.
        eapply sig2h_plus2 with (G:=G) (M:=M).
        solve_permutation.
        rewrite union_comm_app in H0.
        eauto.
      ++ (* bang *)
        apply H in H2;auto.
        inversion H2.
        eexists.
        simpl. simpl in H0.
        eapply sig2h_bang with (F:=F);auto.
        apply H0.
      ++ (* Release *)
        apply H in H3;auto.

      ++ (* bottom *)
        apply H in H2;auto.
        inversion H2.
        simpl in H0.
        eexists.
        simpl.
        eapply sig2h_bot;eauto.
      ++ (* par *)
        apply H in H2;auto.
        inversion H2.
        simpl in H0.
        eexists.
        simpl.
        eapply sig2h_par;auto.
        assert ( M ++ F :: G :: M0 =mul=  F :: G :: M ++ M0) by solve_permutation.
        rewrite H3 in H0.
        eauto.

      ++ (* with *)
        apply H in H2;auto.
        apply H in H3;auto.
        inversion H2.
        inversion H3.
        simpl in *.
        eexists.

        apply sig2h_with with (F:=F) (G:=G) (M:=M ++ M0).
        solve_permutation.

        assert( M ++ ([F] ++ M0) =mul=  [F] ++ (M ++ M0)) by auto.
        rewrite H5 in H0.
        eauto.
        assert( M ++ ([G] ++ M0) =mul=  [G] ++ (M ++ M0)) by auto.
        rewrite H5 in H4.
        eauto.
      ++  (* ? *)
        apply H in H2;auto.
        inversion H2.
        eexists.
        simpl. simpl in H0.
        apply sig2h_quest with (F:=F) (M := M ++ M0).
        solve_permutation.
        rewrite union_comm_app in H0.
        eauto.
      ++ (* store *)
        apply H in H3;auto.
        inversion H3.
        eexists.
        simpl. simpl in H0.
        rewrite <- union_assoc_app in H0.
        simpl in H0.
        eassumption.
        apply LPos1 with (L:=[F] ++ M);eauto.
        simpl;split;auto.

      ++ (* decide *)
        apply H in H4;auto.
        inversion H4.
        eexists.
        simpl. simpl in H0.
        rewrite H3.
        simpl.
        rewrite app_nil_r.
        rewrite union_comm_app in H0.
        eassumption.
        apply  LPos1 in H3;auto.
        eapply LPos3 with (L:= [F] ++ L') ;auto.

      ++ (* decide *)
        apply H in H4;auto.
        inversion H4.
        eexists.
        simpl. simpl in H0.
        rewrite H3.
        eapply sig2h_copy with (F:=F);auto.
        rewrite H3 in H0.
        rewrite (union_comm_cons).
        eauto.
  Qed.


Require Import Coq.Lists.List.
Import ListNotations.

(** * What users need to know **)
(** ** Parameters *)

Inductive connective :=
| impp
| andp
| orp
| falsep
| truep
| negp
| iffp
| coq_prop
| sepcon
| wand
| emp
| multi_imp
| iter_andp
| iter_sepcon
| empty_context.

Inductive judgement :=
| provable
| derivable
| derivable1
| logic_equiv
| corable.

Inductive type :=
| prog_state
| expr
| context.

Inductive parameter :=
| CP (c: connective)
| JP (j: judgement)
| TP (t: type).

Coercion CP: connective >-> parameter.
Coercion JP: judgement >-> parameter.
Coercion TP: type >-> parameter.

Inductive how_connective :=
| primitive_connective (c: connective)
| ___predicate_over_states (mono: bool) (c: connective)
| FROM_andp_impp_TO_iffp
| FROM_falsep_impp_TO_negp
| FROM_falsep_impp_TO_truep
| FROM_impp_negp_TO_orp
| FROM_negp_falsep_TO_truep
| FROM_negp_truep_TO_falsep
| FROM_impp_TO_multi_imp
| FROM_andp_TO_iter_andp
| FROM_sepcon_TO_iter_sepcon
| FROM_empty_set_TO_empty_context.

Definition primitive_connectives := map primitive_connective.
Definition predicate_over_states := ___predicate_over_states false.
Definition mpredicate_over_states := ___predicate_over_states true.
Definition predicates_over_states := map predicate_over_states.
Definition mpredicates_over_states := map mpredicate_over_states.

Inductive how_judgement :=
| primitive_judgement (j: judgement)
| ___USE_valid_FOR_provable (mono: bool)
| ___USE_consequence_FOR_derivable (mono fin: bool)
| FROM_provable_TO_derivable
| FROM_derivable_TO_provable
| FROM_provable_TO_derivable1
| FROM_provable_TO_logic_equiv
| FROM_derivable1_TO_logic_equiv(*
| FROM_derivable1_TO_provable*).

Definition USE_valid_FOR_provable := ___USE_valid_FOR_provable false.
Definition USE_mono_valid_FOR_provable := ___USE_valid_FOR_provable true.
Definition USE_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable false false.
Definition USE_mono_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable true false.
Definition USE_fin_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable false true.
Definition USE_mono_fin_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable true true.

(* TODO: Add coq_prop for derivitive1 *)
Inductive rule_class :=
| provability_OF_impp
| provability_OF_andp
| provability_OF_orp
| provability_OF_falsep
| provability_OF_truep
| provability_OF_iffp
| provability_OF_negp
| provability_OF_iter_andp
| provability_OF_de_morgan
| provability_OF_godel_dummett
| provability_OF_classical_logic
| provability_OF_classical_logic_peirce
| provability_OF_classical_logic_by_contra
| provability_OF_classical_logic_double_negp
| provability_OF_classical_logic_canalysis
| provability_OF_classical_logic_EM
| provability_OF_classical_logic_impp_orp
| provability_OF_coq_prop
| provability_OF_coq_prop_impp
| provability_OF_sepcon_rule
| provability_OF_wand_rule
| provability_OF_emp_rule
| provability_OF_iter_sepcon
| provability_OF_sepcon_orp_rule
| provability_OF_sepcon_falsep_rule
| provability_OF_sepcon_coq_prop
| provability_OF_sepcon_rule_AS_weak
| provability_OF_sepcon_rule_AS_weak_iffp
| provability_OF_sepcon_rule_AS_mono
| provability_OF_emp_rule_AS_iffp
| provability_OF_garbage_collected_sl
| derivitive_OF_basic_setting
| derivitive_OF_finite_derivation
| derivitive_OF_impp
| derivitive_OF_andp
| derivitive_OF_orp
| derivitive_OF_falsep
| derivitive_OF_truep
| derivitive_OF_iffp
| derivitive_OF_negp
| derivitive_OF_de_morgan
| derivitive_OF_godel_dummett
| derivitive_OF_classical_logic
| derivitive1_OF_basic_setting
| derivitive1_OF_impp_andp_adjoint
| derivitive1_OF_andp
| derivitive1_OF_orp
| derivitive1_OF_falsep
| derivitive1_OF_truep
| derivitive1_OF_iffp
| derivitive1_OF_negp
| derivitive1_OF_impp_negp
| derivitive1_OF_sepcon
| derivitive1_OF_wand
| derivitive1_OF_emp
| derivitive1_OF_sepcon_orp_rule
| derivitive1_OF_sepcon_falsep_rule
| equivalence_OF_basic_setting
| equivalence_OF_impp
| corability_OF_basic_setting
| corability_OF_coq_prop
| GEN_iffp_FROM_andp_impp
| GEN_truep_FROM_falsep_impp
| GEN_negp_FROM_falsep_impp
| GEN_orp_FROM_impp_negp
| GEN_truep_FROM_impp_self
| GEN_truep_FROM_negp_falsep
| GEN_falsep_FROM_negp_truep
| GEN_iter_andp_FROM_fold_left_andp
| GEN_iter_andp_FROM_fold_right_andp
| GEN_iter_sepcon_FROM_fold_left_sepcon
| GEN_iter_sepcon_FROM_fold_right_sepcon
| GEN_derivable_FROM_provable
| GEN_provable_FROM_derivable
| GEN_derivable1_FROM_provable
| GEN_logic_equiv_FROM_provable
| GEN_logic_equiv_FROM_derivable1
.

(** * What users need not to know **)
(** ** Parameters *)

Inductive how_type :=
| primitive_type (t: type)
| FROM_predicate_over_states_TO_expr
| FROM_mpredicate_over_states_TO_expr
| FROM_ensemble_expr_TO_context
.

Notation "'ht_restriction'" := (list how_type).

Inductive type_class :=
| Language
.

Inductive connective_class :=
| MinimumLanguage
| AndLanguage
| OrLanguage
| FalseLanguage
| TrueLanguage
| IffLanguage
| NegLanguage
| CoqPropLanguage
| SepconLanguage
| WandLanguage
| EmpLanguage
| IterAndLanguage
| IterSepconLanguage
.

Inductive judgement_class :=
| Provable
| Derivable
| Derivable1
| LogicEquiv
| Corable
.

Inductive any_class :=
| TC (tc: type_class)
| CC (cc: connective_class)
| JC (jc: judgement_class)
| RC (rc: rule_class)
.

Definition how_instance: Type := nat.

Definition primary_rule: Type := nat.

Definition derived_rule: Type := nat.

(** ** Output *)

Module Output.
Record output: Type := {
  primitive_types: list type;
  transparent_types: list type;
  derived_types: list how_type;
  primitive_connectives: list connective;
  transparent_connectives: list connective;
  derived_connectives: list how_connective;
  primitive_judgements: list judgement;
  transparent_judgements: list judgement;
  derived_judgements: list how_judgement;
  primitive_classes: list any_class;
  refl_classes_for_derivation: list any_class;
  how_derive_classes: list how_instance;
  primary_rules: list primary_rule;
  derived_primary_rules: list primary_rule;
  derived_derived_rules: list derived_rule;
  derived_rules_as_instance: list derived_rule
}.
End Output.

(** ** Auxiliary functions *)

Definition force_val_list {T: Type} (ol: option (list T)): list T :=
  match ol with
  | Some l => l
  | None => nil
  end.

Definition is_Some {T: Type} (o: option T): bool :=
  match o with
  | Some _ => true
  | _ => false
  end.

Definition is_nil {T: Type} (l: list T): bool :=
  match l with
  | nil => true
  | _ => false
  end.

Fixpoint valid_sublist {T: Type} (ol: list (option T)): list T :=
  match ol with
  | nil => nil
  | (Some x) :: ol0 => x :: valid_sublist ol0
  | None :: ol0 => valid_sublist ol0
  end.

(* TODO Check Standard Library *)
Module Type DecTypeSig.

  Parameter Inline t: Type.

  Parameter eqb: t -> t -> bool.

  Axiom eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).

End DecTypeSig.

Module ListFunOverDecType (DTS: DecTypeSig).
Import DTS.

Definition shrink (l: list t): list t :=
  fold_right (fun x l => if (existsb (eqb x) l) then l else x :: l) [] l.

Definition set_minus (l1 l2: list t): list t :=
  filter (fun x => negb (existsb (eqb x) l2)) l1.

Definition set_minus1 (l: list t) (x: t): list t :=
  filter (fun x0 => negb (eqb x0 x)) l.

Definition test_element (x: t) (l: list t): bool :=
  existsb (eqb x) l.

Fixpoint test_no_dup (l: list t): bool :=
  match l with
  | nil => true
  | x :: l0 => negb (test_element x l0) && test_no_dup l0
  end.

Definition test_sublist (l1 l2: list t): bool :=
  forallb (fun x => test_element x l2) l1.

Fixpoint inv_with_hint {A: Type} (f: A -> t) (hint: list A) (x: t): option A :=
  match hint with
  | nil => None
  | a :: hint0 => if eqb x (f a) then Some a else inv_with_hint f hint0 x
  end.

Definition map_inv_with_hint {A: Type}
           (f: A -> t) (hint: list A) (l: list t): list A :=
  valid_sublist (map (inv_with_hint f hint) l).

Fixpoint inj_with_hint {A: Type} (l1: list t) (l2: list A) (x: t) :=
  match l1, l2 with
  | cons a l1', cons v l2' =>
    if eqb a x then Some v else inj_with_hint l1' l2' x
  | _, _ => None
  end.

Definition map_with_hint {A: Type} (l1: list t) (l2: list A) (l: list t) :=
  valid_sublist (map (inj_with_hint l1 l2) l).

Section topo_sort.

Fixpoint pick_one {A: Type} (cur: list (list t * t * A)): option (t * A) :=
  match cur with
  | nil => None
  | (nil, x, a) :: _ => Some (x, a)
  | _ :: cur0 => pick_one cur0
  end.

Definition reduce_one {A: Type}
           (cur: list (list t * t * A)) (x: t): list (list t * t * A) :=
  filter
    (fun d => negb (eqb x (snd (fst d))))
    (map (fun d => (set_minus1 (fst (fst d)) x, snd (fst d), snd d)) cur).

Fixpoint topo_sort_rec {A: Type}
         (cur: list (list t * t * A)) (res: list A) (n: nat): list A :=
  match n with
  | O => res
  | S n0 => let ox := pick_one cur in
            match ox with
            | None => res
            | Some (x, a) => let cur0 := reduce_one cur x in
                             topo_sort_rec cur0 (a :: res) n0
            end
  end.

Definition topo_sort {A: Type} (diag: list (list t * t * A)) :=
  let res := topo_sort_rec diag nil (length diag) in
  rev res.

End topo_sort.

End ListFunOverDecType.

Module CType <: DecTypeSig.

Definition t := type.

Definition eqb (t1 t2: type) :=
  match t1, t2 with
  | expr, expr => true
  | context, context => true
  | prog_state, prog_state => true
  | _, _ => false
  end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End CType.

Module CTypeList := ListFunOverDecType CType.

Module HowType <: DecTypeSig.

Definition t := how_type.

Definition eqb (ht1 ht2: how_type) :=
  match ht1, ht2 with
  | primitive_type t1, primitive_type t2 => CType.eqb t1 t2
  | FROM_predicate_over_states_TO_expr, FROM_predicate_over_states_TO_expr => true
  | FROM_mpredicate_over_states_TO_expr, FROM_mpredicate_over_states_TO_expr => true
  | FROM_ensemble_expr_TO_context, FROM_ensemble_expr_TO_context => true
  | _, _ => false
  end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
  pose proof CType.eqb_spec t0 t1.
  destruct (CType.eqb t0 t1).
  + inversion H; constructor.
    subst; auto.
  + inversion H; constructor.
    congruence.
Qed.

End HowType.

Module HowTypeList := ListFunOverDecType HowType.

Module Connective <: DecTypeSig.

Definition t := connective.

Definition eqb (c1 c2: connective) :=
match c1, c2 with
| impp, impp
| andp, andp
| orp, orp
| falsep, falsep
| truep, truep
| negp, negp
| iffp, iffp
| coq_prop, coq_prop
| sepcon, sepcon
| wand, wand
| emp, emp
| multi_imp, multi_imp
| iter_andp, iter_andp
| iter_sepcon, iter_sepcon
| empty_context, empty_context => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End Connective.

Module ConnectiveList := ListFunOverDecType Connective.

Module Judgement <: DecTypeSig.

Definition t := judgement.

Definition eqb (j1 j2: judgement) :=
match j1, j2 with
| provable, provable
| derivable, derivable
| derivable1, derivable1
| logic_equiv, logic_equiv
| corable, corable => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End Judgement.

Module JudgementList := ListFunOverDecType Judgement.

Module CTypeClass.

Definition t := type_class.

Definition eqb (tc1 tc2: type_class) :=
match tc1, tc2 with
| Language, Language => true
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End CTypeClass.

Module CTypeClassList := ListFunOverDecType CTypeClass.

Module ConnectiveClass.

Definition t := connective_class.

Definition eqb (cc1 cc2: connective_class) :=
match cc1, cc2 with
| MinimumLanguage, MinimumLanguage
| AndLanguage, AndLanguage
| OrLanguage, OrLanguage
| FalseLanguage, FalseLanguage
| TrueLanguage, TrueLanguage
| IffLanguage, IffLanguage
| NegLanguage, NegLanguage
| CoqPropLanguage, CoqPropLanguage
| SepconLanguage, SepconLanguage
| WandLanguage, WandLanguage
| EmpLanguage, EmpLanguage
| IterAndLanguage, IterAndLanguage
| IterSepconLanguage, IterSepconLanguage => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End ConnectiveClass.

Module ConnectiveClassList := ListFunOverDecType ConnectiveClass.

Module JudgementClass.

Definition t := judgement_class.

Definition eqb (jc1 jc2: judgement_class) :=
match jc1, jc2 with
| Provable, Provable
| Derivable, Derivable
| Derivable1, Derivable1
| LogicEquiv, LogicEquiv
| Corable, Corable => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End JudgementClass.

Module JudgementClassList := ListFunOverDecType JudgementClass.

Module RuleClass.

Definition t := rule_class.

Definition eqb (rc1 rc2: rule_class) :=
match rc1, rc2 with
| provability_OF_impp, provability_OF_impp
| provability_OF_andp, provability_OF_andp
| provability_OF_orp, provability_OF_orp
| provability_OF_falsep, provability_OF_falsep
| provability_OF_truep, provability_OF_truep
| provability_OF_iffp, provability_OF_iffp
| provability_OF_negp, provability_OF_negp
| provability_OF_iter_andp, provability_OF_iter_andp
| provability_OF_de_morgan, provability_OF_de_morgan
| provability_OF_godel_dummett, provability_OF_godel_dummett
| provability_OF_classical_logic, provability_OF_classical_logic
| provability_OF_classical_logic_peirce, provability_OF_classical_logic_peirce
| provability_OF_classical_logic_by_contra, provability_OF_classical_logic_by_contra
| provability_OF_classical_logic_double_negp, provability_OF_classical_logic_double_negp
| provability_OF_classical_logic_canalysis, provability_OF_classical_logic_canalysis
| provability_OF_classical_logic_EM, provability_OF_classical_logic_EM
| provability_OF_classical_logic_impp_orp, provability_OF_classical_logic_impp_orp
| provability_OF_coq_prop, provability_OF_coq_prop
| provability_OF_coq_prop_impp, provability_OF_coq_prop_impp
| provability_OF_sepcon_rule, provability_OF_sepcon_rule
| provability_OF_wand_rule, provability_OF_wand_rule
| provability_OF_emp_rule, provability_OF_emp_rule
| provability_OF_iter_sepcon, provability_OF_iter_sepcon => true
| provability_OF_sepcon_orp_rule, provability_OF_sepcon_orp_rule => true
| provability_OF_sepcon_falsep_rule, provability_OF_sepcon_falsep_rule => true
| provability_OF_sepcon_coq_prop, provability_OF_sepcon_coq_prop => true
| provability_OF_sepcon_rule_AS_weak, provability_OF_sepcon_rule_AS_weak => true
| provability_OF_sepcon_rule_AS_weak_iffp, provability_OF_sepcon_rule_AS_weak_iffp => true
| provability_OF_sepcon_rule_AS_mono, provability_OF_sepcon_rule_AS_mono => true
| provability_OF_emp_rule_AS_iffp, provability_OF_emp_rule_AS_iffp => true
| provability_OF_garbage_collected_sl, provability_OF_garbage_collected_sl => true
| derivitive_OF_basic_setting, derivitive_OF_basic_setting
| derivitive_OF_finite_derivation, derivitive_OF_finite_derivation
| derivitive_OF_impp, derivitive_OF_impp
| derivitive_OF_andp, derivitive_OF_andp
| derivitive_OF_orp, derivitive_OF_orp
| derivitive_OF_falsep, derivitive_OF_falsep
| derivitive_OF_truep, derivitive_OF_truep
| derivitive_OF_iffp, derivitive_OF_iffp
| derivitive_OF_negp, derivitive_OF_negp
| derivitive_OF_de_morgan, derivitive_OF_de_morgan
| derivitive_OF_godel_dummett, derivitive_OF_godel_dummett
| derivitive_OF_classical_logic, derivitive_OF_classical_logic
| derivitive1_OF_basic_setting, derivitive1_OF_basic_setting
| derivitive1_OF_impp_andp_adjoint, derivitive1_OF_impp_andp_adjoint
| derivitive1_OF_andp, derivitive1_OF_andp
| derivitive1_OF_orp, derivitive1_OF_orp
| derivitive1_OF_falsep, derivitive1_OF_falsep
| derivitive1_OF_truep, derivitive1_OF_truep
| derivitive1_OF_iffp, derivitive1_OF_iffp
| derivitive1_OF_negp, derivitive1_OF_negp
| derivitive1_OF_impp_negp, derivitive1_OF_impp_negp
| derivitive1_OF_sepcon, derivitive1_OF_sepcon
| derivitive1_OF_wand, derivitive1_OF_wand
| derivitive1_OF_emp, derivitive1_OF_emp
| derivitive1_OF_sepcon_orp_rule, derivitive1_OF_sepcon_orp_rule
| derivitive1_OF_sepcon_falsep_rule, derivitive1_OF_sepcon_falsep_rule
| equivalence_OF_basic_setting, equivalence_OF_basic_setting
| equivalence_OF_impp, equivalence_OF_impp
| corability_OF_basic_setting, corability_OF_basic_setting
| corability_OF_coq_prop, corability_OF_coq_prop
| GEN_iffp_FROM_andp_impp, GEN_iffp_FROM_andp_impp
| GEN_truep_FROM_falsep_impp, GEN_truep_FROM_falsep_impp
| GEN_negp_FROM_falsep_impp, GEN_negp_FROM_falsep_impp
| GEN_orp_FROM_impp_negp, GEN_orp_FROM_impp_negp
| GEN_truep_FROM_impp_self, GEN_truep_FROM_impp_self
| GEN_truep_FROM_negp_falsep, GEN_truep_FROM_negp_falsep
| GEN_falsep_FROM_negp_truep, GEN_falsep_FROM_negp_truep
| GEN_iter_andp_FROM_fold_left_andp, GEN_iter_andp_FROM_fold_left_andp
| GEN_iter_andp_FROM_fold_right_andp, GEN_iter_andp_FROM_fold_right_andp
| GEN_iter_sepcon_FROM_fold_left_sepcon, GEN_iter_sepcon_FROM_fold_left_sepcon
| GEN_iter_sepcon_FROM_fold_right_sepcon, GEN_iter_sepcon_FROM_fold_right_sepcon
| GEN_derivable_FROM_provable, GEN_derivable_FROM_provable
| GEN_provable_FROM_derivable, GEN_provable_FROM_derivable
| GEN_derivable1_FROM_provable, GEN_derivable1_FROM_provable
| GEN_logic_equiv_FROM_provable, GEN_logic_equiv_FROM_provable
| GEN_logic_equiv_FROM_derivable1, GEN_logic_equiv_FROM_derivable1 => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End RuleClass.

Module RuleClassList := ListFunOverDecType RuleClass.

Module AllClass.

Definition t := any_class.

Definition eqb (ac1 ac2: any_class) :=
match ac1, ac2 with
| TC tc1, TC tc2 => CTypeClass.eqb tc1 tc2
| CC cc1, CC cc2 => ConnectiveClass.eqb cc1 cc2
| JC jc1, JC jc2 => JudgementClass.eqb jc1 jc2
| RC rc1, RC rc2 => RuleClass.eqb rc1 rc2
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
  + pose proof CTypeClass.eqb_spec tc tc0.
    destruct (CTypeClass.eqb tc tc0); inversion H; constructor; congruence.
  + pose proof ConnectiveClass.eqb_spec cc cc0.
    destruct (ConnectiveClass.eqb cc cc0); inversion H; constructor; congruence.
  + pose proof JudgementClass.eqb_spec jc jc0.
    destruct (JudgementClass.eqb jc jc0); inversion H; constructor; congruence.
  + pose proof RuleClass.eqb_spec rc rc0.
    destruct (RuleClass.eqb rc rc0); inversion H; constructor; congruence.
Qed.

End AllClass.

Module AllClassList := ListFunOverDecType AllClass.

Module NatList := ListFunOverDecType PeanoNat.Nat.


(***************************************************************************
* Safety for STLC with References - Definitions                            *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(* ********************************************************************** *)

(** Grammar of types. *)

Parameter atm : Set.

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_ref   : typ -> typ
  | typ_unit  : typ.

(** Grammar of pre-terms. *)

Definition loc := var.

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_unit : trm
  | trm_loc : loc -> trm
  | trm_ref : trm -> trm
  | trm_get : trm -> trm
  | trm_set : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_unit          => trm_unit
  | trm_loc l     => trm_loc l
  | trm_ref t1    => trm_ref (open_rec k u t1)
  | trm_get t1    => trm_get (open_rec k u t1)
  | trm_set t1 t2 => trm_set (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_trm_unit :
      term trm_unit
  | term_loc : forall l,
      term (trm_loc l)
  | term_new : forall t1,
      term t1 ->
      term (trm_ref t1)
  | term_get : forall t1,
      term t1 ->
      term (trm_get t1)
  | term_set : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_set t1 t2).

(** Store maps (sto) locations to values, and
    Store typing (phi) maps locations to type. *)

Definition sto := LibEnv.env trm.
Definition phi := LibEnv.env typ.

Inductive sto_ok : sto -> Prop :=
  | sto_ok_empty : sto_ok empty
  | sto_ok_push : forall mu l t,
      sto_ok mu -> term t ->
      sto_ok (mu & l ~ t).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(* ********************************************************************** *)

(** Typing relation *)

Reserved Notation "E ! P |= t ~: T" (at level 69).

Inductive typing : env -> phi -> trm -> typ -> Prop :=
  | typing_var : forall E P x T,
      ok E ->
      binds x T E ->
      E ! P |= (trm_fvar x) ~: T
  | typing_abs : forall L E P U T t1,
      (forall x, x \notin L -> (E & x ~ U) ! P  |= t1 ^ x ~: T) ->
      E ! P |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E P t1 t2,
      E ! P |= t1 ~: (typ_arrow S T) -> E ! P  |= t2 ~: S ->
      E ! P  |= (trm_app t1 t2) ~: T
  | typing_trm_unit : forall E P,
      ok E ->
      E ! P |= trm_unit ~: typ_unit
  | typing_loc : forall E P l T,
      ok E ->
      binds l T P ->
      E ! P |= (trm_loc l) ~: (typ_ref T)
  | typing_new : forall E P t1 T,
      E ! P |= t1 ~: T ->
      E ! P |= (trm_ref t1) ~: (typ_ref T)
  | typing_get : forall E P t1 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= (trm_get t1) ~: T
  | typing_set : forall E P t1 t2 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= t2 ~: T ->
      E ! P |= (trm_set t1 t2) ~: typ_unit

where "E ! P |= t ~: T" := (typing E P t T).

(** Typing store *)

Definition sto_typing P mu :=
     sto_ok mu
  /\ (forall l, l # mu -> l # P)
  /\ (forall l T, binds l T P ->
        exists t, binds l t mu
               /\ empty ! P |= t ~: T).

Notation "P |== mu" := (sto_typing P mu) (at level 68).

(** Definition of values *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) ->
      value (trm_abs t1)
  | value_trm_unit :
      value trm_unit
  | value_loc : forall l,
      value (trm_loc l).

(** Reduction relation - one step in call-by-value *)

Definition conf := (trm * sto)%type.

Inductive red : conf -> conf -> Prop :=

  | red_beta : forall mu t1 t2,
      sto_ok mu ->
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2, mu) (t1 ^^ t2, mu)
  | red_new : forall mu t1 l,
      sto_ok mu ->
      value t1 ->
      l # mu ->
      red (trm_ref t1, mu) (trm_loc l, (mu & l ~ t1))
  | red_get : forall mu l t,
      sto_ok mu ->
      binds l t mu ->
      red (trm_get (trm_loc l), mu) (t, mu)
  | red_set : forall mu l t2,
      sto_ok mu ->
      value t2 ->
      red (trm_set (trm_loc l) t2, mu) (trm_unit, mu & l ~ t2)

  | red_app_1 : forall mu mu' t1 t1' t2,
      term t2 ->
      red (t1, mu) (t1', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1' t2, mu')
  | red_app_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1 t2', mu')
  | red_new_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_ref t1, mu) (trm_ref t1', mu')
  | red_get_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_get t1, mu) (trm_get t1', mu')
  | red_set_1 : forall mu mu' t1 t1' t2,
      red (t1, mu) (t1', mu') ->
      term t2 ->
      red (trm_set t1 t2, mu) (trm_set t1' t2, mu')
  | red_set_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_set t1 t2, mu) (trm_set t1 t2', mu').

Notation "c --> c'" := (red c c') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall P t t' mu mu' T,
  empty ! P |= t ~: T ->
  (t,mu) --> (t',mu') ->
  P |== mu ->
  exists P',
     extends P P'
  /\ empty ! P' |= t' ~: T
  /\ P' |== mu'.

Definition progress := forall P t mu T,
  empty ! P |= t ~: T ->
  P |== mu ->
     value t
  \/ exists t', exists mu', (t,mu) --> (t',mu').


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Properties involving series and integrals *)
Require Import Reals.
Require Import Rseries_def.
Require Import Rseries_facts.
Require Import RiemannInt.
Require Import Lra.
Require Import Rsequence_facts.
Require Import Rsequence_subsequence.
Require Import Riemann_integrable.
Require Import Rintegral.

Local Open Scope R_scope.
(** printing ~	~ *)
Section Rseries_RiemannInt.

Local Coercion INR : nat >-> R.

(* begin hide *)
Lemma Rle_minus' : forall a b, b <= a -> 0 <= a - b. intros; lra. Qed.
Lemma Rminus_le_compat_r: forall r r1 r2 : R, r2 <= r1 -> r - r1 <= r - r2. intros; lra. Qed.
(* end hide *)

Lemma Telescoping_series : forall a n, sum_f_R0 (fun i => a (S i) - a i) n = a (S n) - a O.
Proof.
intros a n.
rewrite tech11 with (fun i => a (S i) - a i) (fun i => a (S i)) a _; [|reflexivity].
destruct n; [reflexivity|].
rewrite tech2 with a O (S n); [|intuition].
rewrite tech5.
simpl (sum_f_R0 a 0).
replace (S n - 1)%nat with n by (simpl; apply minus_n_O).
assert (REW : forall S S' A B, S = S' -> S + A - (B + S') = A - B) by (intros; subst; ring).
apply REW.
reflexivity.
Qed.

Lemma Telescoping_series_opp : forall a n, sum_f_R0 (fun i => a i - a (S i)) n = a O - a (S n).
Proof.
intros a n.
rewrite tech11 with (fun i => a i - a (S i)) a (fun i => a (S i)) _; [|reflexivity].
destruct n; [reflexivity|].
rewrite tech2 with a O (S n); [|intuition].
rewrite tech5.
simpl (sum_f_R0 a 0).
replace (S n - 1)%nat with n by (simpl; apply minus_n_O).
assert (REW : forall S S' A B, S = S' -> A + S - (S' + B) = A - B) by (intros; subst; ring).
apply REW.
reflexivity.
Qed.

(** * Generalized Chasles relation *)
Lemma Rint_generalized_Chasles : forall f An,
  (forall n : nat, Rint f n (S n) (An n)) ->
    forall n : nat, Rint f 0 (S n) (sum_f_R0 An n).
Proof.
intros f An H.
induction n.
  apply (H O).
apply Rint_Chasles with (S n).
  apply IHn.
apply H.
Qed.

Section Rser_RiemannInt_link.

Variable f : R -> R.
Hypothesis Hcont : forall x, 0 <= x -> continuity_pt f x.
Hypothesis Hpos : forall x, 0 <= x -> 0 <= f x.
Hypothesis Hdec : forall x y : R, 0 <= x <= y -> f y <= f x.

Lemma Riemann_integrable_f_n_Sn : forall (n : nat), Riemann_integrable f (INR n) (INR (S n)).
Proof.
intro n.
apply continuity_implies_RiemannInt.
  apply le_INR; do 2 constructor.
intros x [Hnx HxSn]; apply Hcont.
apply (Rle_trans 0 (INR n) x (le_INR _ _ (le_O_n n)) Hnx).
Qed.

Lemma Rser_RiemannInt_link_general_term_integrable : forall (n : nat),
  Riemann_integrable (fun x => fct_cte (f (INR n)) x - f x) (INR n) (INR (S n)).
Proof.
intros n.
apply RiemannInt_integrable_minus.
 apply RiemannInt_P6.
  auto with *.
  intros x Hx.
  apply continuity_const.
  intros y z; reflexivity.

  apply (Riemann_integrable_f_n_Sn n).
Qed.

Lemma Rser_RiemannInt_link_general_term_bound (n : nat) :
  RiemannInt (Rser_RiemannInt_link_general_term_integrable n) <= f (INR n) - f (INR (S n)).
Proof.
intros.
rewrite <- Rmult_1_r.
replace 1 with (INR (S n) - (INR n)).
 assert (pr:Riemann_integrable (fct_cte (f (INR n) - f (INR (S n)))) (INR n) (INR (S n))) by apply RiemannInt_P14.
 rewrite <- RiemannInt_P15 with _ _ _ pr.
 apply RiemannInt_P19; [intuition|].
 unfold fct_cte.
 intros x [xn xsn].
 apply Rminus_le_compat_r.
 apply Hdec.
 split.
 apply Rle_trans with (INR n).
 auto with *.
 left; apply xn.
 apply (Rlt_le _ _ xsn).

 rewrite <- minus_INR by intuition.
 replace (S n - n)%nat with 1%nat by intuition.
 reflexivity.
Qed.

(**  * Link between series and integral *)
Lemma Rser_RiemannInt_link : { l | Rser_cv (fun n => f (INR n) - RiemannInt (Riemann_integrable_f_n_Sn n) ) l}.
Proof.
apply Rser_pos_bound_cv with (f 0).
 intro n.
 destruct (Rint_constant (f n) n (S n)) as [ pr int].
 replace (f n * (S n -n)) with (f n) in int by (rewrite S_INR; ring).
 rewrite <- int.
 apply Rle_minus'.
 apply RiemannInt_P19; [intuition|].
 intros x [xn snx].
 assert(Hcond : 0 <= (INR n) <= x).
   split.
     auto with *.

     left; apply xn.
   apply (Hdec _ _ Hcond).

 intro n.
 apply Rle_trans with (sum_f_R0 (fun n => f (INR n) - f (INR (S n))) n).
 apply sum_Rle.
  intros i ni.
  destruct (Rint_constant (f i) i (S i)) as [ pr int].
   replace (f i * (S i -i)) with (f i) in int by (rewrite S_INR; ring).
  rewrite <- int.
  rewrite <- RiemannInt_minus with _ _ _ _ _ _ (Rser_RiemannInt_link_general_term_integrable i); [|intuition].
  rewrite RiemannInt_P15.
  replace (INR (S i) - INR i) with 1.
   rewrite Rmult_1_r.
   apply (Rser_RiemannInt_link_general_term_bound i).

   rewrite <- minus_INR by intuition.
   replace (S i - i)%nat with 1%nat by intuition.
   reflexivity.

  rewrite Telescoping_series_opp.
  rewrite <- Rminus_0_r.
  apply Rminus_le_compat_r.
  apply Hpos.
auto with *.
Qed.

Lemma Rser_RiemannInt_cv_pos_infty :
    exists pr : forall (n : nat), Riemann_integrable f 0 (INR n),
    Rseq_cv_pos_infty (fun n => RiemannInt (pr (S n))) ->
        (sum_f_R0 (fun n => f (INR n))) ~ (fun n => RiemannInt (pr (S n))).
Proof.
assert (pr : forall n : nat, Riemann_integrable f 0 n).
  intro n.
  apply continuity_implies_RiemannInt.
  intuition.
  intros x [Hx _]; apply (Hcont x Hx).
exists pr.
intro Hdiv.
destruct Rser_RiemannInt_link as [ l Hl].
apply Rseq_equiv_sym.
unfold Rseq_equiv, Rseq_minus.
apply Rseq_cv_little_O_cv_pos_infty with (-l).
  apply Rseq_cv_eq_compat with
      (sum_f_R0 (fun n : nat =>- (f (INR n) - RiemannInt (Riemann_integrable_f_n_Sn n)))).
    intro n.
    destruct (Rint_generalized_Chasles f
                  (fun n =>RiemannInt (Riemann_integrable_f_n_Sn n))
                  (fun n => Rint_RiemannInt_link f n (S n) (Riemann_integrable_f_n_Sn n)) n) as [prn H].
    rewrite RiemannInt_P5 with _ _ _ (pr (S n)) prn.
    rewrite H.
    rewrite <- minus_sum.
    apply sum_eq; intros p Hp.
    unfold Rminus.
    ring.
  unfold Rser_cv in Hl.
  apply Rser_cv_opp_compat; apply Hl.
apply Hdiv.
Qed.

End Rser_RiemannInt_link.

Section Applications.

Definition ln1 := comp ln (fun x => x+1).

Lemma Rint_inv1 : forall a b,
  -1 < a <= b -> Rint (/(id + fct_cte 1))%F a b (ln (b + 1) - ln (a + 1)).
Proof.
intros a b Hab.
replace (ln (b + 1)) with (comp ln (id + fct_cte 1) b) by reflexivity.
replace (ln (a + 1)) with (comp ln (id + fct_cte 1) a) by reflexivity.
apply Rint_derive.
intuition.
intros x Hx.
  replace ((/ (id + fct_cte 1))%F x) with ((/ (id + fct_cte 1))%F x * (1+0)) by ring.
  apply derivable_pt_lim_comp.
    apply derivable_pt_lim_plus.
      apply derivable_pt_lim_id.
      apply derivable_pt_lim_const.
      apply derivable_pt_lim_ln.

     unfold plus_fct, fct_cte, id.
     intuition.
     apply Rlt_le_trans with (a + 1); lra.
  intros x Hx.
  apply continuity_pt_inv.
  apply continuity_pt_plus.
  apply derivable_continuous, derivable_id.
  apply continuity_pt_const.
  unfold fct_cte; intros u v; reflexivity.
  unfold fct_cte, id, plus_fct.
  assert(0 < x + 1).
  apply Rlt_le_trans with (a + 1).
  replace 0 with (- 1 + 1) by ring.
  apply Rplus_lt_compat_r; intuition.
  apply Rplus_le_compat_r; intuition.
auto with *.
Qed.

(** Equivalent of the harmonic series *)
Lemma harmonic_series_equiv : (sum_f_R0 (fun n => / (S n))) ~ (fun n => ln (S (S n))).
Proof.
destruct (Rser_RiemannInt_cv_pos_infty (/(id + fct_cte 1))%F) as [int_f_0_n Hi];
unfold plus_fct, fct_cte, id, inv_fct.
  intros x Hx.
    apply continuity_pt_inv.
    apply (continuity_pt_plus _ _ _
      (derivable_continuous id derivable_id x)
      (derivable_continuous _ (derivable_const 1) x)).
    auto with *.

  auto with *.

  intros x y [Hxpos Hxy].
  apply Rle_Rinv; lra.
  assert (Heq2 : (fun n : nat => ln (INR (S (S n)))) ==
          (fun n : nat => RiemannInt (int_f_0_n (S n)))).
    intro n.
    replace (ln (S (S n))) with ((ln (S n + 1)%R - ln (O + 1))).
    destruct (Rint_inv1 0%nat (S n)) as [Hint Heq].
    change (INR O) with 0.
    auto with *.
    rewrite <- Heq.
    apply RiemannInt_P18.
    auto with *.
    reflexivity.
    replace (INR (S n) + 1) with (INR (S (S n))) by trivial.
    replace (INR 0 + 1) with 1 by (simpl; ring).
    rewrite ln_1.
    ring.
  assert(Rseq_cv_pos_infty (fun n : nat => RiemannInt (int_f_0_n (S n)))) as Hdiv.
    apply Rseq_cv_pos_infty_eq_compat with (fun n : nat => ln (S (S n))).
    apply Heq2.
    apply Rseq_subseq_cv_pos_infty_compat with (fun n => ln n).
    assert (Hex : is_extractor (fun n => (S (S n)))).
      constructor.
    exists (exist _ _ Hex).
    trivial.
  apply Rseq_ln_cv.
  assert(Heq1 : (sum_f_R0 (fun n : nat => (/ (id + fct_cte 1))%F (INR n))) ==
                 (sum_f_R0 (fun n : nat => / INR (S n)))).
    intro n; apply sum_eq; intros k Hk.

    unfold inv_fct, id, plus_fct, fct_cte.
    rewrite S_INR.
    reflexivity.
    apply Rseq_eq_sym in Heq2.
  apply (Rseq_equiv_eq_compat
  _ _ _ _  Heq1 Heq2 (Hi Hdiv)).
Qed.

End Applications.

End Rseries_RiemannInt.


(** A Rupicola version of the indirect_add example in Bedrock2. **)
Require Import Rupicola.Lib.Api.
Require Import Rupicola.Examples.Cells.Cells.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {wordok : word.ok word} {mapok : map.ok mem}.
  Context {localsok : map.ok locals}.
  Context {envok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Local Notation cell := (@cell width BW word).

  Definition indirect_add (b c: cell) :=
    let/n vb := get b in
    let/n vc := get c in
    let/n r := word.add vb vc in
    let/n a := put r in
    a.

  Instance spec_of_indirect_add : spec_of "indirect_add" :=
    fnspec! "indirect_add" pa pb pc / a Ra b Rb c Rc,
    { requires t m :=
        (cell_value pa a ⋆ Ra &&&
         cell_value pb b ⋆ Rb &&&
         cell_value pc c ⋆ Rc) m;
      ensures t' m' :=
        t = t' /\
        (cell_value pa (indirect_add b c) ⋆ Ra) m' }.

  Derive indirect_add_br2fn SuchThat
         (defn! "indirect_add"("a", "b", "c") { indirect_add_br2fn },
          implements indirect_add)
         As indirect_add_br2fn_ok.
  Proof.
    compile.
  Qed.

  (* FIXME auto-generate lemma from pre-post condition pair? *)

  Lemma compile_indirect_add : forall {tr mem locals functions} a b c,
    let v := indirect_add b c in
    forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl}
      a_var b_expr c_expr pa pb pc Ra Rb Rc,

      map.get locals a_var = Some pa ->
      (cell_value pa a ⋆ Ra) mem ->

      (cell_value pb b ⋆ Rb) mem ->
      WeakestPrecondition.dexpr mem locals b_expr pb ->

      (cell_value pc c ⋆ Rc) mem ->
      WeakestPrecondition.dexpr mem locals c_expr pc ->

      (_: spec_of "indirect_add") functions ->

      (let v := v in
       forall m,
         sep (cell_value pa v) Ra m ->
         (<{ Trace := tr;
             Memory := m;
             Locals := locals;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.call [] "indirect_add" [expr.var a_var; b_expr; c_expr])
              k_impl
      <{ pred (nlet_eq [a_var] v k) }>.
  Proof.
    unfold unsep.
    repeat straightline.
    repeat (eexists; split; eauto).
    simpl; repeat (eapply WeakestPrecondition_dexpr_expr; eauto).
    straightline_call; unfold unsep in *; eauto; [].
    intuition subst.
    repeat (eexists; split; eauto).
  Qed.

  Hint Extern 1 => simple eapply compile_indirect_add; shelve : compiler.

  Definition indirect_add_twice (a b: cell) :=
    let/n a := indirect_add a b in
    let/n a := indirect_add a b in
    a.

  Instance spec_of_indirect_add_twice : spec_of "indirect_add_twice" :=
    fnspec! "indirect_add_twice" pa pb / a b R,
    { requires t m :=
        (cell_value pa a ⋆ cell_value pb b ⋆ R) m;
      ensures t' m' :=
        t = t' /\ (cell_value pa (indirect_add_twice a b) ⋆ cell_value pb b ⋆ R) m' }.

  Derive indirect_add_twice_br2fn SuchThat
         (defn! "indirect_add_twice"("a", "b") { indirect_add_twice_br2fn },
          implements indirect_add_twice using ["indirect_add"])
         As indirect_add_twice_br2fn_ok.
  Proof.
    compile.
  Qed.

  Definition indirect_add_three (a b c: cell) :=
    let/n a := indirect_add a b in
    let/n a := indirect_add a c in
    a.

  (* Quick sanity check that Rupicola's notations unfold into code that's
     decently nice to work with: *)
  Notation "⟨ v ⟩" := {| data := v |}.
  Goal forall a b c, indirect_add_three ⟨a⟩ ⟨b⟩ ⟨c⟩ = ⟨word.add (word.add a b) c⟩.
    reflexivity.
  Qed.

  Instance spec_of_indirect_add_three : spec_of "indirect_add_three" :=
    fnspec! "indirect_add_three" pa pb pc / a b c Rb R,
    { requires t m :=
        (cell_value pa a ⋆ cell_value pc c ⋆ R &&&
         cell_value pb b ⋆ Rb) m;
      ensures t' m' :=
        t = t' /\
        (cell_value pa (indirect_add_three a b c) ⋆ cell_value pc c ⋆ R) m' }.

  Derive indirect_add_three_br2fn SuchThat
         (defn! "indirect_add_three"("a", "b", "c") { indirect_add_three_br2fn },
          implements indirect_add_three using ["indirect_add"])
         As indirect_add_three_br2fn_ok.
  Proof.
    compile.
  Qed.

  Definition indirect_add_three' (a b c: cell) :=
    let/n v := stack (indirect_add a b) in
    let/n out := indirect_add v c in
    out.

  Instance spec_of_indirect_add_three' : spec_of "indirect_add_three'" :=
    fnspec! "indirect_add_three'" pout pa pb pc / out a b c Ra Rb Rc R,
    { requires t m :=
        (cell_value pout out ⋆ R &&&
         cell_value pa a ⋆ Ra &&&
         cell_value pb b ⋆ Rb &&&
         cell_value pc c ⋆ Rc) m;
      ensures t' m' :=
        t = t' /\
        (cell_value pout (indirect_add_three' a b c) ⋆ R) m' }.

  Derive indirect_add_three'_br2fn SuchThat
         (defn! "indirect_add_three'"("out", "a", "b", "c") { indirect_add_three'_br2fn },
          implements indirect_add_three' using ["indirect_add"])
    As indirect_add_three'_br2fn_ok.
  Proof.
    compile.
  Qed.

  Arguments indirect_add_three'_br2fn /.
  Eval simpl in indirect_add_three'_br2fn.
End with_parameters.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L.Datatypes Require Import LNat LTerm LBool LProd List.List_enc LOptions.

(* ** Extracted encoding of natural numbers *)

#[global]
Instance term_nat_enc : computableTime' (nat_enc) (fun n _ => (n * 14 + 12,tt)).
Proof.
  extract. solverec.
Qed.

(* ** Extracted term encoding *)

#[global]
Instance term_term_enc : computableTime' (term_enc) (fun s _ => (size s * 30,tt)).
Proof.
  extract. solverec.
Qed.

#[global]
Instance bool_enc :computableTime' (@bool_enc) (fun l _ => (12,tt)).
Proof.
  unfold bool_enc. extract. solverec.
Qed.

(* ** Extracted tuple encoding *)

#[global]
Instance term_prod_enc X Y (R1:registered X) (R2:registered Y) t__X t__Y
         `{computableTime' (@enc X _) t__X} `{computableTime' (@enc Y _) t__Y}
  :computableTime' (@prod_enc X Y R1 R2) (fun w _ => (let '(x,y):= w in  fst (t__X x tt) + fst (t__Y y tt) + 15,tt)).
Proof.
  unfold prod_enc.
  change (match R1 with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R1)).
  change (match R2 with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R2)).
  extract. solverec.
Qed.

#[global]
Instance term_list_enc X (R:registered X) t__X
         `{computableTime' (@enc X _) t__X}
  :computableTime' (@list_enc X R) (fun l _ => (sumn (map (fun x => fst (t__X x tt) + 17) l) + 12,tt)).
Proof.
  unfold list_enc.
  change (match R with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R)).
  extract. solverec.
Qed.

Import LOptions.

#[global]
Instance term_option_enc X (R:registered X) t__X
         `{computableTime' (@enc X _) t__X}
  :computableTime' (@option_enc X R) (fun x _ => (match x with Some x => fst (t__X x tt) | _ => 0 end + 15,tt)).
Proof.
  unfold option_enc.
  change (match R with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=R)).
  extract. solverec.
Qed.

(*
Set Printing Implicit.
Check (extT (@enc (nat*(nat*nat)) _)).
*)
(*
Definition prod_enc' {X Y} (enc_x : X -> term) (enc_y : Y -> term) : X * Y -> term :=
  fix f w := let '(x,y) := w in
             lam (var 0 (enc_x x) (enc_y y)).

Lemma enc_prod_eq {X Y} {H__x:registered X} {H__y : registered Y}:
  @enc (X*Y) _ = prod_enc' (@enc _ H__x) (@enc _ H__y).
Proof.
  unfold enc. destruct H__x, H__y. reflexivity.
Qed.

Instance term_prod_enc' {X Y} {H__x : registered X} {H__Y : registered Y}:
  computableTime' (@prod_enc' X Y) (fun _ t__X => (1,fun _ t__Y => (1,fun w _ => (let '(x,y):= w in  fst (t__X x tt) + fst (t__Y y tt) + 15,tt)))).
Proof.
  extract. solverec.
Qed.
*)