(** Formalization of a Predicative System F

In this file, we state and prove meta-properties about our language,
in particular regularity and narrowing. *)

Require Import Arith.
Require Import Omega.

Add LoadPath ".".

(* Use [make SysF.vo] to compile SysF.v before executing this line. *)
Require Import SysF.

(** This lemma states cumulativity. That is, that when a type has been
    assigned a kind, any kind above it in the kind hierarchy is also
    a valid kind for the type. *)
Lemma cumulativity : forall (e : env) (T : typ) (K : kind),
                     kinding e T K -> forall K', K <= K' -> kinding e T K'.
  do 4 intro.
  induction H.
  - intros.
    assert (Kp <= K') by omega.
    eauto using k_tvar.
  - intros.
    destruct K'.
    + inversion H0.
    + assert (max Kp Kq <= K') by omega.
      assert (max K' Kq = K') by eauto with arith.
      rewrite <- H2.
      eauto using k_tall with arith.
  - intros.
    assert (Kp <= max Kp Kq /\ Kq <= max Kp Kq) by auto with arith.
    assert (max K' K' = K') by auto with arith.
    rewrite <- H3.
    destruct H2.
    apply k_tarr; [ eauto using le_trans .. ]. (* TODO just eauto using k_tarr, le_trans doesn't work *)
Qed.

(** [insert_kind pos K e e'] is a logical predicate that says that
    [e'] is the environmnent obtained from [e] by inserting kind [K]
    at position [pos]. *)
Inductive insert_kind : nat -> kind -> env -> env -> Prop :=
| ik_top K e :
    insert_kind 0 K e (etvar K e)
| ik_evar pos K T e e' :
    insert_kind pos K e e' ->
    insert_kind pos K (evar T e) (evar (tshift pos T) e')
| ik_etvar pos K K' e e' :
    insert_kind pos K e e' ->
    insert_kind (S pos) K (etvar K' e) (etvar K' e')
.

Lemma shift_var_s : forall var shift,
                      (if le_gt_dec (S shift) (S var) then S (S var) else S var) =
                      S (if le_gt_dec shift var then S var else var).
  intros.
  induction var.
  - destruct shift; [ auto .. ].
  - destruct (le_gt_dec shift var) eqn:shift_le_var,
             (le_gt_dec (S shift) (S (S var))) eqn:Sshift_le_SSvar,
             (le_gt_dec shift (S var)) eqn:shift_le_Svar;
    [ omega .. ].
Qed.

Lemma insert_kind_get_kind_1 :
  forall pos kind e e',
    insert_kind pos kind e e' ->
    forall var,
      (var < pos -> get_kind e var = get_kind e' var) /\
      (var > pos -> get_kind e var = get_kind e' (S var)) /\
      (var = pos -> get_kind e' var = Some kind).
  do 5 intro. induction H.
  - intro; repeat split; intro.
    + inversion H.
    + simpl. rewrite H. auto.
  - auto.
  - intros; repeat split; intro; destruct var; auto; try apply IHinsert_kind; omega.
Qed.

Lemma insert_kind_get_kind_2 :
  forall pos kind e e',
    insert_kind pos kind e e' ->
    forall var,
      get_kind e var = get_kind e' (if le_gt_dec pos var then S var else var).
  do 5 intro.
  induction H; auto with arith.
  - destruct var; auto.
    + rewrite shift_var_s. eauto.
Qed.

Lemma option_map_compose :
  forall A B C f g x, @option_map B C f (@option_map A B g x) = option_map (fun x => f (g x)) x.
  intros. destruct x; auto.
Qed.

Lemma tshift_compose :
  forall T p p',
    tshift p' (tshift (p + p') T) = tshift (S (p + p')) (tshift p' T).
  induction T; intros.
  - unfold tshift.
    destruct (le_gt_dec (p + p') n), (le_gt_dec p' (S n)), (le_gt_dec p' n),
    (le_gt_dec (S (p + p'))); auto; try omega.
  - simpl. congruence.
  - simpl. rewrite plus_n_Sm. congruence.
Qed.

Ltac tvar_case :=
  unfold tshift; unfold tsubst; fold tshift; fold tsubst;
  match goal with
  | |- ?x =>
      match x with
      | context [le_gt_dec ?n ?n'] =>
          case (le_gt_dec n n')
      | context C [(lt_eq_lt_dec ?n ?n')] =>
          case (lt_eq_lt_dec n n'); [intro s; case s; clear s | idtac ]
      end
  end.

Lemma tshift_tsubst_commut_1 :
  forall (T T' : typ) (n n' : nat),
    tshift (n + n') (tsubst T n T') =
    tsubst (tshift (S (n + n')) T) n (tshift (n + n') T').
  induction T; intros;
  [ repeat tvar_case; simpl; trivial; try (intros; f_equal; omega);
    try (intros; assert False; [ omega | contradiction ]) .. ].
  - f_equal. apply IHT1. apply IHT2.
  - f_equal. assert (S (n + n') = S n + n') by omega. rewrite H.
    assert (n + n' = n + n' + 0) by omega. rewrite H0.
    rewrite (tshift_compose T' (n + n') 0). congruence.
Qed.

Lemma tshift_tsubst_commut_2 :
  forall (T T' : typ) (n n' : nat),
    tshift n (tsubst T (n + n') T') =
    tsubst (tshift n T) (1 + n + n') (tshift n T').
  induction T; intros;
  [ repeat tvar_case; simpl; trivial; auto with arith; try (intros; f_equal; omega) .. ].
  - simpl. f_equal. apply IHT1. apply IHT2.
  - simpl. f_equal. assert (S (n + n') = S n + n') by omega. rewrite H.
    assert (tshift n = tshift (n + 0)) by auto with arith. rewrite H0.
    rewrite tshift_compose. assert (n + 0 = n) by omega. rewrite H1.
    apply IHT.
Qed.

Lemma insert_kind_get_typ :
  forall pos e e' k,
    insert_kind pos k e e' ->
    forall var,
      option_map (tshift pos) (get_typ e var) = get_typ e' var.
  do 5 intro. induction H; intros.
  - auto.
  - destruct var. auto. apply IHinsert_kind.
  - simpl. rewrite <- IHinsert_kind. do 2 rewrite option_map_compose.
    assert (pos = pos + 0) by auto. rewrite H0.
    destruct (get_typ e var).
    + simpl. rewrite tshift_compose. auto.
    + auto.
Qed.

Lemma insert_kind_wf_typ : forall pos e e' typ kind,
                               insert_kind pos kind e e' ->
                               wf_typ e typ -> wf_typ e' (tshift pos typ).
  intros until typ. generalize pos e e'. clear pos. clear e. clear e'.
  induction typ.
  - intros.
    simpl. erewrite <- insert_kind_get_kind_2; [ eauto .. ].
  - intros. destruct H0. split; [ eauto .. ].
  - intros. simpl in H0. simpl.
    eapply IHtyp.
    eapply ik_etvar.
    apply H.
    apply H0.
Qed.

Lemma remove_kind_wf_typ : forall pos e e' typ kind,
                               insert_kind pos kind e e' ->
                               wf_typ e' (tshift pos typ) -> wf_typ e typ.
  intros until typ. generalize pos e e'. clear pos. clear e. clear e'.
  induction typ.
  - intros.
    simpl. erewrite insert_kind_get_kind_2; [ eauto .. ].
  - intros. destruct H0. split; [ eauto .. ].
  - intros. simpl in H0. simpl.
    eapply IHtyp.
    eapply ik_etvar.
    apply H.
    apply H0.
Qed.

Lemma insert_kind_wf_env : forall pos e e' k,
                               insert_kind pos k e e' ->
                               wf_env e -> wf_env e'.
  do 5 intro.
  induction H.
  - auto.
  - intro. simpl.
    split.
    + eapply insert_kind_wf_typ.
      apply H.
      apply H0.
    + apply IHinsert_kind.
      apply H0.
  - intro. apply IHinsert_kind. apply H0.
Qed.

Theorem insert_kind_kinding : forall typ k kind,
                              forall pos e e',
                                insert_kind pos k e e' ->
                                kinding e typ kind -> kinding e' (tshift pos typ) kind.
  induction typ.
  - intros. inversion H0.
    eapply k_tvar.
    { eapply insert_kind_wf_env; [ eauto .. ]. }
    { erewrite <- insert_kind_get_kind_2; [ eauto .. ]. }
    auto.
  - intros. inversion H0.
    eauto using k_tarr.
  - intros. inversion H0.
    eauto using ik_etvar, k_tall.
Qed.

Theorem insert_kind_typing :
  forall (e : env) (t : term) (T : typ),
    typing e t T ->
    forall (e' : env) (pos : nat) (K : kind),
      insert_kind pos K e e' -> typing e' (shift_typ pos t) (tshift pos T).
  do 4 intro. induction H; intros; simpl.
  - apply t_var. eapply insert_kind_wf_env. apply H1. apply H.
    rewrite <- (insert_kind_get_typ pos e e' K). rewrite H0. auto. auto.
  - apply t_abs. apply (insert_kind_wf_typ pos e e' T1 K). apply H1. apply H.
    eapply IHtyping, ik_evar, H1.
  - eapply t_app. eapply IHtyping1, H1. eapply IHtyping2, H1.
  - eapply t_abs_t. eapply IHtyping. eapply ik_etvar. apply H0.
  - assert (pos = 0 + pos) by omega. rewrite H2 at 3.
    rewrite tshift_tsubst_commut_1. simpl. eapply t_app_t.
    eapply IHtyping. apply H1.
    eapply insert_kind_kinding. apply H1. apply H0.
Qed.

Inductive env_subst : nat -> typ -> env -> env -> Prop :=
| env_subst_empty var typ :
    env_subst var typ empty empty

| env_subst_etvar_zero typ kind env :
    env_subst 0 typ (etvar kind env) env
| env_subst_etvar_s pos typ kind env env' :
    env_subst pos typ env env' ->
    env_subst (S pos) typ (etvar kind env) (etvar kind env')

| env_subst_evar pos typ typ' env env' :
    env_subst pos typ env env' ->
    env_subst pos typ (evar typ' env) (evar (tsubst typ' pos typ) env')
.

Fixpoint remove_var (i : nat) (e : env) :=
  match e with
    | empty => empty
    | evar t e' =>
      match i with
        | 0 => e'
        | S i' => evar t (remove_var i' e')
      end
    | etvar k e' => etvar k (remove_var i e')
  end.

Lemma remove_var_evar :
  forall (p : nat) (e : env) (T : typ),
    evar T (remove_var p e) = remove_var (S p) (evar T e).
  induction p; intros; auto.
Qed.

Definition extends e1 e2 :=
  match (e1, e2) with
    | (Some k, Some k') => k' <= k
    | (None, None) => True
    | _ => False
  end.

Lemma kind_extensionality_wf_typ :
  forall (T : typ) (e e' : env),
    (forall p : nat, extends (get_kind e p) (get_kind e' p)) ->
    wf_typ e T -> wf_typ e' T.
  induction T.
  - intros. simpl. unfold extends in H. specialize (H n).
    destruct (get_kind e' n); intro; try discriminate.
    simpl in H0. destruct (get_kind e n). inversion H. apply H0. auto.
  - intros. split.
    + eapply IHT1. apply H. apply H0.
    + eapply IHT2. apply H. apply H0.
  - intros. simpl. simpl in H0.
    assert (forall p : nat, extends (get_kind (etvar k e) p) (get_kind (etvar k e') p)).
    destruct p; simpl; auto. unfold extends; trivial. eapply IHT; auto.
Qed.

Lemma kind_extensionality_kinding :
  forall (T : typ) (e : env) (K : kind),
    kinding e T K ->
    forall e',
      wf_env e' ->
      (forall p : nat, extends (get_kind e p) (get_kind e' p)) ->
      kinding e' T K.
  do 4 intro. induction H.
  - intros. specialize (H3 X). unfold extends in H3. rewrite H0 in H3.
    remember (get_kind e' X) as kind_e'_X. destruct kind_e'_X.
    apply k_tvar with (Kp := k); auto; try omega. inversion H3.
  - intros. eapply k_tall. apply IHkinding. auto. intros. destruct p.
    + simpl. unfold extends. auto.
    + simpl. apply H1.
  - intros. apply k_tarr. apply IHkinding1. apply H1. apply H2. apply IHkinding2.
    apply H1. apply H2.
Qed.

Lemma remove_var_respects_kind_extensionality_strong :
  forall (e : env) (pos : nat),
    forall p : nat, (get_kind e p) = (get_kind (remove_var pos e) p).
  induction e; simpl; intros; auto; try destruct pos; try destruct p; eauto.
Qed.

Lemma equality_implies_extension (a b : option nat) (eq : a = b) : extends a b.
  unfold extends. destruct a, b; auto; try discriminate. inversion eq. omega.
Qed.

Lemma remove_var_respects_kind_extensionality_weak :
  forall (e : env) (pos : nat),
    forall p : nat, extends (get_kind e p) (get_kind (remove_var pos e) p).
  intros. apply equality_implies_extension.
  apply remove_var_respects_kind_extensionality_strong.
Qed.

Lemma remove_var_wf_typ :
  forall (e : env) (pos : nat) (T : typ),
    wf_typ e T -> wf_typ (remove_var pos e) T.
  intros.
  eapply kind_extensionality_wf_typ with (e' := (remove_var pos e)).
  apply remove_var_respects_kind_extensionality_weak.
  apply H.
Qed.

Lemma remove_var_wf_env :
  forall (e : env) (pos : nat),
    wf_env e -> wf_env (remove_var pos e).
  induction e.
  - auto.
  - induction pos.
    + intros. apply H.
    + intros. simpl. split. simpl in H. apply remove_var_wf_typ.
      apply H. apply IHe. apply H.
  - intros. simpl. apply IHe. apply H.
Qed.

Lemma subst_kind_wf_typ :
  forall (T T' : typ) (e e' : env) (pos : nat) (K : kind),
    insert_kind pos K e e' ->
    wf_typ e' T ->
    wf_typ e T' ->
    wf_typ e (tsubst T pos T').
  induction T; simpl; intros.
  - destruct (lt_eq_lt_dec n pos).
    + destruct s.
      * simpl. rewrite (insert_kind_get_kind_2 pos K e e' H).
        destruct (le_gt_dec pos n). omega. apply H0.
      * apply H1.
    + simpl. rewrite (insert_kind_get_kind_2 pos K e e' H).
      destruct (le_gt_dec pos (n - 1)).
      * assert (S (n - 1) = n) by omega. rewrite H2. auto.
      * omega.
  - split.
    { eapply IHT1. apply H. apply H0. apply H1. }
    { eapply IHT2. apply H. apply H0. apply H1. }
  - eapply IHT. apply ik_etvar. apply H. apply H0.
    eapply insert_kind_wf_typ. apply ik_top. apply H1.
Qed.

Lemma add_var_wf_typ :
  forall (e : env) (pos : nat) (T : typ),
    wf_typ (remove_var pos e) T -> wf_typ e T.
  intros.
  eapply kind_extensionality_wf_typ with (e := (remove_var pos e)).
  intro. apply equality_implies_extension. symmetry.
  apply remove_var_respects_kind_extensionality_strong. auto.
Qed.

Lemma remove_var_get_typ_lt :
  forall (e : env) (pos var : nat),
    var < pos ->
    get_typ e var = get_typ (remove_var pos e) var.
  induction e.
  - auto.
  - intros. destruct pos.
    + inversion H.
    + destruct var.
      * auto.
      * apply lt_S_n in H. apply IHe. apply H.
  - intros. simpl. erewrite IHe. reflexivity. auto.
Qed.

Lemma remove_var_get_typ_gt :
  forall (e : env) (pos var : nat),
    var > pos ->
    get_typ e var = get_typ (remove_var pos e) (var - 1).
  induction e.
  - auto.
  - intros. destruct pos.
    + destruct var. inversion H. simpl. rewrite <- minus_n_O. auto.
    + destruct var. inversion H. destruct var. inversion H. inversion H1.
      simpl. pose (IHe pos (S var)). simpl in e0. rewrite <- minus_n_O in e0. apply e0.
      apply lt_S_n in H. apply H.
  - intros. simpl. erewrite IHe. reflexivity. auto.
Qed.

Inductive free_var : nat -> term -> Prop :=
| var_free_var v : free_var v (var v)
| abs_free_var typ body v :
    free_var (S v) body -> free_var v (abs typ body)
| app_free_var_l t1 t2 v :
    free_var v t1 -> free_var v (app t1 t2)
| app_free_var_r t1 t2 v :
    free_var v t2 -> free_var v (app t1 t2)
| abs_t_free_var kind term v :
    free_var v term -> free_var v (abs_t kind term)
| app_t_free_var term typ v :
    free_var v term -> free_var v (app_t term typ)
.

Lemma typing_wf_env :
  forall (t : term) (T : typ) (e : env),
    typing e t T -> wf_env e.
  do 4 intro. induction H; [ auto .. ]. apply IHtyping.
Qed.

Lemma weakening_wf_typ_var :
  forall (e : env) (p : nat),
    wf_typ e (tvar (S p)) ->
    wf_typ e (tvar p).
  induction e; intros; auto.
  - apply IHe, H.
  - destruct p; simpl.
    + discriminate.
    + apply IHe. apply H.
Qed.

Lemma weak_extensionality_wf_typ :
  forall (T : typ) (e e' : env),
    (forall p, get_kind e p <> None -> get_kind e' p <> None) ->
    wf_typ e T -> wf_typ e' T.
  induction T; intros; simpl.
  - simpl in H0. specialize (H n). destruct (get_kind e n), (get_kind e' n); [ auto .. ].
  - split; [ eapply IHT1, H0 | eapply IHT2, H0 ]. apply H. apply H.
  - apply (IHT (etvar k e)). intro. destruct p. auto. apply H. apply H0.
Qed.

Lemma kind_weakening_wf_typ :
  forall (T : typ) (e : env) (K : kind),
    wf_typ e T -> wf_typ (etvar K e) T.
  intros.
  apply (weak_extensionality_wf_typ T e (etvar K e)).
  induction p; intros; simpl.
  - discriminate.
  - apply weakening_wf_typ_var. apply H0.
  - apply H.
Qed.

Lemma weakening_wf_typ :
  forall (T : typ) (e : env),
    wf_typ e T ->
    forall (K : kind),
      wf_typ (etvar K e) T.
  induction T; intros; simpl.
  - destruct n; simpl.
    + discriminate.
    + apply weakening_wf_typ_var. apply H.
  - split; [ apply IHT1, H | apply IHT2, H ].
  - apply IHT. simpl in H. apply (weak_extensionality_wf_typ T (etvar k e) (etvar K e)).
    { intro. destruct p. discriminate. simpl. auto. }
    apply H.
Qed.

Lemma get_typ_wf_typ :
  forall (e : env),
    wf_env e ->
    forall (p : nat),
      match get_typ e p with
        | None => True
        | Some T => wf_typ e T
      end.
  induction e.
  - auto.
  - intro. destruct p.
    + simpl. destruct H. apply (kind_extensionality_wf_typ _ e); auto.
      { unfold extends. simpl. intro. destruct (get_kind e p); auto. }
    + assert (wf_env e). apply H. simpl.
      assert (match get_typ e p with | Some T => wf_typ e T | None => True end).
      apply IHe. apply H0.
      destruct (get_typ e p); auto.
      apply (kind_extensionality_wf_typ _ e); auto.
      { intro. simpl. unfold extends. destruct (get_kind e p0); auto. }
  - intros. destruct p; simpl.
    + specialize (IHe H 0).
      destruct (get_typ e 0).
      * simpl. eapply insert_kind_wf_typ. apply ik_top. apply IHe.
      * auto.
    + specialize (IHe H (S p)). destruct (get_typ e (S p)).
      * simpl. eapply insert_kind_wf_typ. apply ik_top. apply IHe.
      * auto.
Qed.

Lemma kinding_wf_typ :
  forall (T : typ) (e : env) (K : kind),
    kinding e T K -> wf_typ e T.
  do 4 intro. induction H; simpl; intros.
  - intro. assert (Some Kp = None). transitivity (get_kind e X). auto. auto. discriminate.
  - apply IHkinding.
  - split. { apply IHkinding1. } { apply IHkinding2. }
Qed.

Lemma kinding_wf_env :
  forall (T : typ) (e : env) (K : kind),
    kinding e T K -> wf_env e.
  do 4 intro. induction H; simpl; intros; auto.
Qed.

Lemma typing_wf_typ :
  forall (t : term) (T : typ) (e : env),
    typing e t T -> wf_typ e T.
  do 4 intro. induction H.
  - pose (get_typ_wf_typ e H X). rewrite H0 in y. apply y.
  - split. apply H. apply (kind_extensionality_wf_typ T2 (evar T1 e)); auto.
    intro. unfold extends. simpl. destruct (get_kind e p); auto.
  - apply IHtyping1.
  - apply IHtyping.
  - simpl in IHtyping.
    eapply subst_kind_wf_typ. apply ik_top. apply IHtyping. eapply kinding_wf_typ. apply H0.
Qed.

Lemma kinding_extensionality :
  forall (T : typ) (K : kind) (e : env),
    kinding e T K ->
    forall (e' : env),
      (forall p, extends (get_kind e p) (get_kind e' p)) ->
      wf_env e' ->
      kinding e' T K.
  do 4 intro. induction H; intros; simpl.
  - pose H2. specialize (e0 X).
    unfold extends in e0. remember (get_kind e X) as kind_e_X. destruct kind_e_X; simpl.
    + remember (get_kind e' X) as kind_e'_X. destruct kind_e'_X; try omega.
      apply k_tvar with (Kp := k0); auto. inversion H0. omega.
    + discriminate.
  - eapply k_tall. apply IHkinding. intro.
    destruct p. { simpl. unfold extends. auto. } { simpl. apply H0. }
    apply H1.
  - apply k_tarr.
    { apply IHkinding1. apply H1. apply H2. }
    { apply IHkinding2. apply H1. apply H2. }
Qed.

Lemma typing_extensionality :
  forall (t : term) (T : typ) (e : env),
    typing e t T ->
    forall (e' : env),
      (forall p, extends (get_kind e p) (get_kind e' p)) ->
      (forall p, free_var p t -> get_typ e p = get_typ e' p) ->
      wf_env e' ->
      typing e' t T.
  do 4 intro. induction H.
  - intros. apply t_var. apply H3. rewrite <- H2. apply H0.
    apply var_free_var.
  - intros. apply t_abs.
    eapply kind_extensionality_wf_typ. apply H1. apply H.
    apply IHtyping.
    { intro. simpl. apply H1. }
    { intros. destruct p. auto. simpl. apply H2. apply abs_free_var, H4. }
    { split. eapply kind_extensionality_wf_typ. apply H1.
      apply typing_wf_env in H0. apply H0. apply H3. }
  - intros. eapply t_app.
    + eapply IHtyping1.
      * apply H1.
      * intros. eapply app_free_var_l in H4. apply H2, H4.
      * apply H3.
    + eapply IHtyping2.
      * apply H1.
      * intros. eapply app_free_var_r in H4. apply H2, H4.
      * apply H3.
  - intros. apply t_abs_t.
    apply IHtyping.
    { intro. destruct p; simpl. unfold extends; auto. apply H0. }
    { intros. simpl. rewrite H1. auto. apply abs_t_free_var. apply H3. }
    { apply H2. }
  - intros. eapply t_app_t. apply IHtyping. apply H1.
    { intros. apply H2. apply app_t_free_var. apply H4. }
    { apply H3. }
    { eapply kind_extensionality_kinding. apply H0. apply H3. apply H1. }
Qed.

Lemma typing_weakening_var_ind :
  forall (e : env) (pos : nat) (t : term) (T : typ),
    wf_env e -> typing (remove_var pos e) t T -> typing e (shift pos t) T.
  intros e pos t T H1 H2; cut (exists e', e' = remove_var pos e). intros (e', E).
  rewrite <- E in H2. generalize pos e E H1. clear pos e E H1.
  induction H2; intros pos e' E H1; simpl.
  - apply t_var. apply H1.
    destruct (le_gt_dec pos X).
    + assert (S X > pos) by omega.
      apply (remove_var_get_typ_gt e' _ (S X)) in H2. simpl in H2.
      rewrite H2. rewrite <- minus_n_O. rewrite <- H0. rewrite E. auto.
    + apply (remove_var_get_typ_lt e' _ X) in g. rewrite g. rewrite <- E. rewrite <- H0. auto.
  - apply t_abs. eapply add_var_wf_typ. rewrite E in H. apply H. apply IHtyping.
    + rewrite E. auto.
    + split. apply typing_wf_env in H2. destruct H2. rewrite E in H.
      eapply add_var_wf_typ. apply H. apply H1.
  - eapply t_app. apply IHtyping1. apply E. apply H1. apply IHtyping2. apply E. apply H1.
  - eapply t_abs_t. apply IHtyping. rewrite E. auto.
    simpl. apply H1.
  - eapply t_app_t. apply IHtyping. apply E. apply H1.
    eapply kinding_extensionality.
    { apply H. }
    { rewrite E. intro. apply equality_implies_extension. symmetry.
      apply remove_var_respects_kind_extensionality_strong. }
    { apply H1. }
  - exists (remove_var pos e). auto.
Qed.

Lemma typing_weakening_var :
  forall (e : env) (t : term) (T T' : typ),
  wf_env e -> wf_typ e T' -> typing e t T -> typing (evar T' e) (shift 0 t) T.
  intros.
  eapply typing_weakening_var_ind.
  split. apply H0. apply H. simpl. apply H1.
Qed.

Lemma subst_preserves_typing :
  forall (t u : term),
  forall (V W : typ),
  forall (e : env) (x : nat),
    typing e t V ->
    typing (remove_var x e) u W ->
    get_typ e x = Some W ->
    typing (remove_var x e) (subst t x u) V.
  intros t u V W e x H. generalize u W x. clear u W x.
  induction H; simpl; intros.
  - case (lt_eq_lt_dec X x).
    + intro. destruct s.
      * eapply t_var. apply remove_var_wf_env. apply H.
        rewrite <- H0. symmetry.
        apply remove_var_get_typ_lt. apply l.
      * assert (T = W). symmetry in H2. rewrite e0 in H0.
        apply (eq_trans H2) in H0. inversion H0. auto. rewrite <- H3 in H1. auto.
    + intro. eapply t_var. apply remove_var_wf_env. apply H.
      rewrite <- H0. symmetry. apply remove_var_get_typ_gt. apply l.
  - subst. apply t_abs.
    specialize (IHtyping (shift 0 u) W (S x)). simpl in IHtyping.
    apply remove_var_wf_typ, H. rewrite remove_var_evar. apply IHtyping with (W := W).
    simpl. apply typing_weakening_var. apply remove_var_wf_env.
    apply typing_wf_env in H0. apply H0. apply remove_var_wf_typ. apply H.
    apply H1. apply H2.
  - eapply t_app.
    eapply IHtyping1. apply H1. apply H2. eapply IHtyping2. apply H1. apply H2.
  - eapply t_abs_t.
    eapply IHtyping.
    eapply (insert_kind_typing (remove_var x e) u). apply H0.
    apply ik_top.
    rewrite <- (insert_kind_get_typ 0 e (etvar K e) K). rewrite H1. auto.
    apply ik_top.
  - eapply t_app_t. eapply IHtyping. apply H1. apply H2.
    eapply kinding_extensionality. apply H0.
    apply remove_var_respects_kind_extensionality_weak.
    apply remove_var_wf_env.
    eapply typing_wf_env.
    apply H.
Qed.

Theorem wf_typ_kinding :
  forall (T : typ) (e : env),
    wf_env e ->
    wf_typ e T ->
    exists (K : kind), kinding e T K.
  induction T; simpl; intros.
  - remember (get_kind e n) as o. destruct o.
    + idtac. exists k. eapply k_tvar. apply H. symmetry. apply Heqo. auto.
    + exfalso. auto.
  - destruct H0. apply IHT1 in H0; auto. apply IHT2 in H1; auto. destruct H0, H1.
    + idtac. exists (max x x0). apply k_tarr; auto.
  - apply IHT in H0; auto. destruct H0. exists (S (max x k)). apply k_tall. auto.
Qed.

Theorem regularity :
  forall (e : env) (t : term) (T : typ),
    typing e t T ->
    exists (K : kind), kinding e T K.
  intros. apply wf_typ_kinding; eauto using typing_wf_env, typing_wf_typ.
Qed.

Lemma replace_kind_respects_kind_extensionality :
  forall (e e' e'' : env) (K' K'' : kind) (pos : nat),
    K'' <= K' ->
    insert_kind pos K' e e' ->
    insert_kind pos K'' e e'' ->
    (forall (p : nat), extends (get_kind e' p) (get_kind e'' p)).
  intros.
  { destruct (gt_eq_gt_dec pos p). destruct s.
    + pose insert_kind_get_kind_2. specialize (e0 pos _ _ _ H0 (pred p)).
      pose insert_kind_get_kind_2. specialize (e1 pos _ _ _ H1 (pred p)).
      erewrite <- S_pred in e0, e1. destruct (le_gt_dec pos (pred p)); try omega.
      * rewrite <- e0. rewrite <- e1. apply equality_implies_extension. auto.
      * apply g. * apply g.
    + pose insert_kind_get_kind_1. specialize (a pos _ _ _ H0 p). destruct a. destruct H3.
      pose insert_kind_get_kind_1. specialize (a pos _ _ _ H1 p). destruct a. destruct H6.
      rewrite H4, H7; auto.
    + pose insert_kind_get_kind_1. specialize (a pos _ _ _ H0 p). destruct a.
      pose insert_kind_get_kind_1. specialize (a pos _ _ _ H1 p). destruct a.
      rewrite <- H2, H4; auto. apply equality_implies_extension; auto. }
Qed.

Lemma replace_kind_wf_typ :
  forall (T : typ),
  forall (e e' e'' : env) (K' K'' : kind) (pos : nat),
    K'' <= K' ->
    insert_kind pos K' e e' ->
    insert_kind pos K'' e e'' ->
    wf_typ e' T ->
    wf_typ e'' T.
  intros.
  eapply kind_extensionality_wf_typ.
  eapply replace_kind_respects_kind_extensionality.
  apply H. apply H0. apply H1. apply H2.
Qed.

Lemma insert_kind_swap :
  forall (e : env) (T : typ) (K: kind),
    insert_kind 0 K (evar T e) (etvar K (evar T e)) ->
    insert_kind 0 K (evar T e) (evar (tshift 0 T) (etvar K e)).
  intros. apply ik_evar. apply ik_top.
Qed.

Lemma replace_kind_wf_env :
  forall (e : env),
    forall (e'' e' : env) (K'' K' : kind) (pos : nat),
      insert_kind pos K'' e e'' /\ insert_kind pos K' e e' ->
      K'' <= K' ->
      wf_env e' ->
      wf_env e''.
  induction e.
  - intros. inversion H. inversion H2. simpl. auto.
  - intros. destruct H.
    remember (evar t e) in H.
    induction H; simpl; auto; try discriminate.
    + remember (evar t e) in H2.
      inversion H2; simpl; auto; try discriminate.
      * simpl. rewrite <- H5 in H1. rewrite Heqe0. rewrite <- Heqe1. apply H1.
      * simpl. rewrite <- H5 in *. rewrite Heqe0. rewrite <- Heqe1.
        rewrite <- H6 in H1. split.
        { clear H5 e1 H4 K0 H3 pos. rewrite <- H6 in H2. inversion H2.
          clear H4 pos H9 e'1 H5 K0 H8 e1 H3 T0.
          inversion Heqe1. rewrite -> H5 in *. clear H5 e2. rewrite -> H4 in *.
          clear H4 T. clear H6 e'. clear H. clear Heqe0. clear Heqe1.
          destruct H1. eapply remove_kind_wf_typ.
          apply H7. apply H. }
        { inversion Heqe1. rewrite H9, H8 in *. clear H3 H4 H8 H9. clear H5 e2.
          eapply (IHe (etvar K e)). split; auto.
          { eapply ik_top. } { rewrite <- H6 in H2. inversion H2. apply H7. }
          auto. apply H1. }
    + split.
      * eapply insert_kind_wf_typ. apply H. inversion Heqe0.
        rewrite H5 in *.
        clear H4 H5 Heqe0 T e0.
        remember (evar t e) in H2. inversion H2; simpl; auto; try discriminate.
        { rewrite <- H3 in *. clear H3 pos. clear H4 K0. clear H5. rewrite <- H6 in *.
          rewrite Heqe0 in H1. apply H1. }
        { rewrite <- H7 in H1. destruct H1. rewrite Heqe0 in *. clear Heqe0 e0.
          rewrite <- H7 in *. clear H7 e'. inversion H6. rewrite H9 in *. clear H9 T.
          rewrite H10 in *. clear H10 e1. clear H4 pos0. clear H5 K0. clear H6.
          eapply remove_kind_wf_typ. apply H3. apply H1. }
        { rewrite <- H6 in *. discriminate. }
      * remember (evar t e) in H2. inversion H2; simpl; auto; try discriminate.
        { clear H5 e2. clear H4 K0. rewrite <- H3 in *. clear pos H3.
          rewrite <- H6 in *. clear H6 e'.
          inversion Heqe0. rewrite H5 in *. clear H5 e0 Heqe0. clear H4.
          rewrite Heqe1 in *. clear Heqe1 e1. clear IHinsert_kind.
          eapply ik_evar with (T := t) in H.
          eapply IHe. split. inversion H. apply H6. apply ik_top. apply H0. apply H1. }
        { rewrite Heqe1 in *. clear Heqe1 e1. inversion Heqe0. rewrite H10 in *.
          clear Heqe0 H9 H10 T e0. clear H4 pos0. clear H5 K0. inversion H6.
          rewrite H5 in *. clear H5 T0. rewrite H8 in *. clear H8 e2. clear H6.
          rewrite <- H7 in *. clear H7 e'. eapply IHe. split.
          { apply H. } { apply H3. } { apply H0. } { apply H1. } }
        { rewrite <- H6 in *. discriminate. }
  - intros. destruct H. remember (etvar k e) in H.
    inversion H.
    + rewrite <- H3 in *. rewrite Heqe0 in *. rewrite <- H6 in *. inversion H2.
      rewrite <- H10 in H2. simpl.
      eapply (IHe (etvar K'' e)). split. apply ik_top. apply ik_top.
      apply H0. rewrite <- H10 in H1. apply H1.
    + rewrite <- H6 in Heqe0. inversion Heqe0.
    + rewrite <- H6 in Heqe0. inversion Heqe0.
      (* As I write this, it's 6:30 AM and I haven't slept *)
      (* This can probably be done in a much shorter way. *)
      rewrite H9, H10 in *. clear H9 H10 H5 K'0 e1 K.
      rewrite <- H6, <- H7 in *. clear H6 H7 e0 e''. clear Heqe0. rewrite <- H4 in *.
      clear H4 pos. remember (etvar k e) in H2.
      inversion H2. rewrite <- H7 in *. clear H7 e0. clear H6 K. clear H5 pos.
      rewrite <- H8 in *. clear H8 e'. inversion Heqe0.
      rewrite <- H7, <- H8 in *. clear H7 H8 e0 e'. rewrite <- H4 in *. clear H4 pos0.
      clear H6. simpl. eapply IHe. split. apply H3. inversion Heqe0. rewrite H7 in *.
      apply H5. auto. apply H1.
Qed.
(* As I finish this proof, I know this is the most satisfying moment of my life *)

Theorem narrowing :
  forall (e' : env) (t : term) (T : typ),
    typing e' t T ->
    forall (pos : nat) (e e'' : env) (K' K'' : kind),
    insert_kind pos K' e e' ->
    insert_kind pos K'' e e'' ->
    K'' <= K' ->
    typing e'' t T.
  intros.
  eapply typing_extensionality. apply H.
  eapply replace_kind_respects_kind_extensionality. apply H2. apply H0. apply H1.
  { intros.
    pose (insert_kind_get_typ _ _ _ _ H0 p).
    pose (insert_kind_get_typ _ _ _ _ H1 p).
    rewrite <- e0, e1. auto. }
  eapply replace_kind_wf_env. split. apply H1. apply H0. apply H2.
  eapply typing_wf_env. apply H.
Qed.


(** Compilation+inference agrees with functional CWP (always). *)

Set Implicit Arguments.
Require Import Coq.Program.Basics.
Require Import Coq.QArith.QArith.
Require Import Coq.micromega.Lqa.
Require Import Coq.micromega.Lia.
Require Import ExtLib.Data.Monads.StateMonad.
Local Open Scope program_scope.

Require Import compile.
Require Import cpGCL.
Require Import cwp.
Require Import infer.
Require Import order.
Require Import Q.
Require Import tree.

(** wpf and unnormalized inference after compilation coincide when c
  is well-formed. *)
Theorem wpf_infer_f c f n :
  wf_cpGCL c ->
  wpf c f ==f infer_f f ∘ evalCompile c n.
Proof.
  revert n f.
  induction c; intros m f Hwf st;
    unfold evalCompile, evalState, compose; simpl; inversion Hwf; subst.
  - reflexivity.
  - rewrite Qdiv_0_num; reflexivity.
  - reflexivity.
  - unfold compose.
    unfold compose, f_Qeq, evalCompile, evalState in *.
    destruct (runState (compile c1) m) eqn:Hc1.
    destruct (runState (compile c2) n) eqn:Hc2.
    specialize (IHc1 m (wpf c2 f) H1 st).
    rewrite IHc1. simpl.
    rewrite Hc1. simpl.
    unfold kcomp. simpl.
    rewrite <- infer_f_bind. unfold compose. simpl.
    + apply infer_f_proper; intro x.
      specialize (IHc2 n f H2 x).
      rewrite IHc2, Hc2; reflexivity.
    + intros l x Hbound. apply not_in_not_bound_and_not_free. split.
      * apply free_in_not_free_in; intro HC.
        eapply compile_free_in_0 in Hc2; eauto. subst.
        eapply compile_bound_labels in Hc1; eauto; lia.
      * apply bound_in_not_bound_in; intro HC.
        eapply compile_bound_labels in Hc2; eauto.
        eapply compile_bound_labels in Hc1; eauto.
        lia.
  - unfold compose, evalCompile, evalState, f_Qeq in *.
    destruct (runState (compile c1) m) eqn:Hc1.
    destruct (runState (compile c2) n) eqn:Hc2.
    simpl; destruct (e st).
    + rewrite IHc1, Hc1; auto; reflexivity.
    + rewrite IHc2, Hc2; auto; reflexivity.
  - unfold compose, evalCompile, evalState, f_Qeq in *.
    destruct (runState (compile c1) m) eqn:Hc1.
    destruct (runState (compile c2) n) eqn:Hc2.
    rewrite IHc1, Hc1, IHc2, Hc2; auto; reflexivity.
  - destruct (runState (compile c) (S m)) eqn:Hc.
    pose proof IHc as IHc'.
    specialize (IHc (S m) f H0 st).
    unfold compose, evalCompile, evalState, f_Qeq in *.
    rewrite Hc in IHc. simpl in *.
    set (g := fun st' => if e st' then 0 else f st').
    set (h := fun st' => if e st' then 1 else 0).
    set (k := fun st' => if e st' then Fail St (S m) else Leaf st').
    destruct (e st).
    + cut (wpf c g st == infer_f f (tree_bind (t st) k)).
      cut (wpf c h st == infer_fail (S m) (tree_bind (t st) k)).
      { intros H1 H2; rewrite H1, H2; reflexivity. }
      * unfold h. unfold k.
        rewrite infer_fail_tree_bind_infer_f.
        specialize (IHc' (S m) (fun st => if e st then 1 else 0) H0 st).
        rewrite Hc in IHc'. simpl in IHc'.
        apply IHc'.
        apply label_in_not_in; intro HC. apply label_in_bound_or_free in HC.
        destruct HC as [HC|HC].
        ++ eapply compile_bound_labels in Hc; eauto; lia.
        ++ eapply compile_free_in_0 in Hc; eauto; lia.
        ++ eapply compile_wf_tree; eauto.
      * specialize (IHc' (S m) g H0 st).
        rewrite IHc'. rewrite Hc. simpl.
        unfold g. unfold k.
        rewrite infer_f_bind_fail.
        ++ reflexivity.
        ++ apply bound_in_not_bound_in; intro HC.
           eapply compile_bound_labels in Hc; eauto; lia.
    + reflexivity.
  - destruct (e st); reflexivity.
Qed.

(** wlpf and unnormalized liberal inference after compilation coincide
  when c is well-formed. *)
Theorem wlpf_infer_f_lib c f n :
  wf_cpGCL c ->
  wlpf c f ==f infer_f_lib f ∘ evalCompile c n.
Proof.
  revert n f.
  induction c; intros m f Hwf st;
    unfold evalCompile, evalState, compose; simpl; inversion Hwf; subst.
  - reflexivity.
  - rewrite Nat.eqb_refl; reflexivity.
  - reflexivity.
  - unfold compose.
    unfold compose, f_Qeq, evalCompile, evalState in *.
    destruct (runState (compile c1) m) eqn:Hc1.
    destruct (runState (compile c2) n) eqn:Hc2.
    specialize (IHc1 m (wlpf c2 f) H1 st).
    rewrite IHc1. simpl.
    rewrite Hc1. simpl.
    unfold kcomp. simpl.
    rewrite <- infer_f_lib_bind. unfold compose. simpl.
    + apply infer_f_lib_proper; intro x.
      specialize (IHc2 n f H2 x).
      rewrite IHc2, Hc2; reflexivity.
    + intros l x Hbound. apply not_in_not_bound_and_not_free. split.
      * apply free_in_not_free_in; intro HC.
        eapply compile_free_in_0 in Hc2; eauto. subst.
        eapply compile_bound_labels in Hc1; eauto; lia.
      * apply bound_in_not_bound_in; intro HC.
        eapply compile_bound_labels in Hc2; eauto.
        eapply compile_bound_labels in Hc1; eauto.
        lia.
  - unfold compose, evalCompile, evalState, f_Qeq in *.
    destruct (runState (compile c1) m) eqn:Hc1.
    destruct (runState (compile c2) n) eqn:Hc2.
    simpl; destruct (e st).
    + rewrite IHc1, Hc1; auto; reflexivity.
    + rewrite IHc2, Hc2; auto; reflexivity.
  - unfold compose, evalCompile, evalState, f_Qeq in *.
    destruct (runState (compile c1) m) eqn:Hc1.
    destruct (runState (compile c2) n) eqn:Hc2.
    rewrite IHc1, Hc1, IHc2, Hc2; auto; reflexivity.
  - destruct (runState (compile c) (S m)) eqn:Hc.
    pose proof IHc as IHc'.
    specialize (IHc (S m) f H0 st).
    unfold compose, evalCompile, evalState, f_Qeq in *.
    rewrite Hc in IHc. simpl in *.
    set (g := fun st' => if e st' then 0 else f st').
    set (h := fun st' => if e st' then 1 else 0).
    set (k := fun st' => if e st' then Fail St (S m) else Leaf st').
    destruct (e st).
    + cut (wlpf c g st == infer_f_lib f (tree_bind (t st) k)).
      cut (wpf c h st == infer_fail (S m) (tree_bind (t st) k)).
      { intros H1 H2. rewrite H1; simpl.
        destruct (Qeq_dec (infer_fail (S m) (tree_bind (t st) k)) 1).
        { rewrite Qeq_eq_bool; auto; reflexivity. }
        rewrite Qeq_bool_false; auto.
        rewrite H1, H2. reflexivity. }
      * unfold h. unfold k.
        rewrite infer_fail_tree_bind_infer_f.
        specialize (IHc' (S m) (fun st => if e st then 1 else 0) H0 st).
        rewrite Hc in IHc'. simpl in IHc'.
        generalize (@wpf_infer_f c (indicator e) (S m) H0 st).
        unfold compose, evalCompile, evalState; rewrite Hc; auto.
        apply label_in_not_in; intro HC. apply label_in_bound_or_free in HC.
        destruct HC as [HC|HC].
        ++ eapply compile_bound_labels in Hc; eauto; lia.
        ++ eapply compile_free_in_0 in Hc; eauto; lia.
        ++ eapply compile_wf_tree; eauto.
      * specialize (IHc' (S m) g H0 st).
        rewrite IHc'. rewrite Hc. simpl.
        unfold g. unfold k.
        rewrite infer_f_lib_bind_fail.
        ++ reflexivity.
        ++ apply bound_in_not_bound_in; intro HC.
           eapply compile_bound_labels in Hc; eauto; lia.
    + reflexivity.
  - destruct (e st); reflexivity.
Qed.

(** cwpf and normalized inference after compilation coincide when c is
    well-formed. *)
Theorem cwpf_infer c f n :
  wf_cpGCL c ->
  cwpf c f ==f infer f ∘ evalCompile c n.
Proof.
  intros Hwf x.
  unfold cwpf, infer, compose; simpl.
  apply Qeq_Qdiv.
  - apply wpf_infer_f; auto.
  - apply wlpf_infer_f_lib; auto.
Qed.


From hahn Require Import Hahn.

Require Import Events.

Section Exec.

Notation "a ²" := (a × a) (at level 1, format "a ²").

Record MExec := {
  EV : MixedEvent -> Prop;
  IW : option MixedEvent;
  sb : MixedEvent -> MixedEvent -> Prop;
  rfb : nat -> MixedEvent -> MixedEvent -> Prop;
  tot : MixedEvent -> MixedEvent -> Prop;
}.

Definition is_rmw e := rvals_dom e ≡₁ wvals_dom e.
Definition is_read e := wvals_dom e ⊆₁ ∅ \/ is_rmw e.
Definition is_write e := rvals_dom e ⊆₁ ∅ \/ is_rmw e.
Definition is_sc e := scevent e = true.

Definition writes exec :=
  EV exec ∩₁ is_write.

Definition reads exec :=
  EV exec ∩₁ is_read.

Definition sc exec :=
  EV exec ∩₁ is_sc.

Definition same_loc e e' :=
  ev_dom e ≡₁ ev_dom e'.

Definition same_val_wr n e e' :=
  get_val (location e) (wvals e) n = get_val (location e') (rvals e') n.

Definition init exec e := match IW exec with
  | None => False
  | Some e' => e = e'
end.

Definition sthd exec :=
  (sb exec)＊ ∪ (sb exec)＊⁻¹.

Definition rf exec :=
  ⋃ n , rfb exec n.

Definition sw e :=
  rf e ∩ ( ((sc e)² ∩ same_loc) ∪ ((init e × sc e)∩(fun y x => forall z, rf e z y -> x = z))).

Definition hb e :=
  (sb e ∪ sw e ∪ init e × EV e)⁺.

Definition tearfree e :=
  aligned ∩₁ (EV e) ∪₁ init e.

Lemma sw_intro e X Y:
  rf e X Y -> sc e X -> sc e Y -> same_loc X Y -> sw e X Y.
Proof.
  intros rfXY scX scY slXY.
  split; try assumption.
  left.
  repeat (split; try assumption).
Qed.

Lemma sw_hb e :
  sw e ⊆ hb e.
Proof.
  do 2 eapply inclusion_trans.
  apply inclusion_union_r2.
  apply inclusion_union_r1.
  apply ct_step.
  apply inclusion_refl.
Qed.

Lemma same_loc_sym :
  forall X Y, same_loc X Y -> same_loc Y X.
Proof.
  intros X Y [H1 H2].
  split; assumption.
Qed.

Lemma same_loc_trans X Y Z :
  same_loc X Y -> same_loc Y Z -> same_loc X Z.
Proof.
  intros slXY slYZ.
  unfold same_loc in *.
  rewrite slXY.
  assumption.
Qed.

Lemma same_loc_in_dom X Y n :
  same_loc X Y -> in_dom n X -> in_dom n Y.
Proof.
  intros sl id.
  apply (proj1 sl).
  apply id.
Qed.

Record well_formed exec := {
  wf_ev : forall e, EV exec e -> wf_event e;
  wf_index : forall e e', EV exec e -> EV exec e' -> index e = index e' -> e = e';
  wf_iww : init exec ⊆₁ writes exec \₁ reads exec;
  wf_iwn : forall ev ev', init exec ev -> ev_dom ev' ⊆₁ ev_dom ev;
  wf_iwsc : init exec ∩₁ sc exec ⊆₁ ∅;
  wf_rfb_func : forall n, functional (rfb exec n)⁻¹;
  wf_rfb_val : forall n, rfb exec n ⊆ same_val_wr n;
  wf_rfb_dom : forall n, rfb exec n ⊆ in_dom n × in_dom n;
  wf_rfb_wr : forall n, rfb exec n ≡ ⦗writes exec⦘ ⨾ (rfb exec n) ⨾ ⦗reads exec⦘;
  wf_loc_size : (EV exec\₁init exec) ⊆₁ size_n 1 ∪₁ size_n 2 ∪₁ size_n 4;
  wf_sb : strict_partial_order (sb exec);
  wf_rmw_sc : writes exec ∩₁ reads exec ⊆₁ sc exec;
  wf_sc_align : sc exec ⊆₁ aligned;
  wf_tot : strict_total_order (EV exec) (tot exec);
  wf_rfeq : forall X, rf exec X X -> False;
}.

Record consistent_sc_unfixed exec := {
  cst_hb_tot : (hb exec) ⊆ (tot exec);
  cst_rf_tf : functional ((rf exec) ∩ ((tearfree exec)×(tearfree exec)) ∩ same_loc)⁻¹;
  cst_rf_hb : irreflexive ((hb exec) ⨾ (rf exec));
  cst_rf_hb_hb : forall n, irreflexive (⦗writes exec⦘ ⨾ (hb exec) ⨾
                           (rfb exec n)⁻¹ ⨾ (hb exec) ⨾ ⦗in_dom n⦘);
  cst_sw_tot : irreflexive (⦗writes exec ∩₁ (sc exec)⦘ ⨾
               (tot exec ∩ same_loc) ⨾ (sw exec)⁻¹ ⨾ (tot exec));
}.

Record consistent exec := {
  cst_ufxd : consistent_sc_unfixed exec;
  cst_dagger : irreflexive (⦗writes exec ∩₁ (sc exec)⦘ ⨾
               (hb exec) ⨾ (rf exec ∩ (hb exec))⁻¹ ⨾
               ⦗sc exec⦘ ⨾ (tot exec ∩ same_loc));
  cst_ddagger : irreflexive (⦗writes exec ∩₁ (sc exec)⦘ ⨾
                (tot exec ∩ same_loc) ⨾ ⦗sc exec⦘ ⨾
                (rf exec ∩ (hb exec))⁻¹ ⨾ (hb exec));
}.

Definition data_race_free e :=
  forall X Y,
    hb e X Y \/ hb e Y X \/
    (~(writes e X) /\ ~(writes e Y)) \/
    nooverlap X Y \/
   (same_loc X Y /\ sc e X /\ sc e Y).

Definition seqcst e :=
  forall n, irreflexive (rfb e n ⨾ tot e) /\
  irreflexive (⦗writes e ∩₁ in_dom n⦘ ⨾ (tot e) ⨾ (rfb e n)⁻¹ ⨾ (tot e)).

Lemma rf__overlap exec :
  well_formed exec ->
  rf exec ⊆ overlap.
Proof.
  intros wf X Y [b [_ rfbXY]].
  eexists.
  eapply wf_rfb_dom; eauto.
Qed.

Lemma rf__ev exec :
  well_formed exec ->
  rf exec ⊆ (EV exec)².
Proof.
  intros wf X Y [b [_ H]].
  destruct (wf_rfb_wr exec wf b) as [H1 _].
  apply H1 in H.
  unfolder in H.
  destruct H as [[EVX _] [_ [EVY _]]].
  split; assumption.
Qed.

Lemma rfb__w exec X Y n :
  well_formed exec ->
  rfb exec n X Y -> writes exec X.
Proof.
  intros wf rf.
  apply wf_rfb_wr in rf; try assumption.
  unfolder in rf.
  destruct rf.
  assumption.
Qed.

Lemma rfb__r exec X Y n :
  well_formed exec ->
  rfb exec n X Y -> reads exec Y.
Proof.
  intros wf rf.
  apply wf_rfb_wr in rf; try assumption.
  unfolder in rf.
  destruct rf as [_[_ H]].
  assumption.
Qed.

Lemma rf__wr exec X Y:
  well_formed exec ->
  rf exec X Y ->
  writes exec X /\ reads exec Y.
Proof.
  intros wf rfXY.
  destruct rfXY as [n [_ rfbXY]].
  apply (proj1 (wf_rfb_wr exec wf n)) in rfbXY.
  unfolder in rfbXY.
  destruct rfbXY as [H1 [_ H2]].
  split; assumption.
Qed.

Lemma rfb__rf exec X Y n :
  rfb exec n X Y -> rf exec X Y.
Proof.
  intro rfbXY.
  exists n.
  split; trivial.
Qed.

Lemma sw_r_sc e X Y :
  well_formed e -> sw e X Y -> reads e Y /\ sc e Y.
Proof.
  intros wf swXY.
  unfold sw in swXY.
  unfolder in swXY.
  destruct swXY as [rfXY H].
  split.
  - apply rf__wr in rfXY;
    destruct rfXY; assumption.
  - destruct H as [[[_ scY] _] | [[_ scY] _]];
    assumption.
Qed.

Lemma sw_init_sc e X Y :
  well_formed e -> sw e X Y -> writes e X /\ (init e X \/ sc e X).
Proof.
  intros wf swXY.
  unfold sw in swXY.
  unfolder in swXY.
  destruct swXY as [rfXY H].
  split.
  - apply rf__wr in rfXY;
    destruct rfXY;
    assumption.
  - destruct H as [[[scX _] _] | [[iwX _] _]];
    auto.
Qed.

Lemma rfb__dom e :
  forall X Y n,
  well_formed e ->
  rfb e n Y X ->
  ev_dom Y n /\ ev_dom X n.
Proof.
  intros X Y n wf rfb.
  apply wf_rfb_dom in rfb;
  assumption.
Qed.

Lemma rfb_w_dom :
  forall e X Y n, well_formed e -> rfb e n Y X -> ev_dom Y n.
Proof.
  intros e X Y n H rfbnYX.
  apply wf_rfb_dom in rfbnYX; try assumption.
  destruct rfbnYX.
  assumption.
Qed.
Lemma rfb_r_dom :
  forall e X Y n, well_formed e -> rfb e n Y X -> ev_dom X n.
Proof.
  intros e X Y n H rfbnYX.
  apply wf_rfb_dom in rfbnYX; try assumption.
  destruct rfbnYX.
  assumption.
Qed.

Lemma rf__neq e X Y:
  well_formed e -> rf e X Y -> X <> Y.
Proof.
  intros wf [n [_ rfnXY]] eq.
  subst.
  eapply wf_rfeq;
  try eapply rfb__rf;
  eassumption.
Qed.

Lemma seqcst__rfbtot e :
  well_formed e -> seqcst e -> forall n, rfb e n ⊆ tot e.
Proof.
  intros wf sqc n X Y rfbnXY.
  destruct (wf_tot e wf) as [[irrefl trans] total].
  assert (EV e X /\ EV e Y) as [evX evY].
    apply rf__ev; try  eapply rfb__rf; eassumption.
  destruct (total X evX Y evY).
  - eapply rf__neq; try eapply rfb__rf; eassumption.
  - assumption.
  - exfalso.
    apply (proj1 (sqc n) X).
    exists Y.
    auto.
Qed.

Lemma same_loc__overlap e :
  forall X Y,
  well_formed e ->
  EV e X \/ EV e Y ->
  same_loc X Y ->
  overlap X Y.
Proof.
  intros X Y wf [ev|ev] slXY;
  apply wf_ev in ev; try assumption;
  destruct ev as [[n domn] _];
  exists n;
  split; try assumption;
  [apply (proj1 slXY) | apply (proj2 slXY)];
  assumption.
Qed.

Theorem seqcst__cst exec :
  well_formed exec -> seqcst exec -> (hb exec) ⊆ (tot exec) ->
  consistent exec.
Proof.
  intros wf sqc hbtot.
  pose proof (seqcst__rfbtot exec wf sqc) as rfbtot.
  constructor.
  constructor.
  - assumption.
  - intros R W1 W2.
    unfolder.
    intros [[rf1 [tf1 tfR]] sl1] [[rf2 [tf2 _]] sl2].
    destruct (mev_eq_dec W1 W2) as [eq | neq]. assumption. exfalso.
    destruct (wf_tot exec) as [[irrefl trans] total]; try assumption.
    assert (tot exec W1 W2 \/ tot exec W2 W1) as [tot12 | tot21]. {
      apply total;
      apply rf__ev in rf1; apply rf__ev in rf2;
      destruct rf1, rf2; assumption.
    }
    + destruct rf1 as [n [_ rfb1]].
      apply (proj2 (sqc n) W2).
      unfolder.
      split. split.
      * destruct rf2 as [H1[H2 rfb2]]. eapply rfb__w;
        eassumption.
      * apply same_loc_in_dom with W1.
        -- apply same_loc_trans with R; try assumption.
            apply same_loc_sym. assumption.
        -- eapply rfb_w_dom; eassumption.
      * repeat (eexists; split; eauto).
        destruct rf2 as [n' [_ rfb2]].
        apply (rfbtot n').
        auto.
    + destruct rf2 as [n [_ rfb2]].
      apply (proj2 (sqc n) W1).
      unfolder.
      split. split.
      * destruct rf1 as [H1[H2 rfb1]]. eapply rfb__w;
        eassumption.
      * apply same_loc_in_dom with W2.
        -- apply same_loc_trans with R; try assumption.
            apply same_loc_sym. assumption.
        -- eapply rfb_w_dom; eassumption.
      * repeat (eexists; split; eauto).
        destruct rf1 as [n' [_ rfb1]].
        apply (rfbtot n').
        auto.
  - intros Y [X [hbYX rfXY]].
    unfold transp in rfXY.
    destruct (wf_tot exec wf) as [[irrefl trans] total].
    apply irrefl with X.
    apply trans with Y.
    + destruct rfXY as [n [_ rfnXY]].
      apply (rfbtot n).
      assumption.
    + auto.
  - intros n Z' [Z [[eqZ WZ] [X [hbZX [Y [rfbYX [Z'' [hbYZ [eqZ' domnZ]]]]]]]]].
    subst.
    apply (proj2 (sqc n) Z).
    unfolder.
    split; auto.
    repeat (eexists; split; eauto).
  - intros Z' [Z [[eqZZ' [wZ _]] [X [[totZX slZX] [Y [[[n [_ rfnYX]] _] totYZ]]]]]].
    subst.
    apply (proj2 (sqc n) Z).
    unfolder.
    split.
    + split; try assumption.
      apply same_loc_in_dom with X.
      * apply same_loc_sym. assumption.
      * apply rfb_r_dom with exec Y; assumption.
    + repeat (eexists; split; eauto).
  - intros Z' [Z [[eqZZ' [wZ _]] [X [hbZX [Y' [[[n [_ rfbnYX]] _] [Y [[eqYY' _] [totYZ slYZ]]]]]]]]].
    subst.
    apply (proj2 (sqc n) Z).
    unfolder.
    split.
    + split; auto.
      eapply same_loc_in_dom; try eassumption.
      eapply rfb_w_dom; eassumption.
    + repeat (eexists; split; eauto).
  - intros Z' [Z [[eqZZ' [wZ _]] [X [[totZX slZX] [X' [[eqXX' _] [Y [[[n [_ rfnYX]] _] hbYZ]]]]]]]].
    subst.
    apply (proj2 (sqc n) Z).
    unfolder.
    split.
    + split; auto.
      eapply same_loc_in_dom.
      * apply same_loc_sym. eassumption.
      * eapply rfb_r_dom; eassumption.
    + repeat (eexists; split; eauto).
Qed.

End Exec.


From stdpp Require Import prelude base gmap fin_sets.

Section preimage.
  Context `{FinMap K MK, FinMap A MA, FinSet K SK, !LeibnizEquiv SK}.
  Local Notation map_preimage :=
    (map_preimage (K:=K) (A:=A) (MKA:=MK A) (MASK:=MA SK) (SK:=SK)).
  Implicit Types m : MK A.

  Lemma map_preimage_singleton i x : map_preimage {[i:=x]} = {[x:={[i]}]}.
  Proof.
    apply map_eq. intro y.
    rewrite <- insert_empty. rewrite map_preimage_insert; [ | apply lookup_empty ].
    destruct (decide (x = y)) as [->|Hxy].
    - rewrite lookup_singleton.
      rewrite map_preimage_empty. rewrite lookup_partial_alter, lookup_empty.
      simpl. f_equal. apply right_id. apply _.
    - rewrite lookup_singleton_ne; auto.
      rewrite lookup_partial_alter_ne; auto.
      rewrite map_preimage_empty. apply lookup_empty.
  Qed.
End preimage.

(** * [set_map_2] *)
Section set_map_2.
  Context {A B C : Type}.
  Context `{!EqDecision A, !Countable A, !EqDecision B, !Countable B}.
  Context `{!EqDecision C, !Countable C}.

  Definition set_map_2 `{Elements A SA, Elements B SB, Singleton C SC, Empty SC, Union SC}
    (f : A → B → C) (X : SA) (Y : SB) : SC :=
    set_bind (λ x, set_bind (λ y, {[ f x y ]} ) Y) X.
  Typeclasses Opaque set_map_2.

  Lemma elem_of_set_map_2 (f : A → B → C) (X : gset A) (Y : gset B) (z : C) :
    z ∈ (set_map_2 f X Y : gset C) ↔ ∃ x y, z = f x y ∧ x ∈ X ∧ y ∈ Y.
  Proof. unfold set_map_2. set_solver. Qed.
  Global Instance set_unfold_map (f : A → B → C) (X : gset A) (Y : gset B) (z : C) P Q :
    (∀ x, SetUnfoldElemOf x X (P x)) →
    (∀ y, SetUnfoldElemOf y Y (Q y)) →
    SetUnfoldElemOf z (set_map_2 (SC:=gset C) f X Y) (∃ x y, z = f x y ∧ P x ∧ Q y).
  Proof. intros ? ?. constructor. rewrite elem_of_set_map_2; set_solver. Qed.
End set_map_2.


(* PURPOSE: This file is one example of an event system. It is a less generalized one where the events are concrete measurement actions. There are not corruption or repair actions.

The measurement systems are defined in and imported from MS.v.

This is a continuation of our attempt at Coq model of Paul Rowe's paper titled "Confining Adversary Actions via Measurements" *)

(* CURRENT PROBLEMS: Due to the event system definition, it is difficult  to prove that the event system is a strict partial order.  *)

Require Import Relations.
Require Import Coq.Classes.RelationClasses.

Print LoadPath.
(* Add LoadPath "/Users/annarosefritz/Documents/EECS_research/GitHubRepos/confining/v2". *)

From v2 Require Import MS_noContext.
Print MS.

Section event1.

(* Definition 2: Events. There are 3 labels for event. Measurement event (ms), adversary events (corruption (cor) and repair (rep)) and an attestation start event (att_start)*)

Inductive event :=
| ms : object -> object -> event
| cor : object -> event
| rep : object -> event
| att_start : event.

Check ms o1 o2.

(* example event system.
    attestation starts then the rtm can measure any component.
    after the rtm measure o1, o1 measures o2.
    after that o2 measures o3 *)
Inductive E1 : relation event :=
| start : E1 (att_start) (ms rtm o1)
| mo1_o2 : E1 (ms rtm o1) (ms o1 o2)
| mo2_o3 : E1 (ms o1 o2) (ms o2 o3).

(* As Perry has mentioned, we need the TRC to
have more than just a sigle step of events. *)
Inductive trc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| TrcRefl : forall x, trc R x x
| TrcFront : forall x y z, R x y -> trc R y z -> trc R x z.

(* May need to prove transitivity later on... I'm not sure. *)
Theorem trc_trans : forall {A} (R : A -> A -> Prop) x y, trc R x y
-> forall z, trc R y z
-> trc R x z.
Proof.
(* the key to this proof is induction on the hypothesis *)
intros A R x y. intros H1 z H2. induction H1.
+ apply H2.
+ eapply TrcFront. apply H. apply IHtrc. apply H2.
Qed.

(* this is just the transitive closure *)
Inductive tc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| TcStep : forall x y , R x y -> tc R x y
| TcFront : forall x y z, R x y -> tc R y z -> tc R x z.

(* May need to prove transitivity later on... I'm not sure. *)
Theorem tc_trans : forall {A} (R : A -> A -> Prop) x y, tc R x y
-> forall z, tc R y z
-> tc R x z.
Proof.
(* the key to this proof is induction on the hypothesis *)
intros A R x y. intros H1. induction H1; intros.
+ eapply TcFront. apply H. apply H0.
+ eapply TcFront. apply H. apply IHtc. apply H0.
Qed.

(* Transitive-reflexive closure is so common that it deserves a shorthand notation! *)
Set Warnings "-notation-overridden". (* <-- needed while we play with defining one
* of the book's notations ourselves locally *)
Notation "R ^**" := (trc R) (at level 0).
Notation "R ^*" := (tc R) (at level 0).

(* (ms o1 o2) is in the transitive reflexive closure of the start event. *)
Example measure_o2 : E1^* (att_start) (ms o1 o2).
Proof.
eapply TcFront.
+ apply start.
+ eapply TcStep. apply mo1_o2.
Qed.

Example measure_o3 : E1^* (att_start) (ms o2 o3).
Proof.
eapply TcFront.
+ apply start.
+ eapply TcFront.
++ apply mo1_o2.
++ eapply TcStep. apply mo2_o3.
Qed.

Check E1^*.

(* execution is a poset of events *)
(* a partial order is a preorder that is anti symmetric *)
Definition E' : PreOrder E1.
Proof.
constructor.
+ (* proof events are reflexive...  *)
unfold Reflexive. induction x.
Abort.

(* A preorder is reflexive and transitive. Proving this as a prerec to the partial order. *)
Instance E'' : PreOrder E1^**.
Proof.
constructor.
+ unfold Reflexive. intros. apply TrcRefl.
+ unfold Transitive. intros x y z H1 H2.
induction H1. apply H2. eapply TrcFront. apply H. apply IHtrc. apply H2.

(* can also solve proof with these commands
generalize dependent z. apply trc_trans. apply H.*)
Qed.

Class PartialOrder' {A} (R: relation A) := {
    refl :> Reflexive R ;
    anti_sym :> Antisymmetric _ eq R ;
    trans :> Transitive R
    }.

Instance E : PartialOrder' E1^**.
Proof.
    constructor.
    (* proving reflexivity is easy ... *)
    * unfold  Reflexive. intros. apply TrcRefl.
    (* proving antisymmetric is more difficult ... *)
    * unfold Antisymmetric. intros. eapply TrcFront in H.
    ** inversion H.
    *** reflexivity.
    *** subst. inversion H1.  Abort.
    (* more difficult... maybe impossible. At this point, we realize is must be a strict partial order. *)

Lemma E_trans : Transitive E1^*.
Proof.
    Abort.

Class StrictPartialOrder {A} (R: relation A) := {
    asym :> Asymmetric R ;
    arefl :> Irreflexive R ;
    strans :> Transitive R
}.

Check MS.
Check E1.

Lemma m_irr : forall x, E1 x x -> False.
Proof.
    intros. inversion H.
Qed.

Check Asymmetric.

Theorem E_asym : forall x y, ~ (E1 x y /\ E1 y x).
Proof.
    intros. cbv in *. intros. inversion H. inversion H0. inversion H1. subst. inversion H4. subst. inversion H5. subst. inversion H5. subst. inversion H1. subst. inversion H1.
Qed.

Instance E_strict : StrictPartialOrder E1^*.
Proof.
    constructor.
    + induction 1.
    ++ intros. inversion H0; subst. inversion H; inversion H1; subst; try inversion H4; try inversion H5. absurd ((E1) ^* y x -> (E1) ^* y0 x). unfold not. apply TcFront.  auto.

Class StrictPartialOrder' {A} (R: relation A) := {
    (* arefl :> Irreflexive R ;
    asym :> Asymmetric R ; *)
    strans' :> Transitive R
}.

Instance E_strict' : StrictPartialOrder' E1.
Proof.
    constructor. unfold Transitive. intros x y z H. induction H.
    + intros. (* no where to go, need transitive closure *) Abort.

Instance E_strict' : StrictPartialOrder' E1^*.
Proof.
    constructor.
    + unfold Transitive. intros x y z. intros h1. induction h1; intros.
    ++ eapply TcFront.
    +++ apply H.
    +++ apply H0.
    ++ eapply TcFront.
    +++ apply H.
    +++ apply IHh1. apply H0.
Qed.

End event1.

(* *)


Require Import ExtLib.Core.RelDec.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance RelDec_eq : RelDec (@eq bool) :=
{ rel_dec := fun x y => match x , y with
                          | true , true
                          | false , false => true
                          | _ , _=> false
                        end }.

Global Instance RelDec_Correct_eq_bool : RelDec_Correct RelDec_eq.
  constructor. destruct x; destruct y; auto; simpl; intuition.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal29.

Set Printing Depth 1000.
Definition lfind_eval  n:=
Cons n Nil.

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).


From Coq Require Import List Bool FunInd.
From CoLoR Require Import weaved_relation closure term_spec terminaison.
From CoLoR Require equational_theory_spec closure_extension.

Module Make  (Eqt:equational_theory_spec.EqTh).

Lemma one_step_list_same_length :
  forall R l1 l2, one_step_list (Eqt.one_step R) l2 l1 -> length l1 = length l2.
Proof.
  intros R l1 l2 H; apply sym_eq; apply one_step_list_length_eq with (Eqt.one_step R); assumption.
Qed.

Lemma rwr_as_star : forall R t t', Eqt.rwr R t t' -> star _ (Eqt.one_step R) t t'.
Proof.
  induction 1.
  apply star_R. assumption.

  apply star_trans with y;auto.
  right with x; [left | assumption].
Qed.

Lemma one_step_list_star_decompose_cons :
  forall R x l l'', refl_trans_clos (one_step_list (Eqt.one_step R)) (x::l) l'' ->
    exists x', exists l',
      l'' = x'::l' /\
      refl_trans_clos (Eqt.one_step R) x x'/\
      refl_trans_clos (one_step_list (Eqt.one_step R)) l l'.
Proof.
  intros R x l l''.
  set (l1 := x::l) in *.
  generalize (eq_refl l1); unfold l1 at 1;clearbody l1.
  intros H H0  .
  revert x l  H.
  induction H0.
  rename x into l0.

  intros x l He;subst.
  exists x;exists l;repeat split;constructor.

  rename x into l';rename y into l.
  induction H.
  inversion H;clear H;subst.
  intros a b Heq;injection Heq;clear Heq;intros;subst.
  exists t2;exists l.
  repeat (assumption||constructor).
  intros a b Heq;injection Heq;clear Heq;intros;subst.
  exists t;exists l2.
  repeat (assumption||constructor).

  inversion H;clear H;subst;  intros;  injection H;clear H;intros;subst.
  destruct (IHtrans_clos _ _ (eq_refl _)) as [u [l'' [h1 [h2 h3]]]];clear IHtrans_clos.
  subst.
  exists u;exists l''.
  split. apply eq_refl.
  split.
  apply refl_trans_clos_is_trans with t2;  repeat (assumption||constructor).
  assumption.

  destruct (IHtrans_clos _ _ (eq_refl _)) as [u [l'' [h1 [h2 h3]]]];clear IHtrans_clos.
  subst.
  exists u;exists l''.
  split. apply eq_refl.
  split.
  assumption.
  apply refl_trans_clos_is_trans with l2;  repeat (assumption||constructor).
Qed.

Lemma one_step_list_star_decompose_nil :
  forall R l'', refl_trans_clos (one_step_list (Eqt.one_step R)) nil l'' -> l'' = nil.
Proof.
  intros R l'' H.
  set (l:= @nil Eqt.T.term) in *.
  generalize (eq_refl l).
  unfold l at 1;clearbody l.
  induction H;intro;subst;auto.
  inversion H;clear H;subst;  inversion H0.
Qed.

Lemma one_step_list_star_l : forall  R l x y,
  refl_trans_clos (Eqt.one_step R) x y ->
  refl_trans_clos (one_step_list (Eqt.one_step R)) (x::l) (y::l).
Proof.
induction 1.
constructor.
constructor.
induction H.
repeat  (assumption || constructor).
constructor 2 with (y::l).
repeat  (assumption || constructor).
assumption.
Qed.

Lemma one_step_list_star_r : forall R l l' x,
  refl_trans_clos (one_step_list (Eqt.one_step R)) l l' ->
  refl_trans_clos (one_step_list (Eqt.one_step R)) (x::l) (x::l').
Proof.
induction 1.
constructor.
induction H.
repeat (exact H || constructor).
apply refl_trans_clos_is_trans with (x::y).
constructor.
constructor.
repeat (exact H || constructor).
assumption.
Qed.

Lemma one_step_list_refl_trans_clos : forall  R l l' x y,
  refl_trans_clos (Eqt.one_step R) x y ->
  refl_trans_clos (one_step_list (Eqt.one_step R)) l l' ->
  refl_trans_clos (one_step_list (Eqt.one_step R)) (x::l) (y::l').
Proof.
  intros R l l' x y H H0.

apply refl_trans_clos_is_trans with (x::l').
apply one_step_list_star_r. assumption.
apply one_step_list_star_l. assumption.
Qed.

Import Eqt.
Import T.
Import Relation_Definitions.
Lemma one_step_ind2
     : forall (R : relation term)
         (P : forall t t0 : term, one_step R t t0 -> Prop)
         (P0 : forall l l0 : list term, one_step_list (one_step R) l l0 -> Prop),
       (forall (t1 t2 : term) (a : axiom R t1 t2), P t1 t2 (at_top R t1 t2 a)) ->
       (forall (f0 : symbol) (l1 l2 : list term) (o : one_step_list (one_step R) l1 l2),
        P0 l1 l2 o -> P (Term f0 l1) (Term f0 l2) (in_context R f0 l1 l2 o)) ->
       (forall (t1 t2 : term) (l : list term) (o : one_step R t1 t2),
        P t1 t2 o -> P0 (t1 :: l) (t2 :: l) (head_step (one_step R) t1 t2 l o)) ->
       (forall (t : term) (l1 l2 : list term) (o : one_step_list (one_step R) l1 l2),
        P0 l1 l2 o -> P0 (t :: l1) (t :: l2) (tail_step t o)) ->
       forall (t t0 : term) (o : Eqt.one_step R t t0), P t t0 o
.
Proof.
  intros R P P0 H H0 H1 H2.
  fix one_step_ind2 3.
  intros t t0 [t1 t2 a|f l1 l2 o].
  apply H.
  apply H0.
  revert l1 l2 o.
  fix one_step_list_ind2 3 .
  intros l1 l2 [t1 t2 l a|t1 l1' l2' a].
  apply H1.
  apply one_step_ind2.
  apply H2.
  apply one_step_list_ind2.
Qed.

Lemma star_list :
  forall R f l l', refl_trans_clos (one_step_list (one_step R)) l' l ->
  refl_trans_clos (one_step R) (Term f l') (Term f l).
Proof.
  intros R f l l' H.
  induction H.
  constructor.
  constructor.
  induction H.
  constructor.
  constructor 2;assumption.

  constructor 2 with (Eqt.T.Term f y).
  constructor 2;assumption.
  assumption.
Qed.

Import closure_extension.

Lemma star_cons : forall R t l t' l',
  refl_trans_clos (one_step R) t' t ->
  refl_trans_clos (one_step_list (one_step R)) l' l ->
  refl_trans_clos (one_step_list (one_step R)) (t'::l') (t::l).
Proof.
  intros R t l t' l' H H0.

  apply refl_trans_clos_is_trans with (t::l').
  clear H0.
  induction H.
  constructor.
  induction H.
  apply refl_trans_clos_with_R.
  constructor;assumption.

  apply refl_trans_clos_is_trans with (y::l').
  apply refl_trans_clos_with_R.
  constructor;assumption.
  assumption.

  clear H;induction H0.
  constructor.
  induction H.
  apply refl_trans_clos_with_R.
  constructor;assumption.
  apply refl_trans_clos_is_trans with (t::y).
  apply refl_trans_clos_with_R.
  constructor;assumption.
  assumption.
Qed.

Lemma cons_star : forall R t l t' l',
  refl_trans_clos (one_step_list (one_step R)) (t'::l') (t::l) ->
  refl_trans_clos (one_step R) t' t/\
  refl_trans_clos (one_step_list (one_step R)) l' l.
Proof.
  intros R t l t' l' H.
  set (l1:= t'::l') in *; generalize (eq_refl l1);unfold l1 at 1;clearbody l1.
  set (l2:= t::l) in *; generalize (eq_refl l2);unfold l2 at 1;clearbody l2.
  revert t l t' l'.
  induction H.
  intros;do 2 subst.
  injection H0;clear H0;intros;subst.
  split;constructor.
  induction H.
  induction H.
  intros t l0 t' l' H0 H1.
  injection H0;injection H1;clear H0 H1.
  intros;repeat subst.
  split.
  constructor 2;constructor;assumption.
  constructor.
  intros tk l0 t' l' H0 H1.
  injection H0;injection H1;clear H0 H1.
  intros;repeat subst.
  split.
  constructor.
  constructor 2;constructor;assumption.
  intros t l t' l' H1 H2.
  subst.
  inversion H;subst.
  destruct (IHtrans_clos _ _ _ _ (eq_refl _) (eq_refl _)) as [h1 h2].
  clear IHtrans_clos H H0.
  split.
  inversion h1;subst;clear h1.
  constructor. constructor;assumption.
  constructor. constructor 2 with t2; assumption.
  assumption.
  destruct (IHtrans_clos _ _ _ _ (eq_refl _) (eq_refl _)) as [h1 h2].
  clear IHtrans_clos H H0.
  split.
  assumption.
  inversion h2;subst;clear h2.
  constructor. constructor;assumption.
  constructor. constructor 2 with l2; assumption.
Qed.

  Function inb (A:Type) (eq_bool: A -> A -> bool) (f:A) (l:list A) {struct l} : bool :=
    match l with
      | nil => false
      | g::l => orb (eq_bool g f) (inb A eq_bool f l)
    end.

  Lemma inb_equiv :
    forall (A:Type) aeq_bool f l, (forall f g:A, f=g <-> aeq_bool f g = true) ->
      (In f l <-> inb _ aeq_bool f l=true).
  Proof.
    intros A aeq_bool f l H.
    functional induction (inb _ aeq_bool f l).
    simpl;intuition.
    simpl.
    rewrite H.
    case (aeq_bool g f);simpl. clear;intuition.
    rewrite (IHb). intuition.
  Qed.

Section is_def.
  Variable defined_list : list symbol.
  Variables rules : relation term.
  Variables rule_list : list (term*term).
  Hypothesis rules_equiv : forall l r : term, rules r l <-> In (l, r) rule_list.

  Hypothesis  defined_list_equiv :
    forall f : symbol,
      In f (defined_list) <-> defined rules f.

  Definition is_def f :=
      inb _ F.Symb.eq_bool f defined_list.

  Lemma is_def_equiv :
    forall f : symbol,
      is_def f = true <-> defined rules f.
  Proof.
    intros f.
    unfold is_def.
    rewrite <- defined_list_equiv.
    rewrite (inb_equiv _ F.Symb.eq_bool) .
    reflexivity.
    clear;intros f g.
    generalize (F.Symb.eq_bool_ok f g).
    case (F.Symb.eq_bool f g);[tauto|intuition discriminate].
  Qed.
End is_def.

End Make.


Require Export Segment.

Definition Ord X :=
    We E X /\ Trans X.

Definition On :=
  {| Ord |}.

Theorem on_ord x (x_ : M x) :
    x ∈ On <-> Ord x.
Proof.
  by rewrite in_cls.
Qed.

Theorem RelE :
  Rel E.
Proof.
  move => p H.
  have p_ : M p by is_set.
  move /(in_cls _ p p_) : H => [x [y [x_ [y_ [p_xy xy]]]]].
  apply in_cls => //.
  exists x; exists y.
  by rewrite !in_universe.
Qed.

Theorem empty_on :
  ∅ ∈ On.
Proof.
  move : empty_set => e_.
  rewrite  on_ord => //.
  split.
  + split => [|Y [Ye F]].
    - split.
      * apply RelE.
      * move => x F.
        have x_ : M x by is_set.
        case (notin_empty x x_ F).
    - move /not_empty : F => [y yY].
      move : (Ye y yY) => F.
      have y_ : M y by is_set.
      case (notin_empty y y_ F).
  + move => x F.
    have x_ : M x by is_set.
    case (notin_empty x x_ F).
Qed.

Theorem ord_notrefl X:
  Ord X  -> ~ X ∈ X.
Proof.
  move => [[[RelE irr] we] H] XX.
  have X_ : M X by is_set.
  have XX_ : X ∈ X by auto.
  move : XX_.
  rewrite -orderd_in_E => //.
  by apply irr.
Qed.

Theorem ord_ele_notrefl X :
  Ord X -> forall x, x ∈ X -> ~ x ∈ x.
Proof.
  intros [[[RelE irr] we] H] x xX xx.
  have x_ : M x by is_set.
  apply (irr x xX).
  by apply orderd_in_E => //.
Qed.

Theorem ord_in_on X Y :
    Ord X -> Y ∈ X -> Y ∈ On.
Proof.
  move => [[[RelE irrX] weX] traX] YX.
  have trX : Tr E X by apply we_tr.
  move  : trX => [_ trX].
  suff weY : We E Y.
  + apply on_ord.
    is_set.
    split => //.
    move  => Z ZY i iZ.
    move : (traX Y YX) => Y_X.
    move : (Y_X Z ZY) => ZX.
    move : (traX Z ZX) => Z_X.
    move : (Z_X i iZ) => iX.
    have Y_ : M Y by is_set.
    have Z_ : M Z by is_set.
    have i_ : M i by is_set.
    apply orderd_in_E => //.
    apply (trX i Z Y).
    move /(orderd_in_E i Z i_ Z_) : iZ => iZ.
    move /(orderd_in_E Z Y Z_ Y_) : ZY => ZY.
    done.
  + split => //.
    - split => //.
      move => y yY.
      apply irrX.
      apply (traX Y) => //.
    - move => Z [ZY _Z].
      have ZX : Z ⊂ X.
        apply sub_trans with (Y := Y) => //.
        apply traX => //.
      apply weX  => //.
Qed.

Theorem trans_on :
  Trans On.
Proof.
  move => a a_On z za.
  have a_ : M a by is_set.
  move /(on_ord a a_) : a_On => [wea Tra].
  move : (we_tot  wea) => [[relE tra] [[_ irra] [_ cona]]].
  have z_ : M z by is_set.
  apply on_ord => //.
  split.
  + apply we_sub with (X := a) => //.
    apply Tra => //.
  + move => y  yz x xy.
    have x_ : M x by is_set.
    have y_ : M y by is_set.
    move : (Tra z za y yz) => ya.
    move : (Tra y ya x xy) => xa.
    rewrite -(orderd_in_E x z x_ z_).
    apply tra with (y := y).
    rewrite !orderd_in_E => //.
Qed.

Theorem cap_ord X Y :
  Ord X -> Ord Y -> Ord (X ∩ Y).
Proof.
  move => [weX TrX] [weY TrY].
  split.
  + apply we_sub with (X := X) => //.
    apply cap_sub_l.
  + apply cap_trans => //.
Qed.

Theorem ord_subin X Y :
  Ord X -> Ord Y -> X ⊂ Y <-> (X ∈ Y) \/ X = Y.
Proof.
  move => [weX TrX] [weY TrY].
  split => [X_Y | [XY | XY]].
  + case (classic (X = Y)) => [XY|_XY]; [right|left] => //.
    pose Z := Y ~ X.
    have _Z : Z <> ∅ by apply diff_sub.
    have ZY : Z ⊂ Y.
      move => i iZ.
      have i_ : M i by is_set.
      by move /diff : iZ => [iY _].
    inversion  weY as [[_ irrY] wey].
    move : (wey Z (conj ZY _Z)) => [m [mZ Hm]].
    have m_ : M m by is_set.
    suff Xm : X = m.
    - subst m.
      apply ZY => //.
    - move /diff : mZ => [mY _mX].
      equal => i.
      move : (we_tot weY) => [[_ trY] [_ [_ conY]]].
      split => [iX|im]; have i_ : M i by is_set.
      * move : (X_Y i iX) => iY.
        case (classic (m = i)) => [mi | _mi].
        (***)
          subst i.
          case (_mX iX).
        (***)
          case : (conY m i (conj mY (conj iY _mi))) => [mi |im].
          (***)
            move /(orderd_in_E m i m_ i_) : mi => mi.
            move : (TrX i iX m mi) => mX.
            case (_mX mX).
          (***)
            rewrite -orderd_in_E => //.
      * have m_X : m ⊂ X.
          move => j jm.
          move : (TrY m mY j jm) => jY.
          move : (Hm j) => Hj.
          case /imply_to_or : Hj => [H0|H0].
            case /not_and_or : H0 => H0.
              apply NNPP => F; apply H0.
              apply diff => //.
              apply NNPP => F; apply H0 => i_m.
              subst j.
              apply (irrY m mY).
              rewrite orderd_in_E => //.
              move : H0 => [_ _im].
              have j_ : M j by is_set.
              move /(orderd_in_E j m j_ m_):_im => _im.
              case (_im jm).
        apply m_X => //.
  + move => i iX.
    apply (TrY X XY i iX).
  + by subst X.
Qed.

Theorem diff_set X Y (X_ : M X) :
    M (X ~ Y).
Proof.
  apply sep_set => //.
Qed.

Theorem we_on :
  We E On.
Proof.
  have irrOn : Irr E On.
  + split.
    - apply RelE.
    - move => x x_On.
      have x_ : M x by is_set.
      rewrite orderd_in_E => //.
      apply ord_notrefl.
      rewrite -on_ord => //.
  + move : irrOn => [RelE irrOn].
    split => //.
    move => X [X_On _X].
    move /not_empty : _X => [x xX].
    have x_ : M x by is_set.
    move : (X_On x xX) => xOn.
    move : (trans_on x xOn) => x_On.
    move /(on_ord x x_) : xOn => [[[_ irrx] wex] Trx].

    pose Y := X ~ x.
    have Y_X : Y ⊂ X.
      move => i iY.
      have i_ : M i by is_set.
      by move /diff : iY => [iX _].
    have _Xx : X <> x.
      move => Xx; subst x.
      have X_ : M X by is_set.
      move : (X_On X xX) => ordX.
      move /(on_ord X X_) : ordX => ordX.
      move : (ord_notrefl X ordX).
      by apply.

    pose Y := X ∩ x.
    have Y_x : Y ⊂ x.
      move => i iY; have i_ : M i by is_set.
      by move /in_cap : iY => [_ ix].
    move : (wex Y).
    case /imply_to_or => H.
    - case /not_and_or : H => [_Y_x|_Y] => //.
      exists x.
      split => //.
      move => y [yX _yx].
      have _y : M y by is_set.
      rewrite !orderd_in_E => //.
      split; first last.
      * move => yx.
        apply _Y.
        apply not_empty.
        exists y.
        by apply in_cap.
      * apply NNPP => _xy.
        apply _Y.
        apply not_empty.


Require Forcing.

Section Nat.

Variable Obj : Type.
Variable Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Forcing Translate nat using Obj Hom.

Fixpoint nat_rec_ (p : Obj)
  (P : forall p0 : Obj, p ≤ p0 -> forall p : Obj, p0 ≤ p -> Type)
  (H0 : forall (p0 : Obj) (α : p ≤ p0),
       P p0 (fun (R : Obj) (k : Hom p0 R) => α R k) p0 #)
  (HS : forall (p0 : Obj) (α : p ≤ p0),
       (forall (p : Obj) (α0 : p0 ≤ p), P p (α ∘ α0) p #) ->
       P p0 (fun (R : Obj) (k : Hom p0 R) => α R k) p0 #)
  (n : natᶠ p):
   P p # p # := match n with
            | Oᶠ _ =>    H0 p #
            | Sᶠ _ n0 => HS p #
                   (fun (p1 : Obj) (α1 : p ≤ p1) =>
                      nat_rec_ p1
                        (fun p1 f1 => P  p1 (α1 ∘ f1))
                        (fun p1 f1 => H0 p1 (α1 ∘ f1))
                        (fun p1 f1 => HS p1 (α1 ∘ f1))
                        (n0 p1 α1))
            end.

Forcing Definition nat_rec : forall (P : Type), P -> (P -> P) -> nat -> P using Obj Hom.
Proof.
  intros p P H0 HS n.
  exact (nat_rec_ p P H0 HS (n p #)).
Defined.

Definition foo := fun (P : Type) (H0 : P) (HS : P -> P) => nat_rec P H0 HS O.
Definition bar := fun (P : Type) (H0 : P) (HS : P -> P) (n : nat) => nat_rec P H0 HS (S n).
Definition qux := fun (P : Type) (H0 : P) (HS : P -> P) (n : nat) => HS (nat_rec P H0 HS n).

Forcing Translate foo using Obj Hom.
Forcing Translate bar using Obj Hom.
Forcing Translate qux using Obj Hom.

Eval compute in barᶠ.
Eval compute in quxᶠ.

Check (eq_refl : barᶠ = quxᶠ).

Definition nat_mem : forall R, nat -> (nat -> R) -> R :=
  fun R : Type =>
    nat_rec ((nat -> R) -> R) (fun f => f O)
            (fun H f => H (fun n => f (S n))).

Forcing Translate nat_mem using Obj Hom.

Forcing Definition nat_rect : forall (P : nat -> Type),
    P O ->
    (forall (n:nat), nat_mem _ n P -> nat_mem _ (S n) P) ->
    forall n : nat, nat_mem _ n P using Obj Hom.
Proof.

  intros p P H0 HS n. unfold nat_memᶠ, nat_recᶠ . set (n0 := n p #). clearbody n0; clear n.

  (* avoiding noise in the actual definition *)
  (* may be improved using LTac ? *)

  set (Type_of_P := fun p => forall p0 : Obj,
      p ≤ p0 ->
      (forall p : Obj, p0 ≤ p -> natᶠ p) ->
      forall p : Obj, p0 ≤ p -> Type).
  set (Type_of_H0 := fun p (P:Type_of_P p) => forall (p0 : Obj) (α : p ≤ p0),
       P p0 (# ∘ (α ∘ #)) (fun (p : Obj) (_ : p0 ≤ p) => Oᶠ p) p0 #).
  set (Type_of_HS := fun p (P:Type_of_P p) => forall (p0 : Obj) (α : p ≤ p0)
         (n : forall p : Obj, p0 ≤ p -> natᶠ p),
       (forall (p1 : Obj) (α0 : p0 ≤ p1),
        nat_memᶠ p1
          (fun (p : Obj) (_ : p1 ≤ p) (p2 : Obj) (_ : p ≤ p2) =>
           forall p3 : Obj, p2 ≤ p3 -> Type)
          (fun (p : Obj) (α1 : p1 ≤ p) => n p (# ∘ (α0 ∘ (α1 ∘ #))))
          (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
           P p2 (# ∘ (# ∘ (α ∘ (# ∘ (# ∘ (α0 ∘ (α1 ∘ #)))))))) p1
          #) ->
       nat_memᶠ p0
         (fun (p : Obj) (_ : p0 ≤ p) (p1 : Obj) (_ : p ≤ p1) =>
          forall p2 : Obj, p1 ≤ p2 -> Type)
         (fun (p : Obj) (α0 : p0 ≤ p) =>
          Sᶠ p
            (fun (p1 : Obj) (α1 : p ≤ p1) => n p1 (# ∘ (α0 ∘ (α1 ∘ #)))))
         (fun (p1 : Obj) (α0 : p0 ≤ p1) =>
          P p1 (# ∘ (# ∘ (α ∘ (# ∘ (# ∘ (α0 ∘ #))))))) p0
         #).
  set (Type_of_Goal := fun p (P:Type_of_P p) (H0:Type_of_H0 p P) (HS:Type_of_HS p P) (n0: natᶠ p) => nat_rec_ p
     (fun (p0 : Obj) (_ : p ≤ p0) (p1 : Obj) (_ : p0 ≤ p1) =>
      (forall p2 : Obj,
       p1 ≤ p2 ->
       (forall p3 : Obj, p2 ≤ p3 -> natᶠ p3) ->
       forall p3 : Obj, p2 ≤ p3 -> Type) ->
      forall p2 : Obj, p1 ≤ p2 -> Type)
     (fun (p0 : Obj) (_ : p ≤ p0)
        (f : forall p1 : Obj,
             p0 ≤ p1 ->
             (forall p2 : Obj, p1 ≤ p2 -> natᶠ p2) ->
             forall p2 : Obj, p1 ≤ p2 -> Type) =>
      f p0 # (fun (p1 : Obj) (_ : p0 ≤ p1) => Oᶠ p1))
     (fun (p0 : Obj) (_ : p ≤ p0)
        (H : forall p1 : Obj,
             p0 ≤ p1 ->
             (forall p2 : Obj,
              p1 ≤ p2 ->
              (forall p3 : Obj, p2 ≤ p3 -> natᶠ p3) ->
              forall p3 : Obj, p2 ≤ p3 -> Type) ->
             forall p2 : Obj, p1 ≤ p2 -> Type)
        (f : forall p1 : Obj,
             p0 ≤ p1 ->
             (forall p2 : Obj, p1 ≤ p2 -> natᶠ p2) ->
             forall p2 : Obj, p1 ≤ p2 -> Type) =>
      H p0 #
        (fun (p1 : Obj) (α0 : p0 ≤ p1)
           (n : forall p2 : Obj, p1 ≤ p2 -> natᶠ p2) =>
         f p1 (fun (R : Obj) (k : Hom p1 R) => α0 R k)
           (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
            Sᶠ p2 (fun (p3 : Obj) (α2 : p2 ≤ p3) => n p3 (α1 ∘ α2))))) n0
     (fun (p0 : Obj) (α : p ≤ p0) =>
      P p0 (fun (R : Obj) (k : Hom p0 R) => α R k)) p
     #).

  change (Type_of_Goal p P H0 HS n0).

  revert p P H0 HS n0.
  compute.
  (* Now the definition using a fixpoint *)
  refine (fix F p
              (P : Type_of_P p)
              (H0 : Type_of_H0 p P)
              (HS : Type_of_HS p P)
              (n0 : natᶠ p) : Type_of_Goal p P H0 HS n0
             := match n0 as n1 in natᶠ _ return Type_of_Goal p P H0 HS n1 with
            | Oᶠ _ =>   H0 p #
            | Sᶠ _ n => HS p # n
                   (fun (p1 : Obj) (α1 : p ≤ p1) =>
                      F p1
                        (fun p1 f1 => P  p1 (α1 ∘ f1))
                        (fun p1 f1 => H0 p1 (α1 ∘ f1))
                        (fun p1 f1 => HS p1 (α1 ∘ f1))
                        (n p1 α1)) end
         ).

Defined.

Definition bar2 := fun (P : nat -> Type) (H0 : P O)
    (HS : (forall (n:nat), nat_mem _ n P -> nat_mem _ (S n) P))
    (n : nat) => nat_rect P H0 HS (S n).
Definition qux2 := fun (P : nat -> Type) (H0 : P O)
    (HS : (forall (n:nat), nat_mem _ n P -> nat_mem _ (S n) P))
    (n : nat) => HS n (nat_rect P H0 HS n).

Forcing Translate bar2 using Obj Hom.
Forcing Translate qux2 using Obj Hom.

Eval compute in bar2ᶠ.
Eval compute in qux2ᶠ.

Check (eq_refl : bar2ᶠ = qux2ᶠ).

End Nat.