Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import Robustdef.
Require Import Criteria.
Require Import ClassicalExtras.
Require Import FunctionalExtensionality.
Require Import Coq.Logic.ClassicalFacts.

(** This file proves the collapses that happens in presence of
    reflection in the source language *)

(*

       RrHP  ---
                 \
        |  ----- RrSCP ---
          /      /         \
       RHP      /          RrTP ---
(<-> RFrSCP)   /           /       \
        |     /---------- /          RrSP
                         /          /
     RSCP (<-> RFrTP)   /          /
                       /          /
        |             /          /
                     /          /
       RTP --------- --        /
                       \      /
      /   \             RHSP (<-> RFrSP)
                       /
    RDP   RSP   -------

*)

Variable code_intro : forall {P1 P2 : par src} (h : P1 <> P2) (Cs1 Cs2 : ctx src), ctx src.

Axiom beh_intro1 : forall P1 P2 (h : P1 <> P2)Cs1 Cs2,
    forall t,
     sem src ((code_intro h Cs1 Cs2) [P1]) t <-> sem src (Cs1 [P1]) t.

Axiom beh_intro2 : forall P1 P2 (h : P1 <> P2) Cs1 Cs2,
    forall t,
    sem src ((code_intro h Cs1 Cs2) [P2]) t = sem src (Cs2 [P2]) t.

(* R2HSP -> r2RSP and a similar argument for k >= 2 *)
Lemma R2HSP_R2rSP : R2HSP -> R2rSP.
Proof.
  rewrite <- R2HSC_R2HSP, <- R2rSC_R2rSP.
  intros H2rsc Ct P1 P2 m1 m2 H1 H2.
  destruct H1 as [t1 [Hpref1 H1]].
  destruct H2 as [t2 [Hpref2 H2]].
  destruct (classic (P1 = P2)) as [Heq | Hneq].
  + rewrite <- Heq in *.
    destruct (H2rsc P1 Ct m1 m2) as [Cs Hspref].
    ++ intros x [Hx | Hx]; [exists t1 | exists t2]; subst; auto.
    ++ exists Cs. split.
       +++ destruct (Hspref m1) as [tt1 Hpref11]; simpl; auto.
           now exists tt1.
       +++ destruct (Hspref m2) as [tt2 Hpref22]; simpl; auto.
           now exists tt2.
  + apply R2HSC_RSC in H2rsc.
    destruct (H2rsc P1 Ct t1 H1 m1 Hpref1) as [Cs1 [t1' [H' H'']]].
    destruct (H2rsc P2 Ct t2 H2 m2 Hpref2) as [Cs2 [t2' [H2' H2'']]].
    exists (code_intro Hneq Cs1 Cs2).
    split; [exists t1' | exists t2'];
      split; auto; [  now rewrite (beh_intro1 P1 P2 Hneq Cs1 Cs2)
                    | now rewrite (beh_intro2 P1 P2 Hneq Cs1 Cs2)].
Qed.

(* RHP -> r2RHP *)

(* as usual we need prop_extensionality *)

Hypothesis prop_ext : prop_extensionality.

Lemma RHP_R2rHP : RHP -> R2rHP.
Proof.
  rewrite <- RHC_RHP, <- R2rHC_R2rHP.
  intros hrc P1 P2 Ct.
  destruct (hrc P1 Ct) as [Cs1 H1].
  destruct (hrc P2 Ct) as [Cs2 H2].
  destruct (classic (P1 = P2)) as [Heq | Hneq].
  + rewrite Heq in *.
    exists Cs1. split; apply functional_extensionality;
             intros t; apply prop_ext; now auto.
  + exists (code_intro Hneq Cs1 Cs2).
    split; apply functional_extensionality; intros t;
      apply prop_ext;
    [ now rewrite beh_intro1 | now rewrite beh_intro2].
Qed.

(* RSCP -> R2rSCP *)

Lemma RSCP_R2rSCP : RSCHP -> R2rSCHP.
Proof.
  rewrite <- R2rSCHC_R2rSCHP, <- RSCHC_RSCHP.
  intros sscr P1 P2 Ct.
  destruct (classic (P1 = P2)) as [Heq | Hneq].
  + rewrite <- Heq in *. destruct (sscr P1 Ct) as [Cs H].
    now exists Cs.
  + destruct (sscr P1 Ct) as [Cs1 H1].
    destruct (sscr P2 Ct) as [Cs2 H2].
    exists (code_intro Hneq Cs1 Cs2).
    split; intros t H; [rewrite beh_intro1; now apply H1
                       | rewrite beh_intro2; now apply H2].
Qed.

Lemma R2rSCP_R2rTP : R2rSCHP -> R2rTP.
Proof.
  rewrite <- R2rSCHC_R2rSCHP, <- R2rTC_R2rTP.
  intros rp Ct P1 P2 t1 t2 H1 H2.
  destruct (rp P1 P2 Ct) as [Cs [HH1 HH2]].
  exists Cs; split; [now apply HH1 | now apply HH2].
Qed.

Theorem RSCHP_R2rTP : RSCHP -> R2rTP.
Proof.
  intros H. now apply R2rSCP_R2rTP; apply RSCP_R2rSCP.
Qed.


Require compcert.backend.Linearizeproof.
Require LinearX.
Require LTLX.

Import Coqlib.
Import Errors.
Import Globalenvs.
Import Events.
Import Smallstep.
Import LTLX.
Import LinearX.
Import Linearize.
Export Linearizeproof.

Section WITHCONFIG.

Context `{external_calls_prf: ExternalCalls}.

Variable prog: LTL.program.
Variable tprog: Linear.program.

Hypothesis TRANSF: transf_program prog = OK tprog.

Let MATCH_PROG: match_prog prog tprog.
Proof.
  apply transf_program_match.
  assumption.
Qed.

Lemma transf_initial_states:
  forall init_ls i sg args m,
  forall st1, LTLX.initial_state init_ls prog i sg args m st1 ->
         exists st2, LinearX.initial_state init_ls tprog i sg args m st2 /\ match_states st1 st2.
Proof.
  intros. inv H.
  exploit function_ptr_translated; eauto.
  destruct 1 as [? [? ?]].
  econstructor; split.
  econstructor; eauto.
  erewrite symbols_preserved; eauto.
  subst. symmetry; eauto using sig_preserved.
  constructor; auto. constructor.
Qed.

Lemma transf_final_states:
  forall init_ls,
  forall sg,
  forall st1 st2 r,
    match_states st1 st2 -> LTLX.final_state init_ls sg st1 r -> LinearX.final_state init_ls sg st2 r.
Proof.
  intros. inv H0. inv H. inv H4. econstructor; eauto.
Qed.

Theorem transf_program_correct:
  forall init_ls i sg args m,
    forward_simulation (LTLX.semantics init_ls prog i sg args m) (LinearX.semantics init_ls tprog i sg args m).
Proof.
  intros.
  eapply forward_simulation_star.
  apply senv_preserved; eauto.
  apply transf_initial_states.
  apply transf_final_states.
  apply transf_step_correct; eauto.
Qed.

End WITHCONFIG.


Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import PeanoNat.
Require Import Ensembles.

Require Import FO_Bi_Int_Syntax.
Require Import Set_FO_Bi_Int_calcs.

Section Logics.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

Lemma subst_Ax : forall A f, (BIAxioms A) -> (BIAxioms A[f]).
Proof.
intros A f Ax. revert f. induction Ax ; intro f.
- destruct H. destruct H. destruct H. subst. apply RA1_I.
  exists (x[f]). exists (x0[f]). exists (x1[f]). unfold RA1. reflexivity.
- destruct H. destruct H. subst. apply RA2_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. subst. apply RA3_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. destruct H. subst. apply RA4_I.
  exists (x[f]). exists (x0[f]). exists (x1[f]). reflexivity.
- destruct H. destruct H. subst. apply RA5_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. subst. apply RA6_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. destruct H. subst. apply RA7_I.
  exists (x[f]). exists (x0[f]). exists (x1[f]). reflexivity.
- destruct H. destruct H. destruct H. subst. apply RA8_I.
  exists (x[f]). exists (x0[f]). exists (x1[f]). reflexivity.
- destruct H. destruct H. destruct H. subst. apply RA9_I.
  exists (x[f]). exists (x0[f]). exists (x1[f]). reflexivity.
- destruct H. destruct H. subst. apply RA10_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. subst. apply RA11_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. subst. apply RA12_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. destruct H. destruct H. subst. apply RA13_I.
  exists (x[f]). exists (x0[f]). exists (x1[f]). reflexivity.
- destruct H. destruct H. subst. apply RA14_I.
  exists (x[f]). exists (x0[f]). reflexivity.
- destruct H. subst. apply RA15_I. exists (x[f]). reflexivity.
- destruct H. subst. apply RA16_I. exists (x[f]). reflexivity.
- destruct H. destruct H. subst. apply RA17_I.
  unfold RA17. simpl. exists (x[f]). exists (x0[up f]).
  rewrite up_form. reflexivity.
- destruct H. destruct H. subst. apply RA18_I.
  unfold RA18. simpl. exists (x[up f]).
  assert (exists t, x[x0..][f] = x[up f][t..]).
  { rewrite subst_comp. unfold funcomp.
     exists (subst_term f x0).
    rewrite subst_comp. unfold funcomp. apply subst_ext. intros.
    induction n. simpl. auto. simpl. unfold funcomp. rewrite subst_term_comp.
    rewrite subst_term_id. auto. auto. }
  destruct H. exists x1. rewrite H. auto.
- destruct H. destruct H. subst. apply RA19_I.
  unfold RA19. simpl. exists (x[up f]).
  assert (exists t, x[x0..][f] = x[up f][t..]).
  { rewrite subst_comp. unfold funcomp.
     exists (subst_term f x0).
    rewrite subst_comp. unfold funcomp. apply subst_ext. intros.
    induction n. simpl. auto. simpl. unfold funcomp. rewrite subst_term_comp.
    rewrite subst_term_id. auto. auto. }
  destruct H. exists x1. rewrite H. auto.
Qed.

Theorem wFOBIC_subst : forall s f, wFOBIC_rules s ->
    wFOBIC_rules (fun x : form => exists B : form, x = B[f] /\ In form (fst s) B, (snd s)[f]).
Proof.
intros s f D. revert f. induction D ; intro f.
(* Id *)
- inversion H. subst. apply Id. apply IdRule_I. simpl. exists A. auto.
(* Ax *)
- inversion H. subst. apply Ax. apply AxRule_I. simpl. apply subst_Ax. auto.
(* MP *)
- inversion H1. subst. simpl. apply MP with (ps:=[(fun x : form => exists B : form, x = B[f] /\ In form Γ B, (A --> B)[f]); (fun x : form => exists B : form, x = B[f] /\ In form Γ B, A[f])]).
  intros. inversion H2. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1). apply w. inversion H3. subst.
  assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). apply w. inversion H4. simpl. apply MPRule_I.
(* DNw *)
- inversion H1. subst. simpl. apply DNw with (ps:=[(Empty_set _ , A[f])]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply DNwRule_I.
  assert (J1: List.In (Empty_set form, A) ((Empty_set form, A) :: nil)). apply in_eq.
  pose (H0 (Empty_set _, A) J1 f). simpl in w.
  assert ((fun x : form => exists B : form, x = B[f] /\ In form (Empty_set form) B) = Empty_set _).
  apply Extensionality_Ensembles. split. intro. intros. inversion H3. destruct H4. inversion H5.
  intro. intros. inversion H3. rewrite H3 in w ; auto.
(* Gen *)
- inversion H1. subst. simpl.
  apply Gen with (ps:=[((fun x : form => exists C : form, x = C[↑] /\ In _ (fun x : form => exists B : form, x = B[f] /\ In form Γ B) C), A[up f])]).
  2: apply GenRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B), A) (((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil))). apply in_eq.
  pose (@H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1). simpl in w.
  pose (w (up f)).
  assert ((fun x : form => exists B : form, x = B[up f] /\ In form (fun x0 : form => exists B0 : form, x0 = B0[↑] /\ In form Γ B0) B) =
  (fun x : form => exists C : form, x = C[↑] /\ In form (fun x0 : form => exists B : form, x0 = B[f] /\ In form Γ B) C)).
  apply Extensionality_Ensembles. split ; intro ; intro. inversion H3. destruct H4. inversion H5. destruct H6.
  subst. unfold In. exists x1[f]. split. apply up_form. exists x1. split ; auto. inversion H3.
  destruct H4. subst. inversion H5. destruct H4. subst. unfold In. exists x[↑]. split.
  rewrite up_form. auto. exists x ; split ; auto. rewrite <- H3 ; auto.
(* EC *)
- inversion H1. subst. simpl.
  apply EC with (ps:=[((fun x : form => exists C : form, x = C[↑] /\ In _ (fun x : form => exists B : form, x = B[f] /\ In form Γ B) C), A[up f] --> B[f][↑])]).
  2: apply ECRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (@H0 _ J1). simpl in w. pose (w (up f)).
  assert ((fun x : form => exists B : form, x = B[up f] /\ In form (fun x0 : form => exists B0 : form, x0 = B0[↑] /\ In form Γ B0) B) =
  (fun x : form => exists C : form, x = C[↑] /\ In form (fun x0 : form => exists B0 : form, x0 = B0[f] /\ In form Γ B0) C)).
  apply Extensionality_Ensembles. split ; intro ; intro. inversion H3. destruct H4. inversion H5. destruct H6.
  subst. unfold In. exists x1[f]. split. apply up_form. exists x1. split ; auto. inversion H3.
  destruct H4. subst. inversion H5. destruct H4. subst. unfold In. exists x[↑]. split.
  rewrite up_form. auto. exists x ; split ; auto.  rewrite up_form in w0. rewrite <- H3 ; auto.
Qed.

Theorem sFOBIC_subst : forall s f, sFOBIC_rules s -> sFOBIC_rules (fun x : form => exists B : form, x = B[f] /\ In form (fst s) B, (snd s)[f]).
Proof.
intros s f D. revert f. induction D ; intro f.
(* Ids *)
- inversion H. subst. apply Ids. apply IdRule_I. simpl. exists A. auto.
(* Axs *)
- inversion H. subst. apply Axs. apply AxRule_I. simpl. apply subst_Ax. auto.
(* MPs *)
- inversion H1. subst. simpl. apply MPs with (ps:=[(fun x : form => exists B : form, x = B[f] /\ In form Γ B, (A --> B)[f]); (fun x : form => exists B : form, x = B[f] /\ In form Γ B, A[f])]).
  intros. inversion H2. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1). apply s. inversion H3. subst.
  assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). apply s. inversion H4. simpl. apply MPRule_I.
(* DNs *)
- inversion H1. subst. simpl. apply DNs with (ps:=[(fun x : form => exists B : form, x = B[f] /\ In form Γ B, A[f])]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply DNsRule_I.
  apply H0 with (prem:=(Γ, A)). apply in_eq.
(* Gens *)
- inversion H1. subst. simpl.
  apply Gens with (ps:=[((fun x : form => exists C : form, x = C[↑] /\ In _ (fun x : form => exists B : form, x = B[f] /\ In form Γ B) C), A[up f])]).
  2: apply GenRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B), A) (((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil))). apply in_eq.
  pose (@H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1). simpl in s.
  pose (s (up f)).
  assert ((fun x : form => exists B : form, x = B[up f] /\ In form (fun x0 : form => exists B0 : form, x0 = B0[↑] /\ In form Γ B0) B) =
  (fun x : form => exists C : form, x = C[↑] /\ In form (fun x0 : form => exists B : form, x0 = B[f] /\ In form Γ B) C)).
  apply Extensionality_Ensembles. split ; intro ; intro. inversion H3. destruct H4. inversion H5. destruct H6.
  subst. unfold In. exists x1[f]. split. apply up_form. exists x1. split ; auto. inversion H3.
  destruct H4. subst. inversion H5. destruct H4. subst. unfold In. exists x[↑]. split.
  rewrite up_form. auto. exists x ; split ; auto. rewrite <- H3 ; auto.
(* ECs *)
- inversion H1. subst. simpl.
  apply ECs with (ps:=[((fun x : form => exists C : form, x = C[↑] /\ In _ (fun x : form => exists B : form, x = B[f] /\ In form Γ B) C), A[up f] --> B[f][↑])]).
  2: apply ECRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (@H0 _ J1). simpl in s. pose (s (up f)).
  assert ((fun x : form => exists B : form, x = B[up f] /\ In form (fun x0 : form => exists B0 : form, x0 = B0[↑] /\ In form Γ B0) B) =
  (fun x : form => exists C : form, x = C[↑] /\ In form (fun x0 : form => exists B0 : form, x0 = B0[f] /\ In form Γ B0) C)).
  apply Extensionality_Ensembles. split ; intro ; intro. inversion H3. destruct H4. inversion H5. destruct H6.
  subst. unfold In. exists x1[f]. split. apply up_form. exists x1. split ; auto. inversion H3.
  destruct H4. subst. inversion H5. destruct H4. subst. unfold In. exists x[↑]. split.
  rewrite up_form. auto. exists x ; split ; auto.  rewrite up_form in s0. rewrite <- H3 ; auto.
Qed.

Theorem wFOBIC_monot : forall s,
          (wFOBIC_rules s) ->
          (forall Γ1, Included _ (fst s) Γ1 -> (wFOBIC_rules (Γ1, (snd s)))).
Proof.
intros s D0. induction D0.
(* Id *)
- intros Γ1 incl. inversion H. subst. apply Id. apply IdRule_I. simpl. apply incl ; auto.
(* Ax *)
- intros Γ1 incl. inversion H. subst. apply Ax. apply AxRule_I. assumption.
(* MP *)
- intros Γ1 incl. inversion H1. subst. simpl. apply MP with (ps:=[(Γ1, A --> B); (Γ1, A)]).
  intros. inversion H2. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1 Γ1). apply w ; auto. inversion H3. subst.
  assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2 Γ1). apply w ; auto. inversion H4. apply MPRule_I.
(* DNw *)
- intros Γ1 incl. inversion H1. subst. simpl. apply DNw with (ps:=[(Empty_set _ , A)]).
  intros. inversion H2. subst. auto. inversion H3. apply DNwRule_I.
(* Gen *)
- intros Γ1 incl. inversion H1. subst. simpl. simpl in incl. apply Gen with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B, A)]).
  2: apply GenRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1 (fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B)). apply w.
  intro. simpl. intro. inversion H3. destruct H4 ; subst. unfold In. exists x0 ; split ; auto. apply incl ; auto.
(* EC *)
- intros Γ1 incl. inversion H1. subst. simpl. apply EC with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B, A --> B[↑])]).
  2: apply ECRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) J1 (fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B)). apply w.
  intro. simpl. intro. inversion H3. destruct H4 ; subst. unfold In. exists x0 ; split ; auto. apply incl ; auto.
Qed.

Theorem sFOBIC_monot : forall s,
          (sFOBIC_rules s) ->
          (forall Γ1, Included _ (fst s) Γ1 -> (sFOBIC_rules (Γ1, (snd s)))).
Proof.
intros s D0. induction D0.
(* Ids *)
- intros Γ1 incl. inversion H. subst. apply Ids. apply IdRule_I. simpl. apply incl ; auto.
(* Axs *)
- intros Γ1 incl. inversion H. subst. apply Axs. apply AxRule_I. assumption.
(* MPs *)
- intros Γ1 incl. inversion H1. subst. simpl. apply MPs with (ps:=[(Γ1, A --> B); (Γ1, A)]).
  intros. inversion H2. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1 Γ1). apply s ; auto. inversion H3. subst.
  assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2 Γ1). apply s ; auto. inversion H4. apply MPRule_I.
(* DNs *)
- intros Γ1 incl. inversion H1. subst. simpl. apply DNs with (ps:=[(Γ1 , A)]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply DNsRule_I.
  apply H0 with (prem:=(Γ, A)). apply in_eq. auto.
(* Gens *)
- intros Γ1 incl. inversion H1. subst. simpl. simpl in incl. apply Gens with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B, A)]).
  2: apply GenRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1 (fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B)). apply s.
  intro. simpl. intro. inversion H3. destruct H4 ; subst. unfold In. exists x0 ; split ; auto. apply incl ; auto.
(* ECs *)
- intros Γ1 incl. inversion H1. subst. simpl. apply ECs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B, A --> B[↑])]).
  2: apply ECRule_I. intros. inversion H2. 2: inversion H3. subst.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) J1 (fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B)). apply s.
  intro. simpl. intro. inversion H3. destruct H4 ; subst. unfold In. exists x0 ; split ; auto. apply incl ; auto.
Qed.

Theorem wFOBIC_comp : forall s,
          (wFOBIC_rules s) ->
          (forall Γ,  (forall A, (In _ (fst s) A) -> wFOBIC_rules (Γ, A)) ->
          wFOBIC_rules (Γ, (snd s))).
Proof.
intros s D0. induction D0.
(* Id *)
- intros Γ derall. inversion H. subst. pose (derall A). apply w. auto.
(* Ax *)
- intros Γ derall. inversion H. subst. apply Ax. apply AxRule_I. assumption.
(* MP *)
- intros Γ derall. inversion H1. subst. apply MP with (ps:=[(Γ, A --> B); (Γ, A)]).
  intros. inversion H2. subst. assert (J1: List.In (Γ0, A --> B) ((Γ0, A --> B) :: (Γ0, A) :: nil)). apply in_eq.
  pose (H0 (Γ0, A --> B) J1 Γ). apply w. simpl. auto. inversion H3. subst.
  assert (J2: List.In (Γ0, A) ((Γ0, A --> B) :: (Γ0, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ0, A) J2 Γ). apply w. auto. inversion H4. apply MPRule_I.
(* DNw *)
- intros Γ derall. inversion H1. subst. simpl. apply DNw with (ps:=[(Empty_set _, A)]).
  intros. inversion H2. subst. auto. inversion H3. apply DNwRule_I.
(* Gen *)
- intros Γ derall. inversion H1. subst. simpl. apply Gen with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A)]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply GenRule_I.
  apply H0 with (prem:=(fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A)). apply in_eq. simpl. intros. simpl in derall.
  inversion H3. destruct H4. subst. pose (derall x). apply w in H5.
  apply wFOBIC_subst with (f:=↑) (s:=(Γ, x)) ; auto.
(* EC *)
- intros Γ derall. inversion H1. subst. simpl. apply EC with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑])]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply ECRule_I.
  apply H0 with (prem:=(fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A --> B[↑])). apply in_eq. simpl. intros. simpl in derall.
  inversion H3. destruct H4. subst. pose (derall x). apply w in H5.
  apply wFOBIC_subst with (f:=↑) (s:=(Γ, x)) ; auto.
Qed.

Theorem sFOBIC_comp : forall s,
          (sFOBIC_rules s) ->
          (forall Γ,  (forall A, (In _ (fst s) A) -> sFOBIC_rules (Γ, A)) ->
          sFOBIC_rules (Γ, (snd s))).
Proof.
intros s D0. induction D0.
(* Ids *)
- intros Γ derall. inversion H. subst. pose (derall A). apply s. auto.
(* Axs *)
- intros Γ derall. inversion H. subst. apply Axs. apply AxRule_I. assumption.
(* MPs *)
- intros Γ derall. inversion H1. subst. apply MPs with (ps:=[(Γ, A --> B); (Γ, A)]).
  intros. inversion H2. subst. assert (J1: List.In (Γ0, A --> B) ((Γ0, A --> B) :: (Γ0, A) :: nil)). apply in_eq.
  pose (H0 (Γ0, A --> B) J1 Γ). apply s. simpl. auto. inversion H3. subst.
  assert (J2: List.In (Γ0, A) ((Γ0, A --> B) :: (Γ0, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ0, A) J2 Γ). apply s. auto. inversion H4. apply MPRule_I.
(* DNs *)
- intros Γ derall. inversion H1. subst. simpl. apply DNs with (ps:=[(Γ, A)]).
  intros. inversion H2. subst. auto. 2: inversion H3. 2: apply DNsRule_I.
  pose (H0 (Γ0, A)). apply s. apply in_eq. intros. simpl in H3. apply derall. auto.
(* Gens *)
- intros Γ derall. inversion H1. subst. simpl. apply Gens with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A)]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply GenRule_I.
  apply H0 with (prem:=(fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A)). apply in_eq. simpl. intros. simpl in derall.
  inversion H3. destruct H4. subst. pose (derall x). apply s in H5.
  apply sFOBIC_subst with (f:=↑) (s:=(Γ, x)) ; auto.
(* ECs *)
- intros Γ derall. inversion H1. subst. simpl. apply ECs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑])]).
  intros. inversion H2. subst. 2: inversion H3. 2: apply ECRule_I.
  apply H0 with (prem:=(fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A --> B[↑])). apply in_eq. simpl. intros. simpl in derall.
  inversion H3. destruct H4. subst. pose (derall x). apply s in H5.
  apply sFOBIC_subst with (f:=↑) (s:=(Γ, x)) ; auto.
Qed.

Lemma List_Reverse_arrow : forall l0 Γ0 Γ1,
  (Included form Γ0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B)) ->
  (forall A : form, (Γ0 A -> List.In A l0) * (List.In A l0 -> Γ0 A)) ->
      (exists l1, (map (subst_form ↑) l1 = l0) /\ (forall y, List.In y l1 -> In _ Γ1 y)).
Proof.
induction l0 ; intros.
- exists []. split ; auto. intros. inversion H1.
- destruct (In_dec eq_dec_form a l0).
  + assert (J1: forall A : form, (Γ0 A -> List.In A l0) * (List.In A l0 -> Γ0 A)).
     intros. split ; intro. apply H0 in H1. inversion H1. subst. auto. auto.
     apply H0. apply in_cons. auto.
     pose (IHl0 Γ0 Γ1 H J1). destruct e. destruct H1. subst. pose (H0 a).
     destruct p. assert (List.In a (a :: map (subst_form ↑) x)). apply in_eq.
     apply γ in H1. apply H in H1. unfold In in H1. destruct H1. destruct H1. subst.
     exists (x0 :: x). simpl. split ; auto. intros. destruct H1 ; subst ; auto.
  + assert (J1: Included form (fun x : form => x <> a /\ In form Γ0 x)
     (fun x : form => exists B : form, x = B[↑] /\ In form Γ1 B)).
     intro. intros. unfold In in H1. destruct H1. apply H in H2. auto.
     assert (J2: (forall A : form, ((fun x : form => x <> a /\ In form Γ0 x) A -> List.In A l0) *
     (List.In A l0 -> (fun x : form => x <> a /\ In form Γ0 x) A))).
     intros. split. intro. destruct H1. apply H0 in H2. inversion H2. exfalso ; auto. auto.
     intros. split. intro. subst. auto. assert (List.In A (a :: l0)). apply in_cons ; auto.
     apply H0 in H2. auto.
     pose (IHl0 (fun x => x <> a /\ In _ Γ0 x) Γ1 J1 J2). destruct e. destruct H1. subst.
     pose (H0 a). destruct p. assert (List.In a (a :: map (subst_form ↑) x)). apply in_eq.
     apply γ in H1. apply H in H1. unfold In in H1. destruct H1. destruct H1. subst.
     exists (x0 :: x). simpl. split ; auto. intros. destruct H1 ; subst ; auto.
Qed.

Theorem wFOBIC_finite : forall s,
          (wFOBIC_rules s) ->
          (exists (Γ : Ensemble _), prod (Included _ Γ (fst s))
                                     (prod (wFOBIC_rules (Γ, snd s))
                                     (exists (l : list form), (forall A, ((Γ A) -> List.In A l) * (List.In A l -> (Γ A)))))).
Proof.
intros s D0. induction D0.
(* Id *)
- inversion H. subst. simpl. exists (fun x => x = A).
  repeat split. intro. intro. unfold In. inversion H1. assumption.
  apply Id. apply IdRule_I. auto. unfold In ; auto.
  exists [A]. intro. split. intro. subst. apply in_eq. intro. inversion H1.
  subst. auto. inversion H2.
(* Ax *)
- inversion H. subst. simpl. exists (Empty_set _).
  repeat split. intro. intro. unfold In. inversion H1.
  apply Ax. apply AxRule_I. auto.
  exists []. intro. split. intro. subst. inversion H1. intro. inversion H1.
(* MP *)
- inversion H1. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1). destruct e. destruct H2. destruct p. destruct e.
  assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). destruct e. destruct H3. destruct p. destruct e.
  exists (Union _ x x1). repeat split. intro. intro. simpl. inversion H4.
  subst. apply i. assumption. apply i0. assumption. simpl.
  apply MP with (ps:=[(Union _ x x1, A --> B); (Union _ x x1, A)]).
  intros. inversion H4. subst.
  assert (J3: Included _ (fst (x, A --> B)) (Union _ x x1)). intro. simpl. intro.
  apply Union_introl. assumption. pose (@wFOBIC_monot (x, A --> B) w (Union _ x x1) J3). assumption.
  inversion H5. subst. assert (J4: Included _ (fst (x1, A)) (Union _ x x1)). intro. simpl. intro.
  apply Union_intror. assumption. pose (@wFOBIC_monot (x1, A) w0 (Union _ x x1) J4). assumption.
  inversion H6. apply MPRule_I.
  exists (x0 ++ x2). intro. split. intro. inversion H4. subst. pose (H2 A0).
  destruct p. apply in_or_app. apply i1 in H5. auto. subst. pose (H3 A0).
  destruct p. apply i1 in H5. apply in_or_app. auto. intro. apply in_app_or in H4.
  destruct H4. apply Union_introl. apply H2. assumption. apply Union_intror.
  apply H3. assumption.
(* DNw *)
- inversion H1. subst. exists (Empty_set _). repeat split.
  intro. intro. simpl. inversion H2. apply DNw with (ps:=[(Empty_set _, A)]).
  assumption. apply DNwRule_I. exists []. intro. split. intro. inversion H2.
  intro. inversion H2.
(* Gen *)
- inversion H1. subst. simpl.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1). destruct e. destruct H2. destruct p. destruct e.
  simpl in i. simpl in w.
  assert (exists x1, (map (subst_form ↑) x1 = x0) /\ (forall y, List.In y x1 -> In _ Γ y)).
  pose (List_Reverse_arrow x0 x Γ). apply e ; auto.
  destruct H3. destruct H3.
  exists (fun y => List.In y x1). repeat split. intro. intro. unfold In in H5. apply H4 ; auto.
  apply Gen with (ps:=[((fun z => exists C, z = C[↑] /\ In form (fun y : form => List.In y x1) C), A)]).
  intros. 2: apply GenRule_I. inversion H5. subst. 2: inversion H6.
  assert ((fun z : form => exists C : form, z = C[↑] /\ In form (fun y : form => List.In y x1) C) = x).
  apply Extensionality_Ensembles. split ; intro ; intro.
  inversion H3. destruct H6. subst. unfold In in H7. apply H2.
  apply in_map_iff. exists x2 ; split ; auto. unfold In. apply H2 in H3. apply in_map_iff in H3.
  destruct H3. destruct H3 ; subst. exists x2. split ; auto.
  rewrite H3. auto. exists x1. intros ; auto.
(* EC *)
- inversion H1. subst. simpl.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) J1). destruct e. destruct H2. destruct p. destruct e.
  simpl in i. simpl in w.
  assert (exists x1, (map (subst_form ↑) x1 = x0) /\ (forall y, List.In y x1 -> In _ Γ y)).
  pose (List_Reverse_arrow x0 x Γ). apply e ; auto.
  destruct H3. destruct H3.
  exists (fun y => List.In y x1). repeat split. intro. intro. unfold In in H5. apply H4 ; auto.
  apply EC with (ps:=[((fun z => exists C, z = C[↑] /\ In form (fun y : form => List.In y x1) C), A --> B[↑])]).
  intros. 2: apply ECRule_I. inversion H5. subst. 2: inversion H6.
  assert ((fun z : form => exists C : form, z = C[↑] /\ In form (fun y : form => List.In y x1) C) = x).
  apply Extensionality_Ensembles. split ; intro ; intro.
  inversion H3. destruct H6. subst. unfold In in H7. apply H2.
  apply in_map_iff. exists x2 ; split ; auto. unfold In. apply H2 in H3. apply in_map_iff in H3.
  destruct H3. destruct H3 ; subst. exists x2. split ; auto.
  rewrite H3. auto. exists x1. intros ; auto.
Qed.

Theorem sFOBIC_finite : forall s,
          (sFOBIC_rules s) ->
          (exists (Γ : Ensemble _), prod (Included _ Γ (fst s))
                                     (prod (sFOBIC_rules (Γ, snd s))
                                     (exists (l : list form), (forall A, ((Γ A) -> List.In A l) * (List.In A l -> (Γ A)))))).
Proof.
intros s D0. induction D0.
(* Ids *)
- inversion H. subst. simpl. exists (fun x => x = A).
  repeat split. intro. intro. unfold In. inversion H1. assumption.
  apply Ids. apply IdRule_I. auto. unfold In ; auto.
  exists [A]. intro. split. intro. subst. apply in_eq. intro. inversion H1.
  subst. auto. inversion H2.
(* Axs *)
- inversion H. subst. simpl. exists (Empty_set _).
  repeat split. intro. intro. unfold In. inversion H1.
  apply Axs. apply AxRule_I. auto.
  exists []. intro. split. intro. subst. inversion H1. intro. inversion H1.
(* MPs *)
- inversion H1. subst. assert (J1: List.In (Γ, A --> B) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A --> B) J1). destruct e. destruct H2. destruct p. destruct e.
  assert (J2: List.In (Γ, A) ((Γ, A --> B) :: (Γ, A) :: nil)). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). destruct e. destruct H3. destruct p. destruct e.
  exists (Union _ x x1). repeat split. intro. intro. simpl. inversion H4.
  subst. apply i. assumption. apply i0. assumption. simpl.
  apply MPs with (ps:=[(Union _ x x1, A --> B); (Union _ x x1, A)]).
  intros. inversion H4. subst.
  assert (J3: Included _ (fst (x, A --> B)) (Union _ x x1)). intro. simpl. intro.
  apply Union_introl. assumption. pose (@sFOBIC_monot (x, A --> B) s (Union _ x x1) J3). assumption.
  inversion H5. subst. assert (J4: Included _ (fst (x1, A)) (Union _ x x1)). intro. simpl. intro.
  apply Union_intror. assumption. pose (@sFOBIC_monot (x1, A) s0 (Union _ x x1) J4). assumption.
  inversion H6. apply MPRule_I.
  exists (x0 ++ x2). intro. split. intro. inversion H4. subst. pose (H2 A0).
  destruct p. apply in_or_app. apply i1 in H5. auto. subst. pose (H3 A0).
  destruct p. apply i1 in H5. apply in_or_app. auto. intro. apply in_app_or in H4.
  destruct H4. apply Union_introl. apply H2. assumption. apply Union_intror.
  apply H3. assumption.
(* DNs *)
- inversion H1. subst. simpl. assert (J1: List.In (Γ, A) ((Γ, A) :: nil)). apply in_eq.
  pose (H0 (Γ, A) J1). destruct e. destruct H2. destruct p. destruct e.
  exists x. repeat split. intro. intro. simpl. apply i. assumption.
  simpl in s. apply DNs with (ps:=[(x, A)]). 2: apply DNsRule_I. intros.
  inversion H3. subst. 2: inversion H4. auto. exists x0. intro. split ; intro ;
  apply H2 ; auto.
(* Gens *)
- inversion H1. subst. simpl.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A) J1). destruct e. destruct H2. destruct p. destruct e.
  simpl in i. simpl in s.
  assert (exists x1, (map (subst_form ↑) x1 = x0) /\ (forall y, List.In y x1 -> In _ Γ y)).
  pose (List_Reverse_arrow x0 x Γ). apply e ; auto.
  destruct H3. destruct H3.
  exists (fun y => List.In y x1). repeat split. intro. intro. unfold In in H5. apply H4 ; auto.
  apply Gens with (ps:=[((fun z => exists C, z = C[↑] /\ In form (fun y : form => List.In y x1) C), A)]).
  intros. 2: apply GenRule_I. inversion H5. subst. 2: inversion H6.
  assert ((fun z : form => exists C : form, z = C[↑] /\ In form (fun y : form => List.In y x1) C) = x).
  apply Extensionality_Ensembles. split ; intro ; intro.
  inversion H3. destruct H6. subst. unfold In in H7. apply H2.
  apply in_map_iff. exists x2 ; split ; auto. unfold In. apply H2 in H3. apply in_map_iff in H3.
  destruct H3. destruct H3 ; subst. exists x2. split ; auto.
  rewrite H3. auto. exists x1. intros ; auto.
(* ECs *)
- inversion H1. subst. simpl.
  assert (J1: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) :: nil)). apply in_eq.
  pose (H0 (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A --> B[↑]) J1). destruct e. destruct H2. destruct p. destruct e.
  simpl in i. simpl in s.
  assert (exists x1, (map (subst_form ↑) x1 = x0) /\ (forall y, List.In y x1 -> In _ Γ y)).
  pose (List_Reverse_arrow x0 x Γ). apply e ; auto.
  destruct H3. destruct H3.
  exists (fun y => List.In y x1). repeat split. intro. intro. unfold In in H5. apply H4 ; auto.
  apply ECs with (ps:=[((fun z => exists C, z = C[↑] /\ In form (fun y : form => List.In y x1) C), A --> B[↑])]).
  intros. 2: apply ECRule_I. inversion H5. subst. 2: inversion H6.
  assert ((fun z : form => exists C : form, z = C[↑] /\ In form (fun y : form => List.In y x1) C) = x).
  apply Extensionality_Ensembles. split ; intro ; intro.
  inversion H3. destruct H6. subst. unfold In in H7. apply H2.
  apply in_map_iff. exists x2 ; split ; auto. unfold In. apply H2 in H3. apply in_map_iff in H3.
  destruct H3. destruct H3 ; subst. exists x2. split ; auto.
  rewrite H3. auto. exists x1. intros ; auto.
Qed.

End Logics.


Require Import Algebra.Utils Algebra.SetoidCat Algebra.SetoidCat.PairUtils Algebra.Monad Algebra.Monoid Algebra.Traversable Algebra.FoldableFunctor Algebra.Functor SetoidUtils Algebra.Applicative Algebra.Alternative Tactics Algebra.SetoidCat.BoolUtils Algebra.Functor.Utils Algebra.Functor.Compose Algebra.Applicative.Compose Algebra.Functor.List Algebra.SetoidCat.ListUtils Algebra.Applicative.List Algebra.Applicative.Utils Algebra.Applicative.Transformation Algebra.Applicative.TransformationUtils.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Require Import Coq.Lists.List.

Import ListNotations.

Section Generic.

  Definition l A {AS : Setoid A} := list A.
  Instance lS {A} (AS : Setoid A) : Setoid (l A) := listS AS.

  Existing Instance ComposeFunctor.
  Existing Instance Compose_Applicative.
  Existing Instance ComposeS.

  Existing Instance ComposeIso'_Proper.
  Existing Instance listFunctor.

  Instance list_Traversable : @Traversable l (@lS) _.
  Proof.
    exists (@sequenceS).
    intros. simpl. arrequiv. induction a.
    simpl. reflexivity.
    simpl. constructor. reflexivity. destruct (sequence a0). auto.

    intros. simpl_equiv. induction a.
    simpl. repeat rewrite fmap_fmap. evalproper. evalproper. simpl. arrequiv.
    rewrite sequenceS_cons. repeat rewrite comp_eval. rewrite mapS_cons. rewrite sequenceS_cons. rewrite IHa. unfold ap at 1. unfold fmap at 1 2. unfold ComposeFunctor. unfold compFunc_fmap. unfold comp2S. normalizecomp. evalproper.
    match goal with
      | |- _ <$> _ @ (_ @ ?a ** _ @ ?b) == _ =>
        rewrite (ComposeIsoS'_prod _ _ _ _ _ _ app' app'' _ _ _ _ a b)
    end.
    rewrite naturality_prod. rewrite <- uncurry_fmap_prod.  repeat rewrite fmap_fmap. evalproper. evalproper. simpl. arrequiv. simpl_let. reflexivity.

    intros. simpl_equiv. induction a.
    rewrite comp_eval. rewrite sequenceS_nil. rewrite app_trans_pure. reflexivity. auto.
    rewrite comp_eval. rewrite sequenceS_cons. rewrite app_trans_ap. rewrite app_trans_naturality.
    rewrite comp_eval. simpl (tr A AS <$> (a :: a0)). rewrite sequenceS_cons. evalproper. auto. auto.
  Defined.

End Generic.

Section MapM.

  Context
    {m mS}
    {func}
    {app : @Applicative m mS func}
    {A B : Type}
    {SA : Setoid A}
    {SB : Setoid B}.

  Existing Instance listFunctor.
  Existing Instance list_Applicative.
  Existing Instance list_Traversable.
  Definition mapM : (SA ~~> mS _ SB) ~> listS SA ~~> mS _ (listS SB) :=
    comp2S @ fmap @ sequenceA.

  Lemma mapM_cons :
    forall (f: SA ~> mS _ SB) (a : A) ( l : list A),
      mapM @ f @ ( a :: l) == consS <$> f @ a <*> mapM @ f @ l.
  Proof.
    intros.  unfold mapM at 1. unfold comp2S. normalizecomp. simpl fmap. rewrite mapS_cons. rewrite (sequenceS_cons).  evalproper.
  Qed.

  Lemma mapM_consS :
    forall (f: SA ~> mS _ SB) (a : A) ( l : list A),
      mapM @ f @ (consS @ a @ l) == consS <$> f @ a <*> mapM @ f @ l.
  Proof.
    apply mapM_cons.
  Qed.

  Lemma mapM_nil : forall  (f : SA ~> mS _ SB), mapM @ f @ nil == pure @ nil.
  Proof.
    intros. simpl. reflexivity.
  Qed.

  Lemma mapM_app :
    forall (f: SA ~> mS _ SB) (l l2 : list A),
      mapM @ f @ (  l ++ l2) ==
      appS <$> mapM @ f @ l <*> mapM @ f @ l2.
  Proof.
    intros. induction l0.
    simpl (([] ++ l2)). rewrite mapM_nil. rewrite fmap_pure. assert (appS @ [] == idS).
    simpl. arrequiv.
    rewrite H. rewrite ap_pure. rewrite fmap_idS_absorb. reflexivity.
    simpl (( _ :: _ ) ++ _ ). repeat rewrite mapM_cons. rewrite IHl0.
    simpl. normalizecomp. rewrite <- (fmap_idS_absorb (sequence (map (fun a0 : A => f @ a0) l2))) at 1. rewrite naturality_prod. rewrite fmap_fmap. rewrite naturality_prod. rewrite <- associativity_applicative. rewrite fmap_fmap. rewrite fmap_fmap.
    rewrite <- (fmap_idS_absorb (sequence (map (fun a0 : A => f @ a0) l0))) at 2. rewrite naturality_prod. repeat rewrite fmap_fmap. rewrite <- (fmap_idS_absorb (sequence (map (fun a0 : A => f @ a0) l2))) at 2. rewrite naturality_prod. repeat rewrite fmap_fmap. evalproper. evalproper. simpl. arrequiv. destruct a0. destruct p. simpl. reflexivity.
  Qed.

  Lemma mapM_appS :
    forall (f: SA ~> mS _ SB) (l l2 :  (list A)),
      mapM @ f @ (appS @ l @ l2) ==
      appS <$> mapM @ f @ l <*> mapM @ f @ l2.
  Proof.
    apply mapM_app.
  Qed.
End MapM.

Section ConcatMap.
  Context
    {m mS}
    {func}
    {app : @Applicative m mS func}
    {A B : Type}
    {SA : Setoid A}
    {SB : Setoid B}.
  Definition concatMapM  : (SA ~~> mS _ (listS SB)) ~> listS SA ~~> mS _ (listS SB).
    simple refine (injF (fun f : SA ~> mS _ (listS SB) => injF (fun l => concatS <$> mapM @ f @ l) _ ) _).
    exact mS.
    exact func.
    exact func.
    exact app.
    Lemma concatMap_1 : forall f, Proper (equiv ==> equiv) (fun l : list A => concatS <$> mapM @ f @ l).
    Proof.
      repeat autounfold. intros. rewrite H. reflexivity.
    Qed.
    apply concatMap_1.

    Lemma concatMap_2 : forall pr, Proper (equiv ==> equiv)
                                          (fun f : SA ~> mS _ (listS SB) =>
                                             injF (fun l : list A => concatS <$> mapM @ f @ l) (pr f)).
    Proof.
      repeat autounfold. intros. arrequiv. evalproper. apply sequence_Proper. apply map_Proper. autounfold. intros. rewritesr.  reflexivity.
    Qed.
    apply concatMap_2.
  Defined.
End ConcatMap.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib Compopts.
Require Import AST Integers Floats Values Memory Globalenvs.
Require Import Op RTL ValueDomain.

(** Value analysis for RISC V operators *)

Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
  | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
  | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
  | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2
  | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2
  | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n)
  | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n)
  | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
  | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2
  | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2)
  | _, _ => Bnone
  end.

Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
  match addr, vl with
  | Aindexed n, v1::nil => offset_ptr v1 n
  | Aglobal s ofs, nil => Ptr (Gl s ofs)
  | Ainstack ofs, nil => Ptr (Stk ofs)
  | _, _ => Vbot
  end.

Definition eval_static_operation (op: operation) (vl: list aval): aval :=
  match op, vl with
  | Omove, v1::nil => v1
  | Ointconst n, nil => I n
  | Olongconst n, nil => L n
  | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop
  | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop
  | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
  | Oaddrstack ofs, nil => Ptr (Stk ofs)
  | Ocast8signed, v1 :: nil => sign_ext 8 v1
  | Ocast16signed, v1 :: nil => sign_ext 16 v1
  | Oadd, v1::v2::nil => add v1 v2
  | Oaddimm n, v1::nil => add v1 (I n)
  | Oneg, v1::nil => neg v1
  | Osub, v1::v2::nil => sub v1 v2
  | Omul, v1::v2::nil => mul v1 v2
  | Omulhs, v1::v2::nil => mulhs v1 v2
  | Omulhu, v1::v2::nil => mulhu v1 v2
  | Odiv, v1::v2::nil => divs v1 v2
  | Odivu, v1::v2::nil => divu v1 v2
  | Omod, v1::v2::nil => mods v1 v2
  | Omodu, v1::v2::nil => modu v1 v2
  | Oand, v1::v2::nil => and v1 v2
  | Oandimm n, v1::nil => and v1 (I n)
  | Oor, v1::v2::nil => or v1 v2
  | Oorimm n, v1::nil => or v1 (I n)
  | Oxor, v1::v2::nil => xor v1 v2
  | Oxorimm n, v1::nil => xor v1 (I n)
  | Oshl, v1::v2::nil => shl v1 v2
  | Oshlimm n, v1::nil => shl v1 (I n)
  | Oshr, v1::v2::nil => shr v1 v2
  | Oshrimm n, v1::nil => shr v1 (I n)
  | Oshru, v1::v2::nil => shru v1 v2
  | Oshruimm n, v1::nil => shru v1 (I n)
  | Oshrximm n, v1::nil => shrx v1 (I n)
  | Omakelong, v1::v2::nil => longofwords v1 v2
  | Olowlong, v1::nil => loword v1
  | Ohighlong, v1::nil => hiword v1
  | Ocast32signed, v1::nil => longofint v1
  | Ocast32unsigned, v1::nil => longofintu v1
  | Oaddl, v1::v2::nil => addl v1 v2
  | Oaddlimm n, v1::nil => addl v1 (L n)
  | Onegl, v1::nil => negl v1
  | Osubl, v1::v2::nil => subl v1 v2
  | Omull, v1::v2::nil => mull v1 v2
  | Omullhs, v1::v2::nil => mullhs v1 v2
  | Omullhu, v1::v2::nil => mullhu v1 v2
  | Odivl, v1::v2::nil => divls v1 v2
  | Odivlu, v1::v2::nil => divlu v1 v2
  | Omodl, v1::v2::nil => modls v1 v2
  | Omodlu, v1::v2::nil => modlu v1 v2
  | Oandl, v1::v2::nil => andl v1 v2
  | Oandlimm n, v1::nil => andl v1 (L n)
  | Oorl, v1::v2::nil => orl v1 v2
  | Oorlimm n, v1::nil => orl v1 (L n)
  | Oxorl, v1::v2::nil => xorl v1 v2
  | Oxorlimm n, v1::nil => xorl v1 (L n)
  | Oshll, v1::v2::nil => shll v1 v2
  | Oshllimm n, v1::nil => shll v1 (I n)
  | Oshrl, v1::v2::nil => shrl v1 v2
  | Oshrlimm n, v1::nil => shrl v1 (I n)
  | Oshrlu, v1::v2::nil => shrlu v1 v2
  | Oshrluimm n, v1::nil => shrlu v1 (I n)
  | Oshrxlimm n, v1::nil => shrxl v1 (I n)
  | Onegf, v1::nil => negf v1
  | Oabsf, v1::nil => absf v1
  | Oaddf, v1::v2::nil => addf v1 v2
  | Osubf, v1::v2::nil => subf v1 v2
  | Omulf, v1::v2::nil => mulf v1 v2
  | Odivf, v1::v2::nil => divf v1 v2
  | Onegfs, v1::nil => negfs v1
  | Oabsfs, v1::nil => absfs v1
  | Oaddfs, v1::v2::nil => addfs v1 v2
  | Osubfs, v1::v2::nil => subfs v1 v2
  | Omulfs, v1::v2::nil => mulfs v1 v2
  | Odivfs, v1::v2::nil => divfs v1 v2
  | Osingleoffloat, v1::nil => singleoffloat v1
  | Ofloatofsingle, v1::nil => floatofsingle v1
  | Ointoffloat, v1::nil => intoffloat v1
  | Ointuoffloat, v1::nil => intuoffloat v1
  | Ofloatofint, v1::nil => floatofint v1
  | Ofloatofintu, v1::nil => floatofintu v1
  | Ointofsingle, v1::nil => intofsingle v1
  | Ointuofsingle, v1::nil => intuofsingle v1
  | Osingleofint, v1::nil => singleofint v1
  | Osingleofintu, v1::nil => singleofintu v1
  | Olongoffloat, v1::nil => longoffloat v1
  | Olonguoffloat, v1::nil => longuoffloat v1
  | Ofloatoflong, v1::nil => floatoflong v1
  | Ofloatoflongu, v1::nil => floatoflongu v1
  | Olongofsingle, v1::nil => longofsingle v1
  | Olonguofsingle, v1::nil => longuofsingle v1
  | Osingleoflong, v1::nil => singleoflong v1
  | Osingleoflongu, v1::nil => singleoflongu v1
  | Ocmp c, _ => of_optbool (eval_static_condition c vl)
  | _, _ => Vbot
  end.

Section SOUNDNESS.

Variable bc: block_classification.
Variable ge: genv.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.

Theorem eval_static_condition_sound:
  forall cond vargs m aargs,
  list_forall2 (vmatch bc) vargs aargs ->
  cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
Proof.
  intros until aargs; intros VM. inv VM.
  destruct cond; auto with va.
  inv H0.
  destruct cond; simpl; eauto with va.
  inv H2.
  destruct cond; simpl; eauto with va.
  destruct cond; auto with va.
Qed.

Lemma symbol_address_sound:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)).
Proof.
  intros; apply symbol_address_sound; apply GENV.
Qed.

Lemma symbol_address_sound_2:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)).
Proof.
  intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F.
  constructor. constructor. apply GENV; auto.
  constructor.
Qed.

Hint Resolve symbol_address_sound symbol_address_sound_2: va.

Ltac InvHyps :=
  match goal with
  | [H: None = Some _ |- _ ] => discriminate
  | [H: Some _ = Some _ |- _] => inv H
  | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
     H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
  | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps
  | _ => idtac
  end.

Theorem eval_static_addressing_sound:
  forall addr vargs vres aargs,
  eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing addr aargs).
Proof.
  unfold eval_addressing, eval_static_addressing; intros;
  destruct addr; InvHyps; eauto with va.
  rewrite Ptrofs.add_zero_l; eauto with va.
Qed.

Theorem eval_static_operation_sound:
  forall op vargs m vres aargs,
  eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_operation op aargs).
Proof.
  unfold eval_operation, eval_static_operation; intros;
  destruct op; InvHyps; eauto with va.
  destruct (propagate_float_constants tt); constructor.
  destruct (propagate_float_constants tt); constructor.
  rewrite Ptrofs.add_zero_l; eauto with va.
  apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
Qed.

End SOUNDNESS.


Require Import CommonST.
Require Import Events.
Require Import TraceModel.
Require Import Criteria.
Require Import ClassicalExtras.

Section Quick.

(* Very strange thing: This doesn't use RTEP at all! *)
(* - Any chance that going beyond RTC will fix this? *)

(* Less strange thing: this doesn't use compiler correctness any more *)

Definition valid_trace P t := exists Cs, sem src (Cs[P]) t.

Definition valid_finpref P m := exists Cs, @psem src (Cs[P]) m.

Definition err := esbad. (* This esbad thing is not general enough *)

Hypothesis fsb : forall P t,
  (exists Ct, sem tgt (Ct[P↓]) t /\ ~valid_trace P t) ->
  (exists m, t = tapp m (tstop err) /\ valid_finpref P m).

Lemma rtc_informative : forall P Ct t,
  sem tgt (Ct[P↓]) t ->
  exists Cs,
    (valid_trace P t -> sem src (Cs[P]) t) /\
    (~valid_trace P t -> exists m, psem (Cs[P]) m /\ t = (tapp m (tstop err))).
Proof.
  intros P Ct t H. destruct (classic (valid_trace P t)) as [Hv | Hnv].
  - destruct Hv as [Cs Hv]. exists Cs. split.
    + intros _. exact Hv.
    + intro Hnv. apply False_ind. apply Hnv. exists Cs. exact Hv.
  - assert(H':exists Ct, sem tgt (Ct [P ↓]) t /\ ~ valid_trace P t) by eauto.
    specialize (fsb P t H'). clear H'.
    destruct fsb as [m [H1 H2]]. clear fsb. subst. destruct H2 as [Cs H2].
    exists Cs. split.
    + intro Hv. apply False_ind. tauto.
    + intros _. exists m. split. assumption. reflexivity.
Qed.

(* If we can do the final `err` in the source then we can prove the original rtc
   - but there are still concerns about fsb and valid needing to be amended
     in this case to say that err is not in t
   - and more importantly the err_ctx_correct assumption seems too strong;
     context would be able to preempt program at any point and produce any action
*)

Variable err_ctx : ctx src -> ctx src.

Hypothesis err_ctx_correct : forall C P m,
  @psem src (C[P]) m ->
  sem src ((err_ctx C)[P]) (tapp m (tstop err)).

Lemma rtc : RTC.
Proof.
  rewrite RTC'.
  intros P Ct t H. destruct (classic (valid_trace P t)) as [Hv | Hnv].
  - destruct Hv as [Cs Hv]. exists Cs. exact Hv.
  - assert(H':exists Ct, sem tgt (Ct [P ↓]) t /\ ~ valid_trace P t) by eauto.
    specialize (fsb P t H'). clear H'.
    destruct fsb as [m [H1 H2]]. clear fsb. subst. destruct H2 as [Cs H2].
    exists (err_ctx Cs). now apply err_ctx_correct.
Qed.

End Quick.

Section Stefan.

  Definition question_mark := forall P1 P2 Ct,
    beh (Ct [P1 ↓]) ⊆ beh (Ct [P2 ↓]) ->
    exists Cs, beh (Cs [P1 ]) ⊆ beh (Cs [P2 ]).

  Variable Wt : trace -> par src.

  Hypothesis only_t:  forall Ct t t', sem tgt (Ct [(Wt t)↓]) t' -> t = t'.
  Hypothesis t_src : forall Cs t, sem src (Cs [(Wt t)]) t. (* CC for Wt *)

  Lemma question_mark_RTC : question_mark -> RTC.
  Proof.
    rewrite RTC'. intros Hqm P Ct t Ht.
    destruct (classic (valid_trace P t)).
    - exact H.
    - unfold valid_trace in H. rewrite not_ex_forall_not in H.
      destruct (Hqm (Wt t) P Ct) as [Cs HCs].
      + intros b Hb. apply only_t in Hb. rewrite <- Hb. auto.
      + exfalso. apply ((H Cs)). apply HCs. apply t_src.
  Qed.

  (* CA:

     only_t + t_src => ((~ valid P t) -> False)

  *)

End Stefan.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal7.

From lfind Require Import LFind.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal7_theorem0_58_plus_comm/goal7_lfind_orig.ml"  adtind.goal7.plus adtind.goal7.len adtind.goal7.qreva.
Success.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal42.

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_goal42_theorem0_67_mem_union/goal42_lfind_orig.ml"  adtind.goal42.eqb adtind.goal42.lst_mem adtind.goal42.lst_union.
Success.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export proof_with_lib.
Require Export proof_with_lib_notation.

Definition opabs_myint : opabs := Build_opabs "myint" [] [].

Definition cmds1 {o} : @commands o :=
  [
    (* We add the 'member' abstraction *)
    COM_add_def
      opabs_member
      [(nvart, 0), (nvarT, 0)]
      (mk_so_equality (sovar nvart []) (sovar nvart []) (sovar nvarT []))
      opabs_member_correct,

    (* We prove that 'member' is well-formed *)
    COM_start_proof
      "member_wf"
      (mk_uall
         (mk_uni 0)
         nvarT
         (mk_uall
            (mk_var nvarT)
            nvart
            (mk_member
               (mk_abs opabs_member [nobnd (mk_var nvart), nobnd (mk_var nvarT)])
               (mk_uni 0))))
      (eq_refl, eq_refl),
    COM_update_proof
      "member_wf"
      []
      (proof_step_isect_member_formation (nvar "T") 1),
    COM_update_proof
      "member_wf"
      [1]
      (proof_step_isect_member_formation (nvar "t") 0),
    COM_update_proof
      "member_wf"
      [1,1]
      (proof_step_cut
         (nvar "w")
         (mk_cequiv
            (mk_abs opabs_member [nobnd (mk_var (nvar "t")), nobnd (mk_var (nvar "T"))])
            (mk_equality (mk_var (nvar "t")) (mk_var (nvar "t")) (mk_var (nvar "T"))))),
    COM_update_proof
      "member_wf"
      [1,1,1]
      (proof_step_cequiv_computation 1),
    COM_update_proof
      "member_wf"
      [1,1,2]
      (proof_step_cequiv_subst_concl
         (nvar "x")
         (mk_equality (vterm (nvar "x")) (vterm (nvar "x")) (mk_uni 0))
         (mk_abs opabs_member [nobnd (mk_var (nvar "t")), nobnd (mk_var (nvar "T"))])
         (mk_equality (mk_var (nvar "t")) (mk_var (nvar "t")) (mk_var (nvar "T")))),
    COM_update_proof
      "member_wf"
      [1,1,2,1]
      (proof_step_hypothesis (nvar "w")),
    COM_update_proof
      "member_wf"
      [2]
      (proof_step_universe_equality),
    COM_update_proof
      "member_wf"
      [1,2]
      (proof_step_unhide_equality (nvar "T")),
    COM_update_proof
      "member_wf"
      [1,2,1]
      (proof_step_hypothesis_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2]
      (proof_step_equality_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2,1]
      (proof_step_unhide_equality (nvar "T")),
    COM_update_proof
      "member_wf"
      [1,1,2,2,1,1]
      (proof_step_hypothesis_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2,2]
      (proof_step_unhide_equality (nvar "t")),
    COM_update_proof
      "member_wf"
      [1,1,2,2,2,1]
      (proof_step_hypothesis_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2,3]
      (proof_step_unhide_equality (nvar "t")),
    COM_update_proof
      "member_wf"
      [1,1,2,2,3,1]
      (proof_step_hypothesis_equality),
    COM_find_holes "member_wf",
    COM_finish_proof "member_wf",

    (* We prove that Z is inhabited (by 17 here) *)
    COM_start_proof
      "int_member"
      mk_int
      (eq_refl, eq_refl),
    COM_update_proof
      "int_member"
      []
      (proof_step_introduction (mk_integer 17)),
    COM_update_proof
      "int_member"
      [1]
      (proof_step_integer_equality),
    COM_finish_proof "int_member",
    COM_find_holes "int_member",

    (* We prove that 'int_member' computes to 17 in 1 computation step *)
    COM_start_proof
      "int_member_cequiv"
      (mk_cequiv (mk_abs (opname2opabs "int_member") []) (mk_integer 17))
      (eq_refl, eq_refl),
    COM_update_proof
      "int_member_cequiv"
      []
      (proof_step_cequiv_computation 1),
    COM_find_holes "int_member_cequiv",
    COM_finish_proof "int_member_cequiv",

    (* We define a new abstraction on top of the one we got from "int_member"'s proof *)
    COM_add_def
      opabs_myint
      []
      (mk_simple_so_abs (opname2opabs "int_member"))
      (eq_refl, (eq_refl, (eq_refl, (eq_refl, eq_refl)))),

    (* We prove that 'myint' computes to 17 in 2 computation steps *)
    COM_start_proof
      "myint_cequiv"
      (mk_cequiv (mk_abs opabs_myint []) (mk_integer 17))
      (eq_refl, eq_refl),
    COM_update_proof
      "myint_cequiv"
      []
      (proof_step_cequiv_computation 2),
    COM_find_holes "myint_cequiv",
    COM_finish_proof "myint_cequiv",

    (* We prove once more that Z is inhabited.  We'll use our previous proof *)
    COM_start_proof
      "int_member_v2"
      mk_int
      (eq_refl, eq_refl),
    COM_update_proof
      "int_member_v2"
      []
      (proof_step_lemma "int_member"),
    COM_find_holes "int_member_v2",
    COM_finish_proof "int_member_v2",

    (* rename 'member' into 'MEMBER' *)
    COM_rename "member" "MEMBER"
  ].

Definition lib1 {o} : @UpdRes o := update_list_from_init cmds1.
Eval compute in lib1.

Time Eval compute in (update_list_from_init_with_validity cmds1).

(*
(*

***********************************************
                  TESTING
(compute wrapped in a Some below takes forever)
***********************************************

*)

Definition cmds2 {o} : @commands o :=
  [
    (* We prove that Z is inhabited (by 17 here) *)
    COM_start_proof
      "int_member"
      mk_int
      (eq_refl, eq_refl),
    COM_update_proof
      "int_member"
      []
      (proof_step_introduction (mk_integer 17)),
    COM_update_proof
      "int_member"
      [1]
      (proof_step_integer_equality),
    COM_finish_proof "int_member",
    COM_find_holes "int_member"
  ].

Definition lib2 {o} : @UpdRes o := update_list_from_init cmds2.

Eval compute in lib2.
Eval compute in (Library2ProofContext (upd_res_state lib2)).

Eval compute in (compute_atmost_k_steps
                   (Library2ProofContext (upd_res_state lib2))
                   1
                   (mk_abs (opname2opabs "int_member") [])).

Lemma reduces_to_of_compute_atmost_k_steps_if_eq {o} :
  forall lib k (t : @NTerm o) u,
    compute_atmost_k_steps lib k t = u
    -> reduces_to lib t u.
Proof.
  introv h; subst.
  apply reduces_to_of_compute_atmost_k_steps.
Qed.

Opaque reduces_to_of_compute_atmost_k_steps.

Eval compute in
    (@apply_proof_step_cequiv_computation
       _
       (Library2ProofContext (upd_res_state lib2))
       (mk_pre_bseq [] (pre_concl_ext
                          (mk_cequiv
                             (mk_abs (opname2opabs "int_member") [])
                             (mk_integer 17))))
       1).

Eval compute in
    (* this is fine *)
    (reduces_to_of_compute_atmost_k_steps [] 0 (mk_integer 1)).

Eval compute in
    (* the [Some] triggers the long computation!  WTF is going on? *)
    (Some (reduces_to_of_compute_atmost_k_steps [] 0 (mk_integer 1))).

Eval compute in
    (let ctxt := Library2ProofContext (upd_res_state lib2) in
     let a := mk_abs (opname2opabs "int_member") [] in
     let b := mk_integer 17 in
     let x := compute_atmost_k_steps ctxt 1 a in
(*     match term_dec_op x b with
     | Some p =>
*)
       Some (reduces_to_of_compute_atmost_k_steps ctxt 1 a)

(*       Some (reduces_to_of_compute_atmost_k_steps_if_eq ctxt 1 a b p)*)

     (*
                   Some ((*pre_proof_cequiv_computation
                           ctxt a b []*)
                           (eq_rect
                              _
                              _
                              (reduces_to_of_compute_atmost_k_steps ctxt 1 a)
                              _
                              p))*)

(*     | None => None
     end*)).
 *)


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L.Datatypes Require Export List.List_enc LNat LOptions LBool.

Set Default Proof Using "Type".

Definition c__ntherror := 15.
Definition nth_error_time (X : Type) (A : list X) (n : nat) := (min (length A) n + 1) * c__ntherror.
Instance termT_nth_error (X:Type) (Hx : encodable X): computableTime' (@nth_error X) (fun l _ => (5, fun n _ => (nth_error_time l n, tt))).
Proof.
  extract. solverec. all: unfold nth_error_time, c__ntherror; solverec.
Qed.

Definition c__length := 11.
Instance termT_length X `{encodable X} : computableTime' (@length X) (fun A _ => (c__length * (1 + |A|),tt)).
Proof.
extract. solverec. all: unfold c__length; solverec.
Qed.

Instance term_nth X (Hx : encodable X) : computableTime' (@nth X) (fun n _ => (5,fun l lT => (1,fun d _ => (n*20+9,tt)))).
Proof.
  extract.
  solverec.
Qed.

Instance term_repeat A `{encodable A}: computableTime' (@repeat A) (fun _ _ => (5, fun n _ => (n * 12 + 4,tt))).
Proof.
  extract. solverec.
Qed.

Section Fix_X.
  Context {X:Type} {intX : encodable X}.

  Variable X_eqb : X -> X -> bool.
  Hypothesis X_eqb_spec : (forall (x y:X), Bool.reflect (x=y) (X_eqb x y)).

  Definition pos_nondec :=
    fix pos_nondec (eqb: X -> X -> bool) (s : X) (A : list X) {struct A} : option nat :=
      match A with
      | [] => None
      | a :: A0 =>
        if eqb s a
        then Some 0
        else match pos_nondec eqb s A0 with
            | Some n => Some (S n)
            | None => None
            end
      end.

  Lemma pos_nondec_spec (x:X) `{eq_dec X} A: pos_nondec X_eqb x A = pos x A.
  Proof using X_eqb_spec.
    induction A;[reflexivity|];cbn.
    rewrite IHA. destruct (X_eqb_spec x a); repeat (destruct _; try congruence).
  Defined. (* because other extract *)

  Global Instance term_pos_nondec:
    computable pos_nondec.
  Proof.
    extract.
  Defined. (* because other extract *)
End Fix_X.


Add LoadPath "../metatheory".
Require Export F_init.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let C := gather_atoms_with (fun x : typing_env => dom x) in
  let D1 := gather_atoms_with (fun x => fv_term x) in
  let D2 := gather_atoms_with (fun x => ftv_typ x) in
  let D3 := gather_atoms_with (fun x => ftv_term x) in
  constr:(A \u B \u C \u D1 \u D2 \u D3).

(** Mutual induction principles *)
Scheme pval_mut_ind_aux := Induction for pval Sort Prop
with   val_mut_ind_aux  := Induction for val  Sort Prop.
Combined Scheme pval_val_mut_ind from pval_mut_ind_aux, val_mut_ind_aux.

Scheme wfenv_mut_ind_aux := Induction for wfenv Sort Prop
with   wftyp_mut_ind_aux := Induction for wftyp Sort Prop.
Combined Scheme wfenv_wftyp_mut_ind from
  wfenv_mut_ind_aux, wftyp_mut_ind_aux.

(** Administrative lemmas *)
Lemma pval_val_regular :
  (forall p, pval p → lc_term p) ∧ (forall v, val v → lc_term v).
Proof.
apply pval_val_mut_ind; eauto.
Qed.

Lemma pval_regular : forall p, pval p → lc_term p.
Proof.
intros; destruct pval_val_regular as [H1 _]; auto.
Qed.

Lemma val_regular : forall v, val v → lc_term v.
Proof.
intros; destruct pval_val_regular as [_ H2]; auto.
Qed.
Hint Resolve pval_regular val_regular.

Lemma red0_regular1 : forall e e', red0 e e' → lc_term e.
Proof.
intros e e' H. destruct H; auto.
Qed.

Lemma red0_regular2 : forall e e', red0 e e' → lc_term e'.
Proof.
intros e e' H; destruct H; eauto with lngen.
Qed.
Hint Resolve red0_regular1 red0_regular2.

Lemma red1_regular1 : forall e e', e ⇝ e' → lc_term e.
Proof.
intros e e' H. induction H; eauto.
Qed.

Lemma red1_regular2 : forall e e', e ⇝ e' → lc_term e'.
Proof.
intros e e' H; induction H; eauto.
Qed.
Hint Resolve red1_regular1 red1_regular2.

Lemma wftyp_regular : forall Γ τ, wftyp Γ τ → lc_typ τ.
Proof.
intros Γ τ H.
induction H; eauto.
Qed.
Hint Resolve wftyp_regular.

Lemma wfenv_wftyp_aux :
  (forall Γ, wfenv Γ → forall Γ₁ x τ, Γ = x ~ (Some τ) ++ Γ₁ → wftyp Γ₁ τ) ∧
  (forall Γ τ, wftyp Γ τ → wfenv Γ).
Proof.
apply wfenv_wftyp_mut_ind; intros; eauto.
inversion H.
inversion H0; subst; auto.
inversion H0.
pick fresh a; assert (a ~ None ++ G ⊢ ok) by auto; inversion H0; subst; auto.
Qed.

Lemma wfenv_wftyp :
forall Γ₁ Γ₂ x τ, wfenv (Γ₁ ++ x ~ Some τ ++ Γ₂) → wftyp Γ₂ τ.
Proof.
destruct wfenv_wftyp_aux as [H1 H2].
intros Γ₁ Γ₂ x τ H0.
generalize dependent Γ₂.
induction Γ₁; intros; simpl_env in H0; eauto.
inversion H0; subst; simpl_env in H5; eauto.
Qed.
Hint Resolve wfenv_wftyp.

Lemma wftyp_wfenv : forall Γ τ, wftyp Γ τ → wfenv Γ.
Proof.
destruct wfenv_wftyp_aux; auto.
Qed.
Hint Resolve wftyp_wfenv.

Lemma wfenv_wftyp_uniq_aux :
  (forall Γ, wfenv Γ → uniq Γ) ∧ (forall Γ τ, wftyp Γ τ → uniq Γ).
Proof.
apply wfenv_wftyp_mut_ind; intros; auto.
pick fresh a. assert (uniq (a ~ None ++ G)) by auto. destruct_uniq; auto.
Qed.

Lemma wfenv_uniq : forall Γ, wfenv Γ → uniq Γ.
Proof.
destruct wfenv_wftyp_uniq_aux; auto.
Qed.
Hint Resolve wfenv_uniq.

Lemma wftyp_uniq :  forall Γ τ, wftyp Γ τ → uniq Γ.
Proof.
eauto.
Qed.
Hint Resolve wftyp_uniq.

(** Lemmas about [wfenv] and [wftyp] *)
Lemma wfenv_wftyp_weakening :
(forall Γ, wfenv Γ → forall Γ₁ Γ₂ Γ₃, Γ = Γ₁ ++ Γ₃ → wfenv (Γ₂ ++ Γ₃) → disjoint Γ₁ Γ₂ → wfenv (Γ₁ ++ Γ₂ ++ Γ₃))
∧
(forall Γ τ, wftyp Γ τ → forall Γ₁ Γ₂ Γ₃, Γ = Γ₁ ++ Γ₃ → wfenv (Γ₂ ++ Γ₃) → disjoint Γ₁ Γ₂ → wftyp (Γ₁ ++ Γ₂ ++ Γ₃) τ).
Proof.
apply wfenv_wftyp_mut_ind; intros; auto.
Case "wfenv_empty".
destruct Γ₁. destruct Γ₃. simpl_env in *; auto.
simpl in H; inversion H.
simpl in H; inversion H.
Case "wfenv_cons_x".
destruct Γ₁; simpl_env in *.
destruct Γ₃; simpl_env in *; auto.
inversion H0; subst.
apply wfenv_cons_x.
simpl in H2; apply disjoint_cons_1 in H2; auto.
apply H; auto.
simpl in H2; apply disjoint_cons_2 in H2; auto.
Case "wfenv_cons_a".
destruct Γ₁; simpl_env in *.
destruct Γ₃; simpl_env in *; auto.
inversion H0; subst.
apply wfenv_cons_a.
simpl in H2; apply disjoint_cons_1 in H2; auto.
apply H; auto.
simpl in H2; apply disjoint_cons_2 in H2; auto.
Case "wftyp_var".
subst G; analyze_binds b.
Case "wftyp_forall".
subst G; apply wftyp_forall with (L := L ∪ dom Γ₂); intros.
rewrite_env ((a~None ++ Γ₁) ++ Γ₂ ++ Γ₃); apply H; eauto.
Qed.

Lemma wfenv_weakening :
forall Γ₁ Γ₂ Γ₃, wfenv (Γ₁ ++ Γ₃) → wfenv (Γ₂ ++ Γ₃) → disjoint Γ₁ Γ₂ → wfenv (Γ₁ ++ Γ₂ ++ Γ₃).
Proof.
destruct wfenv_wftyp_weakening as [H1 H2].
intros; apply (H1 (Γ₁ ++ Γ₃)); auto.
Qed.

Lemma wftyp_weakening :
forall Γ₁ Γ₂ Γ₃ τ, wftyp (Γ₁ ++ Γ₃) τ → wfenv (Γ₂ ++ Γ₃) → disjoint Γ₁ Γ₂ → wftyp (Γ₁ ++ Γ₂ ++ Γ₃) τ.
Proof.
destruct wfenv_wftyp_weakening as [H1 H2].
intros. apply (H2 (Γ₁ ++ Γ₃)); auto.
Qed.

Lemma wfenv_wftyp2 :
forall Γ x τ, wfenv Γ → binds x (Some τ) Γ → wftyp Γ τ.
Proof.
intro Γ; induction Γ; intros.
analyze_binds H0.
destruct a; destruct o; simpl_env in *; analyze_binds H0.
replace t with τ in * by congruence.
rewrite_env (nil ++ a ~ Some τ ++ Γ).
inversion H; subst.
apply wftyp_weakening; auto.
rewrite_env (nil ++ a ~ Some t ++ Γ).
apply wftyp_weakening; auto. simpl.
inversion H; subst. eapply IHΓ; eauto.
rewrite_env (nil ++ a ~ None ++ Γ).
apply wftyp_weakening; auto.
inversion H; subst. eapply IHΓ; eauto.
Qed.
Hint Resolve wfenv_wftyp2.

Lemma wfenv_wftyp3 :
forall Γ x τ, wfenv (x ~ Some τ ++ Γ) → wftyp Γ τ.
Proof.
intros Γ x τ H; inversion H; subst; auto.
Qed.
Hint Resolve wfenv_wftyp3.

Lemma wfenv_regular :
forall Γ x τ, wfenv Γ → binds x (Some τ) Γ → lc_typ τ.
Proof.
intros. induction H; analyze_binds H0.
replace t with τ in * by congruence; eauto.
eauto.
Qed.
Hint Resolve wfenv_regular.

Lemma wftyp_regular2 : forall Γ x τ τ',
  wftyp (x ~ Some τ ++ Γ) τ' → lc_typ τ.
Proof.
intros Γ x τ τ' H. eauto.
Qed.
Hint Resolve wftyp_regular2.

Lemma wfenv_wftyp_subst :
  (forall Γ, wfenv Γ → forall Γ₁ Γ₂ x τ, Γ = Γ₁ ++ x ~ (Some τ) ++ Γ₂ → wfenv (Γ₁ ++ Γ₂)) ∧
  (forall Γ τ, wftyp Γ τ → forall Γ₁ Γ₂ x τ', Γ = Γ₁ ++ x ~ (Some τ') ++ Γ₂ → wftyp (Γ₁ ++ Γ₂) τ).
Proof.
apply wfenv_wftyp_mut_ind; intros.
Case "wfenv_empty".
assert (binds x (Some τ) nil). rewrite H; auto. analyze_binds H0.
Case "wfenv_cons_x".
destruct Γ₁; simpl_env in *.
inversion H0; subst; eauto.
destruct p; destruct o; inversion H0; subst; simpl_env in *.
constructor; eauto.
Case "wfenv_cons_a".
destruct Γ₁; simpl_env in *.
inversion H0; subst; eauto.
destruct p; destruct o; inversion H0; subst; simpl_env in *.
constructor; eauto.
Case "wftyp_var".
subst G. constructor. analyze_binds b. eauto.
Case "wftyp_arrow".
subst G. constructor; eauto.
Case "wftyp_forall".
subst G. econstructor; intros.
rewrite_env (([(a, None)] ++ Γ₁) ++ Γ₂). eapply H; simpl_env; eauto.
Qed.

Lemma wfenv_subst :
forall Γ₁ Γ₂ x τ, wfenv (Γ₁ ++ x ~ (Some τ) ++ Γ₂) → wfenv (Γ₁ ++ Γ₂).
Proof.
destruct wfenv_wftyp_subst as [H1 H2].
intros Γ₁ Γ₂ x τ H. eapply H1; eauto.
Qed.
Hint Resolve wfenv_subst.

Lemma wftyp_subst :
forall Γ₁ Γ₂ τ x τ', wftyp (Γ₁ ++ x ~ (Some τ') ++ Γ₂) τ → wftyp (Γ₁ ++ Γ₂) τ.
Proof.
destruct wfenv_wftyp_subst as [H1 H2].
intros. eapply H2; eauto.
Qed.
Hint Resolve wftyp_subst.

Lemma wfenv_wftyp_tsubst :
  (forall Γ, wfenv Γ → forall Γ₁ Γ₂ a τ, Γ = Γ₁ ++ a ~ None ++ Γ₂ → wftyp Γ₂ τ → wfenv ((env_map (tsubst_typ τ a) Γ₁) ++ Γ₂)) ∧
  (forall Γ τ, wftyp Γ τ → forall Γ₁ Γ₂ a τ', Γ = Γ₁ ++ a ~ None ++ Γ₂ → wftyp Γ₂ τ' → wftyp ((env_map (tsubst_typ τ' a) Γ₁) ++ Γ₂) (tsubst_typ τ' a τ)).
Proof.
apply wfenv_wftyp_mut_ind; intros.
Case "wfenv_empty".
assert (binds a (@None typ) nil). rewrite H; auto. analyze_binds H1.
Case "wfenv_cons_x".
destruct Γ₁; simpl_env in *.
inversion H0; subst; eauto.
destruct p; destruct o; inversion H0; subst; simpl_env in *.
simpl; simpl_env.
constructor. unfold env_map; auto. eapply H; auto.
Case "wfenv_cons_a".
destruct Γ₁; simpl_env in *.
inversion H0; subst; eauto.
destruct p; destruct o; inversion H0; subst; simpl_env in *.
simpl; simpl_env.
constructor. unfold env_map; auto. eapply H; auto.
Case "wftyp_var".
subst G. simpl.
destruct (a == a0); subst.
rewrite_env (nil ++ env_map (tsubst_typ τ' a0) Γ₁ ++ Γ₂); apply wftyp_weakening; auto.
constructor; auto.
analyze_binds b;
replace (@None typ) with (option_map (tsubst_typ τ' a0) None) by reflexivity;
unfold env_map; auto.
Case "wftyp_arrow".
subst G. simpl; constructor; auto.
Case "wftyp_forall".
subst G. simpl; apply wftyp_forall with (L := L ∪ {{a}}); intros.
rewrite_env (([(a0, None)] ++ env_map (tsubst_typ τ' a) Γ₁) ++ Γ₂).
replace ([(a0, None)] ++ env_map (tsubst_typ τ' a) Γ₁) with (env_map (tsubst_typ τ' a) ([(a0, None)] ++ Γ₁)) by reflexivity.
replace (typ_var_f a0) with (tsubst_typ τ' a (typ_var_f a0)).
rewrite <- tsubst_typ_open_typ_wrt_typ.
eapply H; simpl_env; eauto. eauto.
autorewrite with lngen; auto.
Qed.

Lemma wfenv_tsubst :
  forall Γ₁ Γ₂ a τ, wfenv (Γ₁ ++ a ~ None ++ Γ₂) → wftyp Γ₂ τ →
    wfenv (env_map (tsubst_typ τ a) Γ₁ ++ Γ₂).
Proof.
destruct wfenv_wftyp_tsubst as [H1 H2].
intros Γ₁ Γ₂ x τ H. eapply H1; eauto.
Qed.
Hint Resolve wfenv_tsubst.

Lemma wftyp_tsubst :
forall Γ₁ Γ₂ τ a τ', wftyp (Γ₁ ++ a ~ None ++ Γ₂) τ →
wftyp Γ₂ τ' → wftyp (env_map (tsubst_typ τ' a) Γ₁ ++ Γ₂) (tsubst_typ τ' a τ).
Proof.
destruct wfenv_wftyp_tsubst as [H1 H2].
intros. eapply H2; eauto.
Qed.
Hint Resolve wftyp_tsubst.

Lemma wftyp_fv : forall Γ τ, wftyp Γ τ → ftv_typ τ [<=] dom Γ.
Proof.
intros Γ τ H. induction H; simpl in *; try fsetdec.
assert (a ∈ dom G) by eauto; fsetdec.
pick fresh a.
assert (ftv_typ (open_typ_wrt_typ t (typ_var_f a))[<=]add a (dom G)) by auto.
assert (ftv_typ t [<=] ftv_typ (open_typ_wrt_typ t (typ_var_f a))); auto with lngen.
fsetdec.
Qed.
Hint Resolve wftyp_fv.

(** Lemmas about [wfterm] *)
Lemma wfterm_wfenv : forall Γ e τ,
  wfterm Γ e τ → wfenv Γ.
Proof.
intros Γ e τ H.
induction H; auto.
pick fresh x; assert (wfenv ([(x, Some t1)] ++ G)) by auto; inversion H1; subst; eauto.
pick fresh a; assert (wfenv ([(a, None)] ++ G)) by auto; inversion H1; subst; eauto.
Qed.
Hint Resolve wfterm_wfenv.

Lemma wfterm_wftyp : forall Γ e τ,
  wfterm Γ e τ → wftyp Γ τ.
Proof.
intros Γ e τ H.
induction H.
Case "var". eapply wfenv_wftyp2; eauto.
Case "app". inversion IHwfterm1; subst; auto.
Case "abs". pick fresh x. assert ([(x, Some t1)] ++ G ⊢ t2 ok) by auto.
assert (wfenv ([(x, Some t1)] ++ G)) by eauto.
inversion H2; subst.
constructor; auto. rewrite_env (nil ++ G). eauto.
Case "inst". inversion IHwfterm; subst.
inversion IHwfterm; subst.
pick fresh a. rewrite tsubst_typ_intro with (a1 := a); auto.
rewrite_env (env_map (tsubst_typ t a) nil ++ G).
apply wftyp_tsubst; simpl_env; auto.
Case "gen".
apply wftyp_forall with (L := L); auto.
Qed.
Hint Resolve wfterm_wftyp.

Lemma wfterm_regular2 : forall Γ e τ,
  wfterm Γ e τ → lc_typ τ.
Proof.
intros Γ e τ H; induction H; eauto.
Qed.
Hint Resolve wfterm_regular2.

Lemma wfterm_regular1 : forall Γ e τ,
  wfterm Γ e τ → lc_term e.
Proof.
intros Γ e τ H; induction H; auto.
pick fresh x.
apply lc_term_abs_exists with (x1 := x).
apply wfenv_regular with (Γ := [(x, Some t1)] ++ G) (x := x); eauto.
auto.
eauto.
Qed.
Hint Resolve wfterm_regular1.

Lemma wfterm_env_uniq : forall Γ e τ,
  wfterm Γ e τ → uniq Γ.
Proof.
intros Γ e τ H. eauto.
Qed.
Hint Resolve wfterm_env_uniq.

(** Lemmas about values *)
Lemma value_is_normal_aux :
  (forall v, pval v → ~ exists e, v ⇝ e) ∧
  (forall v, val v → ~ exists e, v ⇝ e).
Proof.
apply pval_val_mut_ind; intros; intros [e0 Hred]; inversion Hred; subst; eauto.
inversion H.
inversion H1; subst. inversion p.
inversion H0; subst. inversion p.
inversion H0.
pick fresh x. eapply H; eauto.
inversion H0.
pick fresh a. eapply H; eauto.
Qed.

Lemma value_is_normal : forall v, val v → ~ exists e, v ⇝ e.
Proof.
destruct value_is_normal_aux as [_ Th]. intuition auto.
Qed.

(** Renaming lemmas *)
Lemma pval_val_renaming : forall x y,
  (forall v, pval v → pval (subst_term (term_var_f y) x v)) ∧
  (forall v, val v → val (subst_term (term_var_f y) x v)).
Proof.
intros x y.
apply pval_val_mut_ind; intros; simpl; auto.
Case "var". destruct (x0 == x); auto.
Case "abs". pick fresh z and apply val_abs; auto.
  rewrite subst_term_open_term_wrt_term_var; auto.
Case "gen". pick fresh a and apply val_gen; auto.
  rewrite subst_term_open_term_wrt_typ_var; auto.
Qed.

Lemma val_renaming : forall x y v,
  val v → val (subst_term (term_var_f y) x v).
Proof.
intros x y v H. destruct (pval_val_renaming x y); auto.
Qed.
Hint Resolve val_renaming.

Lemma pval_val_trenaming : forall a b,
  (forall v, pval v → pval (tsubst_term (typ_var_f b) a v)) ∧
  (forall v, val v → val (tsubst_term (typ_var_f b) a v)).
Proof.
intros a b.
apply pval_val_mut_ind; intros; simpl; auto with lngen.
Case "abs". pick fresh z and apply val_abs; auto with lngen.
  rewrite tsubst_term_open_term_wrt_term_var; auto.
Case "gen". pick fresh c and apply val_gen; auto.
  rewrite tsubst_term_open_term_wrt_typ_var; auto.
Qed.

Lemma val_trenaming : forall a b v,
  val v → val (tsubst_term (typ_var_f b) a v).
Proof.
intros a b v H. destruct (pval_val_trenaming a b); auto.
Qed.
Hint Resolve val_trenaming.

(** Lemmas about red0, red1 *)
Lemma red0_subst : forall x e'' e e', lc_term e'' → red0 e e' →
  red0 (subst_term e'' x e) (subst_term e'' x e').
Proof.
intros x e'' e e' Hlc H.
inversion H; subst; simpl.
rewrite subst_term_open_term_wrt_term; auto. apply red0_beta; auto with lngen.
assert (lc_term (subst_term e'' x (term_abs t e1))) by auto with lngen; auto.
rewrite subst_term_open_term_wrt_typ; auto. apply red0_beta_t; auto with lngen.
assert (lc_term (subst_term e'' x (term_gen e0))) by auto with lngen; auto.
Qed.
Hint Resolve red0_subst.

Lemma red1_subst : forall x e'' e e', lc_term e'' → e ⇝ e' →
  (subst_term e'' x e) ⇝ (subst_term e'' x e').
Proof.
intros x e'' e e' Hlc H.
induction H; subst; simpl; auto with lngen.
apply red1_abs with (L := L `union` {{x}}); auto; intros z Hz.
replace (term_var_f z) with (subst_term e'' x (term_var_f z)) by auto with lngen.
repeat rewrite <- subst_term_open_term_wrt_term; eauto.
apply red1_gen with (L := L `union` {{x}}); intros a Ha.
repeat rewrite <- subst_term_open_term_wrt_typ; eauto.
Qed.
Hint Resolve red1_subst.

Lemma red1_open : forall L e'' e e',
  lc_term e'' →
  (forall x, x ∉ L → e ^ x ⇝ e' ^ x) →
  e ^^ e'' ⇝ e' ^^ e''.
Proof.
intros L e'' e e' Hlc H.
pick fresh x.
rewrite subst_term_intro with (x1 := x) (e1 := e); auto.
rewrite subst_term_intro with (x1 := x) (e1 := e'); auto.
Qed.
Hint Resolve red1_open.

Lemma red0_tsubst : forall a τ e e', lc_typ τ → red0 e e' →
  red0 (tsubst_term τ a e) (tsubst_term τ a e').
Proof.
intros a τ e e' Hlc H.
inversion H; subst; simpl.
rewrite tsubst_term_open_term_wrt_term; auto. apply red0_beta; auto with lngen.
assert (lc_term (tsubst_term τ a (term_abs t e1))) by auto with lngen; auto.
rewrite tsubst_term_open_term_wrt_typ; auto. apply red0_beta_t; auto with lngen.
assert (lc_term (tsubst_term τ a (term_gen e0))) by auto with lngen; auto.
Qed.
Hint Resolve red0_tsubst.

Lemma red1_tsubst : forall a τ e e', lc_typ τ → e ⇝ e' →
  (tsubst_term τ a e) ⇝ (tsubst_term τ a e').
Proof.
intros a τ e e' Hlc H.
induction H; subst; simpl; auto with lngen.
apply red1_abs with (L := L `union` {{a}}); auto with lngen ; intros z Hz.
replace (term_var_f z) with (tsubst_term τ a (term_var_f z)) by reflexivity.
repeat rewrite <- tsubst_term_open_term_wrt_term; eauto.
apply red1_gen with (L := L `union` {{a}}); intros b Hb.
replace (typ_var_f b) with (tsubst_typ τ a (typ_var_f b)) by auto with lngen.
repeat rewrite <- tsubst_term_open_term_wrt_typ; eauto.
Qed.
Hint Resolve red1_tsubst.

Lemma red1_topen : forall L τ e e',
  lc_typ τ →
  (forall a, a ∉ L → open_term_wrt_typ e (typ_var_f a) ⇝ open_term_wrt_typ e' (typ_var_f a)) →
  open_term_wrt_typ e τ ⇝ open_term_wrt_typ e' τ.
Proof.
intros L τ e e' Hlc H.
pick fresh a.
rewrite tsubst_term_intro with (a1 := a) (e1 := e); auto.
rewrite tsubst_term_intro with (a1 := a) (e1 := e'); auto.
Qed.
Hint Resolve red1_topen.

(*
(* Lemmas about wfterm *)
Lemma wfterm_fv : forall Γ e τ,
  wfterm Γ e τ → fv_term e [<=] dom Γ.
Proof.
intros Γ e τ H. induction H; simpl fv_term in *.
assert (x ∈ dom G) by eauto; fsetdec.
fsetdec.
pick fresh x. assert (fv_term (e ^ x) [<=] dom (x ~ t1 ++ G)) by auto.
assert (fv_term e [<=] fv_term (e ^ x)) by auto with lngen.
assert (fv_term e [<=] {{x}} ∪ dom G). simpl in *; fsetdec.
fsetdec.
Qed.
*)

Lemma wfterm_uniqueness : forall Γ e τ τ',
  wfterm Γ e τ → wfterm Γ e τ' → τ = τ'.
Proof.
intros Γ e τ τ' H1 H2. generalize dependent τ'.
induction H1; intros τ' H2; inversion H2; subst.
Case "var".
assert (Some t = Some τ'). eapply binds_unique; eauto. congruence.
Case "app".
assert (typ_arrow t2 t1 = typ_arrow t3 τ') by auto; congruence.
Case "abs".
pick fresh x; assert (t2 = t3) by eauto; congruence.
Case "inst".
assert (typ_forall t' = typ_forall t'0) by auto; congruence.
Case "gen".
pick fresh a. assert (open_typ_wrt_typ t (typ_var_f a) = open_typ_wrt_typ t0 (typ_var_f a)) by auto.
f_equal; eapply open_typ_wrt_typ_inj; eauto.
Qed.

(*
Lemma wfterm_strengthening : forall Γ₁ Γ₂ x τ τ' e,
  x ∉ fv_term e →
  wfterm (Γ₁ ++ x ~ τ' ++ Γ₂) e τ →
  wfterm (Γ₁ ++ Γ₂) e τ.
Proof.
intros Γ₁ Γ₂ x τ τ' e Hx He.
dependent induction He; simpl in Hx.
Case "var".
constructor. solve_uniq. analyze_binds_uniq H0.
Case "app".
econstructor; eauto.
Case "abs".
apply wfterm_abs with (L := L `union` {{x}}); intros.
rewrite_env (([(x0, t1)] ++ Γ₁) ++ Γ₂).
eapply H0 with (x1 := x); auto.
assert (fv_term (e ^ x0) [<=] fv_term (term_var_f x0) ∪ fv_term e) as H2
 by auto with lngen.
simpl in H2; fsetdec.
simpl_env; eauto.
Qed.
*)

(** Major lemmas about [wfterm] *)
Lemma wfterm_weakening : forall Γ₁ Γ₂ Γ₃ e τ,
  wfterm (Γ₁ ++ Γ₃) e τ →
  wfenv (Γ₂ ++ Γ₃) →
  disjoint Γ₁ Γ₂ →
  wfterm (Γ₁ ++ Γ₂ ++ Γ₃) e τ.
Proof.
intros Γ₁ Γ₂ Γ₃ e τ H. dependent induction H; intros; eauto.
Case "var".
constructor. auto using wfenv_weakening. analyze_binds H0.
Case "abs". pick fresh x and apply wfterm_abs.
rewrite_env (([(x, Some t1)] ++ Γ₁) ++ Γ₂ ++ Γ₃).
apply H0; simpl_env; auto.
Case "inst". constructor. auto using wftyp_weakening. eauto.
Case "gen". pick fresh a and apply wfterm_gen.
rewrite_env (([(a, None)] ++ Γ₁) ++ Γ₂ ++ Γ₃).
apply H0; simpl_env; auto.
Qed.

Lemma wfterm_subst : forall Γ₁ Γ₂ x τ₁ τ₂ e₁ e₂,
  wfterm (Γ₁ ++ x ~ Some τ₂ ++ Γ₂) e₁ τ₁ →
  wfterm Γ₂ e₂ τ₂ →
  wfterm (Γ₁ ++ Γ₂) (subst_term e₂ x e₁) τ₁.
Proof with eauto.
intros Γ₁ Γ₂ x τ₁ τ₂ e₁ e₂ H. dependent induction H; intro; simpl...
Case "var".
  destruct (x == x0); subst.
  SCase "x = x0".
    analyze_binds_uniq H0; apply wfterm_weakening with (Γ₁ := nil); auto.
    replace t with τ₂ by congruence; auto.
    eapply wfenv_subst; eauto.
  SCase "x <> x0".
    analyze_binds_uniq H0...
Case "abs".
  pick fresh z and apply wfterm_abs.
  rewrite_env ((z ~ Some t1 ++ Γ₁) ++ Γ₂).
  rewrite subst_term_open_term_wrt_term_var...
  apply H0 with (τ₂0 := τ₂)...
Case "gen".
  pick fresh a and apply wfterm_gen.
  rewrite_env ((a ~ None ++ Γ₁) ++ Γ₂).
  rewrite subst_term_open_term_wrt_typ_var...
  apply H0 with (τ₂0 := τ₂)...
Qed.

Lemma wfterm_tsubst : forall Γ₁ Γ₂ a τ₁ e₁ τ₂,
  wfterm (Γ₁ ++ a ~ None ++ Γ₂) e₁ τ₁ →
  wftyp Γ₂ τ₂ →
  wfterm (env_map (tsubst_typ τ₂ a) Γ₁ ++ Γ₂) (tsubst_term τ₂ a e₁) (tsubst_typ τ₂ a τ₁).
Proof with eauto.
intros Γ₁ Γ₂ a τ₁ e₁ τ₂ H. dependent induction H; intro; simpl...
Case "var".
constructor. auto using wfenv_tsubst.
replace (Some (tsubst_typ τ₂ a t)) with (option_map (tsubst_typ τ₂ a) (Some t)) by reflexivity.
unfold env_map. analyze_binds H0.
simpl.
assert (a ∉ ftv_typ t).
  assert (ftv_typ t [<=] dom Γ₂) by eauto.
  assert (uniq (Γ₁ ++ [(a, None)] ++ Γ₂)) by auto.
  destruct_uniq. fsetdec.
autorewrite with lngen; auto.
Case "app".
econstructor.
eapply IHwfterm1; auto.
eapply IHwfterm2; auto.
Case "abs".
  pick fresh z and apply wfterm_abs.
  rewrite_env (env_map (tsubst_typ τ₂ a) ([(z, Some t1)] ++ Γ₁) ++ Γ₂).
  rewrite tsubst_term_open_term_wrt_term_var...
Case "inst".
  rewrite tsubst_typ_open_typ_wrt_typ...
  constructor; auto. apply IHwfterm; auto.
Case "gen".
  pick fresh b and apply wfterm_gen.
  rewrite_env (env_map (tsubst_typ τ₂ a) ([(b, None)] ++ Γ₁) ++ Γ₂).
  rewrite tsubst_term_open_term_wrt_typ_var...
  rewrite tsubst_typ_open_typ_wrt_typ_var...
Qed.

(** Soundness *)
Theorem subject_reduction : forall Γ e e' τ,
  wfterm Γ e τ → e ⇝ e' → wfterm Γ e' τ.
Proof with eauto.
  intros Γ e e' τ H. generalize dependent e'.
  dependent induction H.
  Case "var".
    intros e' J; inversion J; subst; inversion H1.
  Case "app".
    intros e' J; inversion J; subst...
    inversion H; subst; inversion H1; subst.
    pick fresh z.
    rewrite (subst_term_intro z)...
    eapply wfterm_subst with (Γ₁ := nil); simpl_env...
  Case "abs".
    intros e' J; inversion J; subst.
    inversion H1.
    pick fresh z and apply wfterm_abs...
  Case "inst".
    intros e' J; inversion J; subst; auto.
    inversion H1; subst.
    inversion H0; subst.
    pick fresh a.
    rewrite (tsubst_term_intro a)...
    rewrite (tsubst_typ_intro a)...
    rewrite_env (env_map (tsubst_typ t a) nil ++ G).
    eapply wfterm_tsubst; simpl_env...
  Case "gen".
    intros e' J; inversion J; subst.
    inversion H1.
    pick fresh a and apply wfterm_gen...
Qed.

Theorem progress : forall Γ e τ,
  wfterm Γ e τ →
  (exists e', e ⇝ e') ∨ val e.
Proof with eauto.
  intros Γ e τ H.
  dependent induction H; simpl...
  Case "typing_app".
    destruct IHwfterm1 as [[e1' ?] | ?]...
    destruct IHwfterm2 as [[e2' ?] | ?]...
    destruct e1; simpl in H1; inversion H1; subst; try solve [inversion H]; eauto 7.
  Case "abs".
    pick fresh z. edestruct (H0 z) as [[e1 ?] | ?]...
    left.
      exists (term_abs t1 (close_term_wrt_term z e1)).
      apply red1_abs with (L := L `union` {{z}}); intros...
      rewrite <- subst_term_spec.
      rewrite (subst_term_intro z)...
    right.
      apply val_abs with (L := L `union` {{z}}); intros...
      rewrite (subst_term_intro z)...
  Case "inst".
    destruct IHwfterm as [[e' ? ] | ? ]...
    destruct e; simpl in H1; inversion H1; subst; eauto.
    inversion H0.
    eauto 7.
  Case "gen".
    pick fresh a. edestruct (H0 a) as [[e1 ?] | ?]...
    left.
      exists (term_gen (close_term_wrt_typ a e1)).
      apply red1_gen with (L := L `union` {{a}}); intros.
      rewrite <- tsubst_term_spec.
      rewrite (tsubst_term_intro a)...
    right.
      apply val_gen with (L := L `union` {{a}}); intros.
      rewrite (tsubst_term_intro a)...
Qed.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.reals.fast.CRcorrect.
Require Export CoRN.model.metric2.CRmetric.
Require Export CoRN.algebra.CSetoids.
Require Import CoRN.tactics.CornTac.

#[global]
Instance CR_default : @DefaultRelation CR (@msp_eq CR) | 2 := {}.

(**
** Example of a setoid: [CR]
*** [CR]
*)

Lemma CRisCSetoid : is_CSetoid CR (@msp_eq CR) CRapartT.
Proof.
 split;simpl.
    intros x H.
    eapply ap_irreflexive.
    apply CR_ap_as_Cauchy_IR_ap_1.
    apply H.
   intros x y H.
   apply CR_ap_as_Cauchy_IR_ap_2.
   eapply ap_symmetric.
   apply CR_ap_as_Cauchy_IR_ap_1.
   apply H.
  intros x y H1 z.
  destruct (ap_cotransitive _ _ _ (CR_ap_as_Cauchy_IR_ap_1 _ _ H1) (CRasCauchy_IR z));[left|right];
    apply CR_ap_as_Cauchy_IR_ap_2; assumption.
 intros x y.
 change (Not (CRapartT x y)<->(x==y)%CR).
 rewrite <- CR_eq_as_Cauchy_IR_eq.
 destruct (ap_tight _ (CRasCauchy_IR x) (CRasCauchy_IR y)) as [A B].
 split.
  intros H.
  apply A.
  intros X.
  apply H.
  apply CR_ap_as_Cauchy_IR_ap_2.
  assumption.
 intros H X.
 apply (B H).
 apply CR_ap_as_Cauchy_IR_ap_1.
 apply X.
Qed.

Definition CRasCSetoid : CSetoid := makeCSetoid (msp_as_RSetoid CR) _ CRisCSetoid.

Canonical Structure CRasCSetoid.