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

Definition chooseS (m : Mode) X (C : typ) (D : typ) :=
  match m with
  | Pos => subst_tt X C
  | Neg => subst_tt X D
  end.

Definition choose (m : Mode)  (C : typ) (D : typ) :=
  match m with
  | Pos => C
  | Neg => D
  end.

Lemma chooseS_arrow : forall m X C D A1 A2,
    chooseS m X C D (typ_arrow A1 A2) = typ_arrow (chooseS m X C D A1) (chooseS m X C D A2).
  intros. destruct m; simpl in *; eauto.
Defined.

Lemma chooseS_and : forall m X C D A1 A2,
    chooseS m X C D (typ_and A1 A2) = typ_and (chooseS m X C D A1) (chooseS m X C D A2).
  intros. destruct m; simpl in *; eauto.
Defined.

Lemma choose_flip: forall m A B ,
    choose m A B = choose (flip m) B A .
Proof with auto.
  intros.
  destruct m...
Qed.

Lemma mu_transform_0: forall C  (Y X:atom) A ,
    type (typ_mu C) ->
    X <> Y ->
    (subst_tt X (typ_mu C) (open_tt A (typ_rcd Y (open_tt A Y)))) =
 (open_tt (subst_tt X (typ_mu C) A)
       (typ_rcd Y (open_tt (subst_tt X (typ_mu C) A) Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal.
  simpl...
  f_equal.
  rewrite subst_tt_open_tt_var...
Qed.

Lemma mu_transform_1: forall C D (Y X:atom) A m,
    type (typ_mu (choose m C D)) ->
    X <> Y ->
    (subst_tt X (typ_mu (choose m C D)) (open_tt A (typ_rcd Y (open_tt A Y)))) =
 (open_tt (subst_tt X (typ_mu (choose m C D)) A)
       (typ_rcd Y (open_tt (subst_tt X (typ_mu (choose m C D)) A) Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal.
  simpl...
  f_equal.
  rewrite subst_tt_open_tt_var...
Qed.

Lemma mu_transform_2: forall (X Y:atom) C D A m,
    type (typ_rcd X (choose m (open_tt C X) (open_tt D X))) ->
     X <> Y ->
    open_tt (subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X))) A)
    (typ_rcd Y (open_tt (subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X))) A) Y)) =
  subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X)))
    (open_tt A (typ_rcd Y (open_tt A Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma mu_transform3: forall X0 A1 X C ,
    X <> X0 -> type (typ_rcd X C) ->
    (subst_tt X (typ_rcd X C) (open_tt A1 (typ_rcd X0 (open_tt A1 X0)))) =
(open_tt (subst_tt X (typ_rcd X C) A1)
       (typ_rcd X0 (open_tt (subst_tt X (typ_rcd X C) A1) X0))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma subst_tt_equiv: forall E A B,
    Sub E A B -> forall C D X,
    equiv E C D ->
    Sub E (subst_tt X (typ_rcd X C) A) (subst_tt X (typ_rcd X D) B).
Proof with auto.
  intros E A B H.
  induction H;intros;unfold equiv in *;destruct_hypos;simpl in *;try solve [constructor]...
  -
    destruct (X==X0)...
  -
    constructor...
    get_well_form.
    apply subst_tt_wfs...
  -
    constructor...
    get_well_form.
    apply subst_tt_wfs...
  -
    apply S_andR...
    get_well_form.
    apply subst_tt_wfs...
  -
    apply S_rec with (L:=L \u {{X}} \u dom E);intros.
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wfs...
      get_well_form.
      constructor...
      add_nil.
      apply WFS_weakening...
      apply H...
      get_type...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wfs...
      get_well_form.
      constructor...
      add_nil.
      apply WFS_weakening...
      apply H0...
      get_type...
    +
      rewrite <- mu_transform3...
      rewrite <- mu_transform3...
      apply H2...
      split.
      rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
      apply Sub_weakening...
      simpl.
      constructor...
      get_well_form...
      rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
      apply Sub_weakening...
      simpl.
      constructor...
      get_well_form...
      get_type...
      get_type...
  -
    apply S_top...
    get_well_form.
    apply subst_tt_wfs...
Qed.

Lemma open_var_distinct : forall C i j A B ,
    i <> j ->
    type A -> type B ->
  open_tt_rec i A (open_tt_rec j B C) = open_tt_rec j B (open_tt_rec i A C).
Proof with congruence || eauto.
  intros C.
  induction C;intros;simpl;try solve [f_equal;eauto]...
  -
    destruct (j==n)...
    destruct (i==n)...
    subst...
    simpl...
    destruct (n==n)...
    rewrite <- open_tt_rec_type...
    destruct (i==n)...
    simpl...
    destruct (i==n)...
    rewrite <- open_tt_rec_type...
    simpl...
    destruct (i==n)...
    destruct (j==n)...
Qed.

Lemma rcd_transform1: forall C  k (X Y:atom),
     (typ_rcd Y (open_tt_rec 0 Y (open_tt_rec (S k) X C)) = open_tt_rec (S k) X (typ_rcd Y (open_tt_rec 0 Y C))).
Proof with auto.
  intros.
  simpl.
  f_equal...
  rewrite <- open_var_distinct...
Qed.

Lemma wf_env_weakening: forall E1 E2 X,
    wf_env (E1++E2) ->
    X \notin dom (E1++E2) ->
    wf_env (E1 ++ (X~bind_sub) ++ E2).
Proof with auto.
  intros E1.
  induction E1;intros...
  constructor...
  destruct a.
  rewrite_alist ((a, b) :: E1 ++ E2) in H.
  rewrite_alist ((a, b) :: E1 ++ [(X, bind_sub)] ++ E2).
  dependent destruction H.
  constructor...
  constructor...
  apply WFS_weakening...
Qed.

Lemma Sub_subst_rcd_dismiss: forall E E1 A B X C D,
    X `notin` fl_tt A \u fl_tt B ->
    Sub (E1++[(X, bind_sub)] ++ E) (subst_tt X (typ_rcd X C) A)
        (subst_tt X (typ_rcd X D) B) ->
    type C -> type D ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) A ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) B ->
    Sub (E1++[(X, bind_sub)] ++ E) A B.
Proof with auto.
  intros.
  dependent induction H0;try solve [simpl in *;auto]...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    simpl in *.
    destruct (a==X);destruct (a0==X);try solve [inversion x0|inversion x]...
    rewrite <-x0.
    rewrite <-x.
    apply Reflexivity...
  -
    induction A;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    clear IHB1 IHB2 IHA1 IHA2.
    simpl in *.
    inversion x0.
    inversion x.
    dependent destruction H3.
    dependent destruction H4.
    constructor...
    apply IHSub1 with (C:=D) (D:=C)...
    apply IHSub2 with (C:=C) (D:=D)...
  -
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    simpl in *.
    inversion x.
    dependent destruction H4.
    constructor...
    apply IHSub1 with (C0:=C) (D:=D)...
    apply IHSub2 with (C0:=C) (D:=D)...
  -
    induction A;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    simpl in *.
    inversion x.
    dependent destruction H4.
    apply S_andL...
    apply IHSub with (C:=C) (D0:=D)...
  -
    induction A;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    simpl in *.
    inversion x.
    dependent destruction H4.
    apply S_andR...
    apply IHSub with (C:=C) (D0:=D)...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    clear IHA IHB.
    simpl in *.
    inversion x0.
    inversion x.
    dependent destruction H6.
    dependent destruction H8.
    apply S_rec with (L:=L \u L0 \u L1 \u fv_tt A \u fv_tt B \u {{X}} \u fv_tt C
                     \u fv_tt D \u dom (E1 ++(X~ bind_sub)++ E));intros...
    rewrite_alist  (([(X0, bind_sub)] ++ E1) ++ (X, bind_sub) :: E).
    apply H2 with (X0:=X0) (C:=C) (D:=D)...
    *
      apply notin_union...
      split;apply notin_fl_tt_open;simpl.
      auto.
      apply notin_union.
      split...
      apply notin_fl_tt_open...
      auto.
      apply notin_union.
      split...
      apply notin_fl_tt_open...
    *
      subst.
      rewrite  subst_tt_open_tt...
      f_equal...
      simpl...
      f_equal...
      rewrite  subst_tt_open_tt_var...
    *
      subst.
      rewrite  subst_tt_open_tt...
      f_equal...
      simpl...
      f_equal...
      rewrite  subst_tt_open_tt_var...
    *
      apply H6...
    *
      apply H8...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0];
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    +
      simpl in *.
      destruct (a==X);destruct (a0==X);try solve [inversion x|inversion x0]...
      inversion x.
      inversion x0;subst.
      apply Reflexivity...
      get_well_form...
    +
      clear IHB.
      simpl in *.
      destruct (a==X);subst;try solve [inversion x0]...
      inversion x0.
      inversion x;subst...
      apply notin_union in H.
      destruct H.
      apply notin_union in H5.
      destruct H5.
      apply test_solve_notin_7 in H5...
      destruct H5.
    +
      clear IHA.
      simpl in *.
      destruct (a0==X);subst;try solve [inversion x]...
      inversion x0.
      inversion x;subst...
      apply notin_union in H.
      destruct H.
      apply notin_union in H.
      destruct H.
      apply test_solve_notin_7 in H...
      destruct H.
    +
      clear IHA IHB.
      simpl in *.
      inversion x0.
      inversion x;subst...
      constructor...
      apply IHSub with (C0:=C) (D0:=D)...
      dependent destruction H3...
      dependent destruction H4...
  -
    induction B;try solve [inversion x]...
    simpl in x...
    destruct (a==X);try solve [inversion x]...
Qed.

Lemma Sub_twice_to_one: forall E E1 A B X,
    X `notin` fl_tt A \u fl_tt B \u fv_tt A \u fv_tt B ->
    Sub (E1++[(X, bind_sub)] ++ E) (open_tt A (typ_rcd X (open_tt A X)))
        (open_tt B (typ_rcd X (open_tt B X))) ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) (open_tt A X) ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) (open_tt B X) ->
    Sub (E1++[(X, bind_sub)] ++ E) (open_tt A X) (open_tt B X).
Proof with auto.
  intros.
  rewrite subst_tt_intro with (X:=X) in H0...
  remember (subst_tt X (typ_rcd X (open_tt A X)) (open_tt A X)).
  rewrite subst_tt_intro with (X:=X) in H0...
  subst.
  apply Sub_subst_rcd_dismiss in H0;try solve [get_type;auto]...
  apply notin_union.
  split.
  apply notin_fl_tt_open...
  apply notin_fl_tt_open...
Qed.

Lemma WFS_permutation : forall A B C D E T ,
    WFS (E ++ A ++ B ++ C ++ D ) T ->
    WFS (E ++ C ++ A ++ B ++ D) T.
Proof with auto.
  intros.
  dependent induction H...
  -
    constructor...
    analyze_binds H...
  -
    apply WFS_rec with (L:=L);intros;
      rewrite_alist (([(X, bind_sub)] ++ E) ++ C ++ A ++ B ++ D)...
Qed.

Lemma WFS_permutation2 : forall A B C D  T ,
    WFS ( A ++ B ++ C ++ D ) T ->
    WFS ( A ++ C ++ B ++ D) T.
Proof with auto.
  intros.
  dependent induction H...
  -
    constructor...
    analyze_binds H...
  -
    apply WFS_rec with (L:=L);intros;
      rewrite_alist (([(X, bind_sub)]  ++ A) ++ C ++ B ++ D)...
Qed.

Lemma Sub_permutation: forall A B C D S T,
    Sub (A ++ B ++ C ++ D) S T ->
    wf_env (A ++ C ++ B ++ D) ->
    Sub (A ++ C ++ B ++ D) S T.
Proof with auto using WFS_permutation2.
   intros.
   dependent induction H...
   -
     apply S_rec with (L:=L \u dom (A ++ B++C ++D) );intros;
     rewrite_alist (([(X, bind_sub)]  ++ A) ++ C ++ B ++ D)...
     apply WFS_permutation2...
     rewrite_alist ([(X, bind_sub)]  ++ A ++ B ++ C ++ D)...
     apply WFS_permutation2...
     rewrite_alist ([(X, bind_sub)]  ++ A ++ B ++ C ++ D)...
     apply H2...
     rewrite_alist ([(X, bind_sub)]  ++ A ++ C ++ B ++ D)...
Qed.

Lemma wf_env_notin: forall E1 E2 X,
    wf_env (E1 ++ (X~bind_sub) ++ E2) ->
    X \notin dom (E1 ++ E2).
Proof with auto.
  intros E1.
  dependent induction E1;intros...
  simpl in *...
  dependent destruction H...
  rewrite_alist (a :: (E1 ++ [(X, bind_sub)] ++ E2)) in H.
  rewrite_alist (a :: E1 ++ E2).
  simpl.
  destruct a.
  apply notin_add_3...
  dependent destruction H...
  apply IHE1...
  dependent destruction H...
Qed.

Lemma sub_generalize_intensive : forall E1 E2 A B C D X m,
    WFS (E1 ++ X ~ bind_sub ++ E2) A -> WFS (E1 ++ X ~ bind_sub ++ E2) B ->
    X \notin fv_tt C \u fv_tt D ->
    X \notin fl_tt A \u fl_tt B ->
    Sub (E1 ++ X ~ bind_sub ++ E2) (subst_tt X (typ_rcd X (open_tt C X)) A)
    (subst_tt X (typ_rcd X  (open_tt D X)) B) ->
    Sub (E1 ++ E2) (typ_mu (choose m C D)) (typ_mu (choose m D C)) ->
    Sub (E1 ++ E2) (subst_tt X (typ_mu C) A) (subst_tt X (typ_mu D) B).
Proof with auto.
  intros.
  assert (wf_env (E1 ++ E2)).
  get_well_form...
  generalize dependent m.
  dependent induction H3;intros...
  - (* nat *)
    dependent induction H;simpl in *;try solve [inversion x0;auto].
    dependent induction H0;simpl in *;try solve [inversion x;auto].
    destruct (X0==X)...
    inversion x...
    inversion x...
    destruct (X0==X)...
    inversion x0...
    inversion x0...
  - (* var *)
    dependent induction H;simpl in *;try solve [inversion x0;auto].
    dependent induction H0;simpl in *;try solve [inversion x;auto].
    destruct (X1==X)...
    inversion x0...
    destruct (X2==X)...
    inversion x...
    rewrite <- x0.
    rewrite <- x...
    constructor...
    rewrite x0...
    analyze_binds H...
  - (* bot *)
    dependent induction H;simpl in *;try solve [inversion x;auto].
    constructor...
    destruct m;simpl;apply subst_tt_wfs3...
    get_well_form...
    get_well_form...
    destruct (X0==X)...
    inversion x...
    inversion x...
  - (* arrow *)
    dependent induction H;simpl in *;try solve [inversion x0;auto].
    +
      destruct (X0==X)...
      inversion x0...
      inversion x0...
    +
      inversion x0.
      dependent induction H3;simpl in *;try solve [inversion x;auto].
      *
        destruct (X0==X)...
        inversion x...
        inversion x...
      *
        clear IHWFS1 IHWFS2 IHWFS0 IHWFS3.
        inversion x.
        constructor...
        apply IHSub1 with (m:=flip m)...
        rewrite <- choose_flip...
        rewrite <- choose_flip...
        apply IHSub2 with (m:= m)...
  - (* and *)
    dependent induction H0;simpl in *;try solve [inversion x;auto].
    destruct (X0==X)...
    inversion x...
    inversion x...
    inversion x...
    constructor...
    apply IHSub1 with (m:=m)...
    apply IHSub2 with (m:=m)...
  - (* andL *)
    dependent induction H;simpl in *;try solve [inversion x;auto].
    +
      destruct (X0==X)...
      inversion x...
      inversion x...
    +
      inversion x.
      apply S_andL...
      apply IHSub with (m:=m)...
      apply subst_tt_wfs3;get_well_form...
      destruct m;simpl...
  - (* andR *)
    dependent induction H;simpl in *;try solve [inversion x;auto].
    +
      destruct (X0==X)...
      inversion x...
      inversion x...
    +
      inversion x.
      apply S_andR...
      apply IHSub with (m:=m)...
      apply subst_tt_wfs3;get_well_form...
      destruct m;simpl...
  - (* rec *)
    dependent induction A;simpl in *;try solve [inversion x0;auto].
    +
      destruct (a==X)...
      inversion x0...
      inversion x0...
    +
      dependent induction B;simpl in *;try solve [inversion x;auto].
      *
        destruct (a==X)...
        inversion x...
        inversion x...
      *
        clear IHA IHB.
        inversion x0.
        inversion x.
        clear x x0.
        assert (Ht1:=H).
        assert (Ht2:=H0).
        dependent destruction Ht1.
        dependent destruction Ht2.
        assert (type (typ_mu C) /\ type (typ_mu D)) as Hq.
        destruct m;get_type...
        destruct Hq.
        apply S_rec with (L:=L \u L0 \u L1 \u {{X}} \u fv_tt C \u fv_tt D   \u dom E1 \u dom E2);intros...
        --
          rewrite subst_tt_open_tt_var...
          rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
          apply subst_tt_wfs3...
          apply WFS_permutation...
          apply H12...
          apply WFS_weakening...
          destruct m;simpl;get_well_form...
        --
          rewrite subst_tt_open_tt_var...
          rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
          apply subst_tt_wfs3...
          apply WFS_permutation...
          apply H14...
          apply WFS_weakening...
          destruct m;simpl;get_well_form...
        --
          rename X0 into Y.
          rewrite_alist (([(Y, bind_sub)] ++ E1) ++ E2).
          rewrite <- mu_transform_0...
          rewrite <- mu_transform_0...
          apply H4 with (X1:=X) (X0:=Y) (m:=m)...
          ++
            apply notin_union.
            split;apply notin_fl_tt_open;simpl...
            apply notin_union;split...
            apply notin_fl_tt_open;simpl...
            apply notin_union;split...
            apply notin_fl_tt_open;simpl...
          ++
            rewrite_alist (((Y, bind_sub) :: E1 ++ (X, bind_sub) :: E2))...
            apply H9...
          ++
            rewrite_alist (((Y, bind_sub) :: E1 ++ (X, bind_sub) :: E2))...
            apply H13...
          ++
            rewrite H10.
            rewrite subst_tt_open_tt...
            f_equal...
            simpl...
            f_equal...
            rewrite subst_tt_open_tt_var...
            dependent destruction H15.
            pick fresh Z.
            constructor...
            rewrite subst_tt_intro with (X:=Z)...
            dependent destruction H15.
            pick fresh Z.
            constructor...
            rewrite subst_tt_intro with (X:=Z)...
          ++
            rewrite H11.
            rewrite subst_tt_open_tt...
            f_equal...
            simpl...
            f_equal...
            rewrite subst_tt_open_tt_var...
            dependent destruction H16.
            pick fresh Z.
            constructor...
            rewrite subst_tt_intro with (X:=Z)...
            dependent destruction H16.
            pick fresh Z.
            constructor...
            rewrite subst_tt_intro with (X:=Z)...
          ++
            rewrite_alist ([(Y, bind_sub)] ++ E1 ++ E2).
            constructor...
          ++
            rewrite_alist (nil ++ Y~bind_sub ++ (E1++E2)).
            apply Sub_weakening...
            constructor...
  - (* rcd *)
    dependent induction H;simpl in *;try solve [inversion x0;auto].
    +
      destruct (X0==X)...
      *
        dependent induction H0;simpl in *;try solve [inversion x;auto].
        --
          destruct (X1==X)...
          ++
            inversion x0.
            inversion x.
            clear x x0.
            rewrite H8 in H3.
            rewrite H10 in H3.
            destruct m;simpl in *...
            dependent destruction H4...
            **
              apply S_rec with (L:=L \u fv_tt C \u fv_tt D \u {{X}} \u fl_tt C \u fl_tt D \u dom E1 \u dom E2);intros...
              rename X2 into Y.
              specialize_x_and_L Y L.
              rewrite_alist (nil ++ [(Y, bind_sub)] ++ E1 ++ E2) in H7.
              apply Sub_twice_to_one in H7...
              assert (equiv ([(Y, bind_sub)] ++ E1 ++ E2) (open_tt D Y) (open_tt C Y)).
              {
                unfold equiv.
                split...
                add_nil.
                rewrite subst_tt_intro with (X:=X)...
                remember ((subst_tt X Y (open_tt C X))).
                rewrite subst_tt_intro with (X:=X)...
                subst.
                apply Sub_replacing...
                apply Sub_permutation...
                get_well_form...
                simpl.
                constructor...
                apply wf_env_notin...
                simpl.
                constructor...
              }
              rewrite subst_tt_intro with (X:=Y)...
              remember (subst_tt Y (typ_rcd Y (open_tt C Y)) (open_tt C Y)).
              rewrite subst_tt_intro with (X:=Y)...
              subst.
              apply subst_tt_equiv...
              unfold equiv in H13.
              destruct H13...
              unfold equiv in *...
              destruct H13...
          ++
            inversion x.
        --
          inversion x0.
          inversion x...
          subst.
          apply notin_union in H2.
          destruct H2.
          apply notin_union in H6.
          destruct H6.
          apply notin_singleton_1 in H6.
          destruct H6...
      *
        inversion x0.
    +
      inversion x0.
      dependent induction H0;simpl in *;try solve [inversion x;auto].
      *
        destruct (X0==X)...
        --
          inversion x.
          subst.
          apply notin_union in H2.
          destruct H2.
          apply notin_union in H2.
          destruct H2.
          apply notin_singleton_1 in H2.
          destruct H2...
        --
          inversion x.
      *
        inversion x.
        clear IHWFS IHWFS0.
        subst.
        constructor...
        apply IHSub with (m:=m)...
  - (* top *)
    induction B;try solve [inversion x]...
    +
      simpl...
      constructor...
      apply subst_tt_wfs3...
      destruct m;simpl in *;get_well_form...
    +
      simpl in x...
      destruct (a==X);try solve [inversion x]...
Qed.

Lemma unfolding_lemma: forall E A B,
    Sub E (typ_mu A) (typ_mu B) ->
    Sub E (open_tt A (typ_mu A)) (open_tt B (typ_mu B)).
Proof with auto.
  intros.
  assert (Ht:=H).
  dependent destruction H.
  -
    add_nil.
    pick fresh Y.
    rewrite subst_tt_intro with (X:=Y)...
    remember (subst_tt Y (typ_mu A) (open_tt A Y)).
    rewrite subst_tt_intro with (X:=Y)...
    subst.
    apply sub_generalize_intensive with (m:=Pos)...
    apply H...
    apply H0...
    apply notin_union.
    split.
    apply notin_fl_tt_open...
    apply notin_fl_tt_open...
    rewrite <-  subst_tt_intro...
    rewrite <-  subst_tt_intro...
    apply H1...
Qed.


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Positive.
Require Import ExtLib.Tactics.
Require Import McExamples.Hoare.ILogic.
Require Import MirrorCore.SymI.
Require Import MirrorCore.TypesI.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Monomorphic Universe Utc.

Section typed.
  Variable typ : Set.
  Variable RType_typ : RType typ.
  Variable RelDec_typ_eq : RelDec (@eq typ).
  Variable RelDecCorrect_typ_eq : RelDec_Correct RelDec_typ_eq.

  Inductive ilfunc :=
  | ilf_entails (logic : typ)
  | ilf_true (logic : typ)
  | ilf_false (logic : typ)
  | ilf_and (logic : typ)
  | ilf_or (logic : typ)
  | ilf_impl (logic : typ)
  | ilf_exists (arg logic : typ)
  | ilf_forall (arg logic : typ)
  (** It may be a little nicer to remove embed **)
  | ilf_embed (from to : typ).

  Global Instance RelDec_ilfunc : RelDec (@eq ilfunc) :=
  { rel_dec := fun a b =>
	         match a, b with
		   | ilf_entails t, ilf_entails t'
		   | ilf_true t, ilf_true t'
		   | ilf_false t, ilf_false t'
		   | ilf_and t, ilf_and t'
		   | ilf_or t, ilf_or t'
		   | ilf_impl t, ilf_impl t' => t ?[eq] t'
		   | ilf_forall a t, ilf_forall a' t'
		   | ilf_exists a t, ilf_exists a' t'
		   | ilf_embed a t, ilf_embed a' t' => a ?[eq] a' && t ?[eq] t'
		   | _, _ => false
	         end
  }.

  Global Instance RelDec_Correct_ilfunc : RelDec_Correct RelDec_ilfunc.
  Proof.
    constructor.
    destruct x; destruct y; simpl;
    try solve [ try rewrite andb_true_iff ;
                repeat rewrite rel_dec_correct; intuition congruence ].
  Qed.

  (** TODO: Build an ordered map over types **)
  (** the canonical implementation doesn't work!
  Inductive tree : (typ -> Type) -> Type :=
  | Node : forall F, option (F tyProp) ->
           tree (fun t => tree (fun u => F (tyArr t u))) ->
           tree F
  | Empty : forall F, tree F.
  **)

  Inductive loption (t : Type@{Utc}) : Type@{Utc} :=
  | lSome : t -> loption t
  | lNone.
  Global Arguments lNone {_}.

  Definition logic_ops : Type@{Utc} := forall (t : typ),
    loption (ILogicOps@{Urefl Urefl} (typD t)).
  Definition embed_ops := forall (t u : typ),
    loption (EmbedOp (typD t) (typD u)).
  Definition logic_opsOk (l : logic_ops) : Prop :=
    forall g, match l g return Prop with
              | lSome T => @ILogic _ T
              | lNone => True
              end.
  Definition embed_opsOk (ls : logic_ops) (es : embed_ops) : Prop :=
    forall t t',
      match ls t , ls t' , es t t' return Prop with
        | lSome a , lSome b , lSome T => @Embed _ _ a _ T
        | _ , _ , _ => True
      end.

  Variable gs : logic_ops.
  Variable es : embed_ops.

  Variable Typ2_tyArr : Typ2 _ RFun.
  Variable Typ0_tyProp : Typ0 _ Prop.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp : typ := @typ0 _ _ _ _.

  Definition typeof_func@{} (f : ilfunc) : option typ :=
    match f with
    | ilf_true t
    | ilf_false t =>
      match gs t with
      | lSome _ => Some t
      | lNone => None
      end
    | ilf_entails t =>
      match gs t with
      | lSome _ => Some (tyArr t (tyArr t tyProp))
      | lNone => None
      end
    | ilf_and t
    | ilf_or t
    | ilf_impl t =>
      match gs t with
      | lSome _ => Some (tyArr t (tyArr t t))
      | lNone => None
      end
    | ilf_forall a t
    | ilf_exists a t =>
      match gs t with
      | lSome _ => Some (tyArr (tyArr a t) t)
      | lNone => None
      end
    | ilf_embed a b =>
      match es a b with
      | lNone => None
      | lSome _ => Some (tyArr a b)
      end
    end.

  Definition typ2_cast_bin (a b c : typ)
  : (typD a -> typD b -> typD c) -> typD (tyArr a (tyArr b c)) :=
    fun f =>
      match eq_sym (typ2_cast a (tyArr b c)) in _ = t
            return t
      with
      | eq_refl => match eq_sym (typ2_cast b c) in _ = t
                         return _ -> t with
                   | eq_refl => f
                   end
      end.

  Definition typ2_cast_quant (a b c : typ)
  : ((typD a -> typD b) -> typD c) -> typD (tyArr (tyArr a b) c) :=
    fun f =>
      match eq_sym (typ2_cast (tyArr a b) c) in _ = t
            return t with
      | eq_refl => match eq_sym (typ2_cast a b) in _ = t
                        return t -> _ with
                  | eq_refl => f
                  end
      end.

  Definition funcD@{} (f : ilfunc) :
    match typeof_func f return Type@{Urefl} with
    | Some t => typD t
    | None => unit
    end.
  refine (
    match f as f
          return match typeof_func f return Type@{Urefl} with
		   | Some t => typD t
		   | None => unit
		 end
    with
      | ilf_true t =>
        match gs t as x
              return (match match x with
			      | lSome _ => Some t
			      | lNone => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | lSome t => @ltrue _ t
	  | lNone => tt
        end
      | ilf_false t =>
        match gs t as x
              return (match match x with
			      | lSome _ => Some t
			      | lNone => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | lSome t => @lfalse _ t
	  | lNone => tt
        end
      | ilf_entails t =>
        match gs t as x
              return (match match x with
			    | lSome _ => Some (tyArr t (tyArr t tyProp))
			    | lNone => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | lSome C =>
            match eq_sym (typ2_cast t (tyArr t tyProp)) in _ = t
                  return t with
              | eq_refl =>
                match eq_sym (typ2_cast t tyProp) in _ = t
                      return _ -> t with
                  | eq_refl =>
                    match eq_sym (typ0_cast (F := Prop)) in _ = t
                          return _ -> _ -> t
                    with
                      | eq_refl => @lentails _ _
                    end
                end
            end
	  | lNone => tt
        end
      | ilf_and t =>
        match gs t as x
              return (match match x with
			      | lSome _ => Some (tyArr t (tyArr t t))
			      | lNone => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | lSome t => typ2_cast_bin _ _ _ (@land _ _)
	  | lNone => tt
        end
      | ilf_impl t =>
        match gs t as x
              return (match match x with
			      | lSome _ => Some (tyArr t (tyArr t t))
			      | lNone => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | lSome t => typ2_cast_bin _ _ _ (@limpl _ _)
	  | lNone => tt
        end
      | ilf_or t =>
        match gs t as x
              return (match match x with
			      | lSome _ => Some (tyArr t (tyArr t t))
			      | lNone => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | lSome t => typ2_cast_bin _ _ _ (@lor _ _)
	  | lNone => tt
        end
      | ilf_exists a t =>
        match gs t as x return (match match x with
					| lSome _ => Some (tyArr (tyArr a t) t)
					| lNone => None
				      end
                                      return Type@{Urefl}
                                with
				  | Some t0 => typD t0
				  | None => unit
				end) with
	  | lSome t0 => typ2_cast_quant _ _ _ (@lexists _ t0 (typD a))
	  | lNone => tt
        end
      | ilf_forall a t =>
        match gs t as x return (match match x with
					| lSome _ => Some (tyArr (tyArr a t) t)
					| lNone => None
				      end with
				  | Some t0 => typD t0
				  | None => unit
				end) with
	  | lSome t0 => typ2_cast_quant _ _ _ (@lforall _ _ _)
	  | lNone => tt
        end
      | ilf_embed t u =>
        match es t u as x
              return match match x with
			     | lSome _ => Some (tyArr t u)
			     | lNone => None
			   end with
		       | Some t0 => typD t0
		       | None => unit
		     end
        with
	  | lSome t0 =>
            match eq_sym (typ2_cast t u) in _ = t return t
            with
              | eq_refl => @embed _ _ _
            end
	  | lNone => tt
        end
    end).
  Defined.

  Global Instance RSym_ilfunc : RSym ilfunc :=
  { typeof_sym := typeof_func
  ; sym_eqb := fun a b => Some (rel_dec a b)
  ; symD := funcD
  }.

  Global Instance RSymOk_ilfunc : RSymOk RSym_ilfunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

  Require Import MirrorCore.Views.Ptrns.

  (** TODO: There should be a general proof for this *)
  Ltac ptrn_ok_1 :=
    let do_it H :=
        let x := fresh in
        intro x; destruct x; simpl; try solve [ right; compute; reflexivity ] ;
        match goal with
        | H' : _ |- _ =>
          lazymatch H' with
          | H => fail 2
          | _ =>
            let H'' := fresh in
            let x'' := fresh in
            destruct (H H') as [ [ x'' H'' ] | H'' ] ;
              [ left ; exists x'' ; try solve [ compute ; intros; eapply H'' ]
              | right ; try solve [ compute; intros; eapply H'' ] ]
          end
        end
    in
    intros;
    match goal with
    | H : ptrn_ok ?X |- ptrn_ok (_ ?X) => do_it H
    end.

  (** TODO: This should move into MirrorCore.Views.Ptrn *)
  Definition Mtwo {T U V W X} (f : T -> U -> X)
             (p1 : ptrn T V) (p2 : V -> ptrn U W)
             (x1 : T) (x2 : U) : M X W :=
    fun _T good bad =>
      p1 x1 _T (fun v => p2 v x2 _T good (fun u => bad (f x1 u)))
         (fun t => bad (f t x2)).
  Definition Myes {X T} (m : M X T) res : Prop :=
    forall T good bad, m T good bad = good res.
  Definition Mno {X T} (m : M X T) x : Prop :=
    forall T good bad, m T good bad = bad x.
  Definition Mok {X T} (m : M X T) (x : X) : Prop :=
    (exists y, Myes m y) \/ Mno m x.
  Lemma Mtwo_ok {T U V W X} f p1 p2 x1 x2
    : ptrn_ok p1 ->
      (forall v, ptrn_ok (p2 v)) ->
      Mok (@Mtwo T U V W X f p1 p2 x1 x2) (f x1 x2).
  Proof.
    intros.
    destruct (H x1) as [ [ ? ? ] | ].
    - destruct (H0 x x2) as [ [ ? ? ] | ].
      + left. exists x0.
        unfold Mtwo, Succeeds in *.
        red; intros.
        rewrite H1. apply H2.
      + right. red in H1. red in H2.
        red. compute; intros.
        rewrite H1. apply H2.
    - right. red in H1.
      compute; intros. apply H1.
  Qed.

  Lemma Mrebuild_Succeeds : forall {X Y} (p' : ptrn X Y) {T} p f v x,
      (forall T0 (good : T -> T0) (bad : X -> T0),
          Mrebuild (X:=Y) f (p x) good bad = good v) ->
      (forall T0 good bad, p x T0 good (fun x : Y => p' (f x) T0 bad (fun _ : X => good v)) = p x T0 good bad) ->
      Succeeds x p v.
  Proof.
    red. intros.
    unfold Mrebuild in *.
    specialize (H T0 good (fun x => @p' x T0 bad (fun _ => good v))).
    simpl in H.
    rewrite H0 in H. assumption.
  Qed.

  Lemma Mtwo_Succeeds : forall {X Y Z} (p2' : ptrn Z Y) {T T'}
                               (p1 : ptrn X T) (p2 : T -> ptrn Y T') (f : X -> Y -> Z) v arg logic,
      ptrn_ok p1 ->
      (forall T0 (good : _ -> T0) bad,
          Mtwo (X:=Z) f p1 p2 arg logic good bad = good v) ->
      (forall T0 (good : _ -> T0) bad x logic, p2 x logic T0 good
                                                  (fun u : Y => p2' (f arg u) T0 bad (fun _ : Z => good v)) = p2 x logic T0 good bad) ->
      exists val,
        Succeeds arg p1 val /\ Succeeds logic (p2 val) v.
  Proof.
    intros. unfold Mtwo in *.
    destruct (H arg); clear H.
    - destruct H2. exists x.
      split; auto.
      red in H. setoid_rewrite H in H0.
      red. intros. specialize (H0 T0 good).
      specialize (H0 (fun z => p2' z T0 bad (fun _ => good v))).
      simpl in H0.
      rewrite H1 in H0. assumption.
    - clear H1.
      unfold Fails in H2.
      setoid_rewrite H2 in H0.
      specialize (H0 bool (fun _ => true) (fun _ => false)). inversion H0.
  Qed.

  Ltac solve_Succeeds1 :=
    match goal with
    | |- Succeeds ?e (?p' _ _) ?v -> _ =>
      destruct e;
        let H := fresh in
        try solve [ intro H ; specialize (H bool (fun _ => true) (fun _ => false)); inversion H
                  | intros; eexists; split; auto;
                    red in H; simpl in H ;
                    eapply (@Mrebuild_Succeeds _ _ (p' _ get)) in H; [ auto | reflexivity ] ]
    end.

  Ltac solve_Succeeds2 :=
    match goal with
    | |- Succeeds ?e (?p' _ _ _ _) ?v -> _ =>
      destruct e;
        let H := fresh in
        try solve [ intro H ; specialize (H bool (fun _ => true) (fun _ => false)); inversion H
                  | do 2 eexists; split; eauto;
                    red in H; simpl in H ;
                    eapply Mtwo_Succeeds with (p2':=p' _ _ ignore (fun _ => get)) in H; eauto ]
    end.

  Definition fptrn_lentails@{A X P} {T : Type@{A}} (k : ptrn@{Set A X P} typ T)
  : ptrn@{Set A X P} ilfunc T :=
    fun x =>
      match x with
      | ilf_true t => Mfail (ilf_true t)
      | ilf_false t => Mfail (ilf_false t)
      | ilf_and t => Mfail (ilf_and t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mfail (ilf_impl t)
      | ilf_forall u t => Mfail (ilf_forall u t)
      | ilf_exists u t => Mfail (ilf_exists u t)
      | ilf_entails t => Mrebuild ilf_entails (k t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.

  Global Instance fptrn_lentails_ok {T} (p : ptrn typ T)
  : ptrn_ok p -> ptrn_ok (fptrn_lentails p).
  Proof. ptrn_ok_1. Qed.

  Definition SucceedsE_fptrn_lentails@{T u z} {T : Type@{T}} (e : ilfunc)
             (k : ptrn@{Set T u z} typ T) (v : T)
  : SucceedsE e (fptrn_lentails k) v.
  refine (
  {| s_result := exists t, e = ilf_entails t /\ Succeeds t k v |}).
  Proof. abstract solve_Succeeds1. Defined.
  Global Existing Instance SucceedsE_fptrn_lentails.

  Definition fptrn_ltrue {T} (k : ptrn typ T) : ptrn ilfunc T :=
    fun x =>
      match x with
      | ilf_true t => Mrebuild ilf_true (k t)
      | ilf_false t => Mfail (ilf_false t)
      | ilf_and t => Mfail (ilf_and t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mfail (ilf_impl t)
      | ilf_forall u t => Mfail (ilf_forall u t)
      | ilf_exists u t => Mfail (ilf_exists u t)
      | ilf_entails t => Mfail (ilf_entails t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.

  Global Instance fptrn_ltrue_ok {T} (p : ptrn typ T)
  : ptrn_ok p -> ptrn_ok (fptrn_ltrue p).
  Proof. ptrn_ok_1. Qed.

  Global Instance SucceedsE_fptrn_ltrue {T} e k (v : T) : SucceedsE e (fptrn_ltrue k) v :=
  { s_result := exists t, e = ilf_true t /\ Succeeds t k v }.
  Proof. abstract solve_Succeeds1. Defined.

  Definition fptrn_lfalse {T} (k : ptrn typ T) : ptrn ilfunc T :=
    fun x =>
      match x with
      | ilf_true t => Mfail (ilf_true t)
      | ilf_false t => Mrebuild ilf_false (k t)
      | ilf_and t => Mfail (ilf_and t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mfail (ilf_impl t)
      | ilf_forall u t => Mfail (ilf_forall u t)
      | ilf_exists u t => Mfail (ilf_exists u t)
      | ilf_entails t => Mfail (ilf_entails t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.

  Global Instance fptrn_lfalse_ok {T} (p : ptrn typ T)
  : ptrn_ok p -> ptrn_ok (fptrn_lfalse p).
  Proof. ptrn_ok_1. Qed.

  Global Instance SucceedsE_fptrn_lfalse {T} e k (v : T) : SucceedsE e (fptrn_lfalse k) v :=
  { s_result := exists t, e = ilf_false t /\ Succeeds t k v }.
  Proof. abstract solve_Succeeds1. Defined.

  Definition fptrn_land {T} (k : ptrn typ T) : ptrn ilfunc T :=
    fun x =>
      match x with
      | ilf_true t => Mfail (ilf_true t)
      | ilf_false t => Mfail (ilf_false t)
      | ilf_and t => Mrebuild ilf_and (k t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mfail (ilf_impl t)
      | ilf_forall u t => Mfail (ilf_forall u t)
      | ilf_exists u t => Mfail (ilf_exists u t)
      | ilf_entails t => Mfail (ilf_entails t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.

  Global Instance fptrn_land_ok {T} (p : ptrn typ T)
  : ptrn_ok p -> ptrn_ok (fptrn_land p).
  Proof. ptrn_ok_1. Qed.

  Global Instance SucceedsE_fptrn_land {T} e k (v : T) : SucceedsE e (fptrn_land k) v :=
  { s_result := exists t, e = ilf_and t /\ Succeeds t k v }.
  Proof. abstract solve_Succeeds1. Defined.

  Definition fptrn_limpl {T} (k : ptrn typ T) : ptrn ilfunc T :=
    fun x =>
      match x with
      | ilf_true t => Mfail (ilf_true t)
      | ilf_false t => Mfail (ilf_false t)
      | ilf_and t => Mfail (ilf_and t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mrebuild ilf_impl (k t)
      | ilf_forall u t => Mfail (ilf_forall u t)
      | ilf_exists u t => Mfail (ilf_exists u t)
      | ilf_entails t => Mfail (ilf_entails t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.
  Global Instance fptrn_limpl_ok : ltac:(PtrnOk @fptrn_limpl) := ltac:(ptrn_ok_1).

  Global Instance SucceedsE_fptrn_limpl {T} e k (v : T) : SucceedsE e (fptrn_limpl k) v :=
  { s_result := exists t, e = ilf_impl t /\ Succeeds t k v }.
  Proof. abstract solve_Succeeds1. Defined.

  Definition fptrn_lforall {T U} (k : ptrn typ T) (k' : T -> ptrn typ U)
  : ptrn ilfunc U :=
    fun x =>
      match x with
      | ilf_true t => Mfail (ilf_true t)
      | ilf_false t => Mfail (ilf_false t)
      | ilf_and t => Mfail (ilf_and t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mfail (ilf_impl t)
      | ilf_forall u t => Mtwo ilf_forall k k' u t
      | ilf_exists u t => Mfail (ilf_exists u t)
      | ilf_entails t => Mfail (ilf_entails t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.

  Global Instance fptrn_lforall_ok {T U} (p : ptrn typ T) (p' : T -> ptrn typ U)
  : ptrn_ok p -> (forall x, ptrn_ok (p' x)) -> ptrn_ok (fptrn_lforall p p').
  Proof.
    intros. red. destruct x; try solve [ right ; compute; reflexivity ].
    eapply Mtwo_ok; assumption.
  Qed.

  Global Instance SucceedsE_fptrn_lforall {T U} (p : ptrn typ T) (p' : T -> ptrn typ U) e v
  : ptrn_ok p -> SucceedsE e (fptrn_lforall p p') v :=
  { s_result := exists t l : typ, e = ilf_forall t l /\
                                  exists val,
                                    Succeeds t p val /\
                                    Succeeds l (p' val) v }.
  Proof. abstract solve_Succeeds2. Defined.

  Definition fptrn_lexists {T U} (k : ptrn typ T) (k' : T -> ptrn typ U)
  : ptrn ilfunc U :=
    fun x =>
      match x with
      | ilf_true t => Mfail (ilf_true t)
      | ilf_false t => Mfail (ilf_false t)
      | ilf_and t => Mfail (ilf_and t)
      | ilf_or t => Mfail (ilf_or t)
      | ilf_impl t => Mfail (ilf_impl t)
      | ilf_forall u t => Mfail (ilf_forall u t)
      | ilf_exists u t => Mtwo ilf_exists k k' u t
      | ilf_entails t => Mfail (ilf_entails t)
      | ilf_embed u t => Mfail (ilf_embed u t)
      end.

  Global Instance ptrn_lexists_ok {T U} (p : ptrn typ T) (p' : T -> ptrn typ U)
  : ptrn_ok p -> (forall x, ptrn_ok (p' x)) -> ptrn_ok (fptrn_lexists p p').
  Proof.
    intros. red. destruct x; try solve [ right ; compute; reflexivity ].
    eapply Mtwo_ok; assumption.
  Qed.

  Global Instance SucceedsE_fptrn_lexists {T U} (p : ptrn typ T) (p' : T -> ptrn typ U) e v
  : ptrn_ok p -> SucceedsE e (fptrn_lexists p p') v :=
  { s_result := exists t l : typ, e = ilf_exists t l /\
                                  exists val,
                                    Succeeds t p val /\
                                    Succeeds l (p' val) v }.
  Proof. abstract solve_Succeeds2. Defined.

End typed.


Require Import Lt.
Require Import Omega.
Require Import RelationClasses.
Require Import MFix.Monad.
Require Import MFix.ILogic.
Require Import MFix.Fuel.

Set Implicit Arguments.
Set Strict Implicit.

Section monotone.

  Inductive LTE_option {A}  : option A -> option A -> Prop :=
  | None_LTE :  forall x  , LTE_option None x
  | Some_LTE :  forall (x : A), LTE_option (Some x) (Some x).

  Definition lteM {A} (mx : M A) (my : M A) :=
    forall n, LTE_option (mx n) (my n).

  Definition monotoneM {A} (r : M A) : Prop :=
    forall n m, n < m -> LTE_option (r n) (r m).

  Definition monotoneF {A B} (f : A -> M B) : Prop :=
    forall x, monotoneM (f x).

  Definition lteP {A} (P Q : M A -> Prop) : Prop :=
    forall x y, lteM x y -> P x -> P y.

  Definition ltePF {A B} (P Q : (B -> M A) -> Prop) : Prop :=
    forall v : B,
    forall x y, lteM (x v) (y v) -> P x -> P y.

End monotone.

Section IndexedInd.
  (* Indexed fixpoint induction, take4 *)
  (* Critique:
    - Too low level, you need to unfold ret and bind to get anywhere.
   *)
  Definition FuelProp := fuel -> Prop.

  Definition Inj : Prop -> FuelProp := fun P _ => P.

  Definition atleast (n : nat) : FuelProp :=
    fun fuel => fuel >= n.

  (** ?? **)
  Definition later (fp : FuelProp) : FuelProp :=
    fun n => forall m, m < n -> fp m.

  Definition now {B} (c : M B) (P : B -> FuelProp) : FuelProp :=
    fun fuel => match c fuel with
                  | None => ltrue
                  | Some x => P x fuel
                end.

  Definition nowF {A B} (c : A -> M B) (P : A -> B -> FuelProp) : FuelProp :=
    fun fuel =>
      lforall A (fun x => match c x fuel with
                            | None => ltrue
                            | Some v => P x v fuel
                          end).

  Variable (A B : Type).
  Variable P : (A -> M B) -> FuelProp.
  Hypothesis Pok : forall x y,
                     (forall v, lteM (y v) (x v)) ->
                     (forall n m, m <= n -> P x m -> P y n).
  Variable f : (A -> M B) -> (A -> M B).
  Variable G : FuelProp.

  Hypothesis Step
  : lentails G (limpl (P (mfix f)) (P (f (mfix f)))).

  Instance Refl_lteM {T} : Reflexive (@lteM T).
  Proof.
    red. intro. red. intros.
    destruct (x n). constructor. constructor.
    (** TODO: cleaner proof **)
  Qed.

  (** TODO: It really seems like there should be two rules, one for proving
   ** total correctness and the other for proving partial correctness
   **)
  Theorem mfixind1 : lentails G (P (mfix f)).
  Proof.
    red. simpl.
    induction x.
    { (* intros. eapply Pok.
      { instantiate (1 := fun _ _ => None). simpl.
        intros. constructor. }
      {

*) admit.
 }
    { simpl in *.
      intros. eapply Pok.
      2: instantiate (1 := x); auto.
      2: eapply Step.

unfold satisfiesF in *. simpl in *.
      eapply Step.
      { red. red. intros.
        destruct (mfix f x0 x); constructor. }
      { simpl. auto. } }
  Qed.
End IndexedInd.

Module ExampleFactorial.

  Definition mkfact (fact : nat -> M nat) (n : nat) : M nat :=
    match n with
      | 0 => ret 1
      | S n' => bind (fact n') (fun m => ret (n*m))
    end.

  Definition fact := mfix mkfact.

  (* This works as expected. *)
  Eval compute in (fact 5 10).
  Eval compute in (fact 5 2).

  Fixpoint rfact (n : nat) :=
    match n with
      | 0 => 1
      | (S n') => n * (rfact n')
    end.

  Definition Pfact : (nat -> M nat) -> FuelProp :=
    satisfiesF (fun n fn => limpl (atleast n) (Inj (fn = rfact n))).

  Example fact_correct
  : lentails ltrue (Pfact fact).
  Proof.
    eapply mfixind1.
    { unfold mkfact, satisfiesF, later; simpl. intros.
      destruct x0; simpl.
      { reflexivity. }
      { unfold bind.
        destruct x.
        { inversion H0. }
        { specialize (H0 x0).
          assert (x < S x) by omega.
          do 2 red in H. specialize (H x0 x (S x) H1).
          inversion H.
          { subst. rewrite <- H3 in *.

        remember (r x0 x). destruct o.
        { simpl. intros. red.

  Example fact_correct :
    forall m,  (m > n) -> fact n m = Some (rfact n).
  intros m n.
  pose (H:= @mfixind1 nat nat (fun fuel res=> forall arg, (fuel > arg) -> res arg = Some (rfact arg))).
  simpl in H.
  unfold fact.
  apply H.
  { intros.  inversion H0. }
  { intros.
    unfold mkfact.
    destruct arg.
    { unfold ret. reflexivity. }
    { apply lt_S_n in H2.
      apply H0 in H2.
      unfold bind.
      assert (n0 < S n0) by omega.
      specialize (H1 arg n0 (S n0) H3).
      destruct H1; try congruence.
      { inversion H2. unfold ret.
        reflexivity. } } }
  Qed.

  Theorem factTerminates : forall n, Terminates (fact n).
  intros. exists (S n).
  abstract (rewrite fact_correct; auto; congruence).
  Defined.

  Definition pure_fact : nat -> nat :=
    Eval compute in purifyF fact (@factTerminates).

  (** pure_fact is a little bit slower... **)
  Time Eval vm_compute in pure_fact 7.
  Time Eval vm_compute in rfact 7.

End ExampleFactorial.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e480m2e240m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import GraphBasics.Graphs.
Require Import Coq.Logic.Classical_Prop.
Require Import Verdi.Verdi.
Require Export StructTact.Fin.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.

Require Import Verdi.ExtrOcamlBasicExt.
Require Import Verdi.ExtrOcamlList.

Require Import FunInd.

Load CDAInterface.
Section Help_Lemmata.

Lemma list_not_equals : forall (T : Type) (x y : T) (l1 l2 : list T) ,
  (x <> y \/ l1 <> l2) -> (x :: l1 <> y :: l2).
Proof.
  intros T x y l1 l2.
  induction l1 ; unfold not.
  + intros.
    destruct H.
    - destruct l2.
      inversion H0.
      intuition.
      inversion H0.
    - destruct l2.
      intuition.
      inversion H0.
  + intros.
    destruct H.
    - induction l2.
      inversion H0.
      inversion H0.
      intuition.
    - inversion H0.
      intuition.
Qed.

Lemma silly_lemma : forall (T: Type) y (p : T) xs ys,
  In p (xs ++ ys) -> In p (xs ++ y :: ys).
Proof.
  intros T y p xs ys H.
  apply in_app_or in H.
  apply in_or_app.
  simpl.
  destruct H ; auto.
Qed.

Lemma name_comp_name : forall n1 n2,
  name_component n1 = name_component n2 -> n1 = n2.
Proof.
  intros n1 n2 H.
  unfold name_component in *.
  break_match.
  break_match.
  subst.
  auto.
Qed.

Lemma checker_name : forall p,
  Checker (name_component p) = p.
Proof.
  intros p.
  unfold name_component.
  break_match.
  auto.
Qed.

Lemma cinc: forall pSrc0 pSrc,
  (component_index (name_component pSrc0) =? component_index (name_component pSrc)) = true ->
  pSrc0 = pSrc.
Proof.
  intros.
  apply beq_nat_true in H.
  unfold component_index in *.
  unfold name_component in *.
  destruct pSrc. destruct pSrc0.
  destruct c0. destruct c. subst.
  auto.
Qed.

Lemma cinc': forall pSrc0 pSrc,
  (component_index (name_component pSrc0) =? component_index (name_component pSrc)) = false ->
  pSrc0 <> pSrc.
Proof.
  intros.
  apply beq_nat_false in H.
  destruct pSrc. destruct pSrc0.
  destruct c0. destruct c. simpl in *.
  intuition. apply H.
  inversion H0. auto.
Qed.

Notation "a =/= b" := (beq_nat (Some a) (Some b)) (at level 70).
Notation "a == b" := (beq_nat a b) (at level 70).

Lemma beq_false_nat : forall n m : nat,
  n <> m -> (n == m) = false.
Proof.
  induction n; induction m; intros.
  intuition.
  intuition.
  intuition.
  simpl.
  intuition.
Qed.

Fixpoint remove_src (src : Name) (child_list : list Name) : list Name :=
  match child_list with
  | [] => []
  | hd :: tl => if (component_index (name_component src) == component_index (name_component hd)) then tl else hd :: (remove_src src tl)
  end.

Lemma remove_src_still_in : forall pSrc pSrc0 x,
  pSrc <> pSrc0 ->
  In pSrc x ->
  In pSrc (remove_src pSrc0 x).
Proof.
  intros.
  induction x.
  inversion H0.
  simpl in *.
  destruct H0 ; repeat break_match ; intuition.
  subst.
  apply cinc in Heqb.
  subst.
  intuition.
  simpl. left. auto.
Qed.

Lemma remove_removes_one : forall p l,
 In p l -> NoDup l -> Permutation (p :: remove_src p l) l.
Proof.
  intros p l H H0.
  induction l.
  inversion H.
  simpl in H. destruct H.
  subst.
  simpl.
  break_match. auto.
  assert ((component_index (name_component p) =? component_index (name_component p)) = true).
  apply Nat.eqb_refl.
  rewrite H in Heqb. inversion Heqb.
  intuition.
  assert (H0' := H0).
  apply NoDup_cons_iff in H0'.
  destruct H0'.
  intuition.
  simpl in *.
  assert (p = a0 \/ p <> a0).
  apply classic.
  destruct H1.
  subst. intuition.
  break_match.
  apply cinc in Heqb.
  intuition.
  apply (perm_skip a0) in H4.
  apply Permutation_sym in H4. apply Permutation_sym.
  apply (Permutation_trans H4) ; auto.
  apply perm_swap.
Qed.

Lemma remove_src_before': forall (d pSrc : Name) (l1 : list Name),
  ~ In d l1 ->
  ~ In d (remove_src pSrc l1).
Proof.
  intros.
  induction l1 ; intros ; simpl in * ; intuition ; break_match ; intuition.
  inversion H0.
  subst.
  intuition.
  intuition.
Qed.

Lemma NoDup_remove_src : forall pSrc l1,
  NoDup l1 ->
  NoDup (remove_src pSrc l1).
Proof.
  intros.
  induction l1 ; intros ; simpl in * ; intuition ; break_match ; intuition.
  + apply NoDup_cons_iff in H. destruct H ; auto.
  + apply NoDup_cons_iff in H. destruct H ; intuition.
    apply NoDup_cons_iff. split ; auto.
    apply remove_src_before' ; auto.
Qed.

Fixpoint is_always (test_case : Assignment) (vl : list Assignment) : bool :=
  let (var, val) := test_case in
  match vl with
  | nil => true
  | hd :: tl => let (vl_var, vl_val) := hd in
      if (var_beq var vl_var) then (val_beq val vl_val) && is_always test_case tl else is_always test_case tl
  end.

Fixpoint check_ass_list (vl : list Assignment) : bool :=
  match vl with
  | nil => true
  | hd :: tl => (is_always hd tl) && check_ass_list tl
  end.

Lemma remove_src_before : forall d pSrc l1,
  In d (remove_src pSrc l1) ->
  In d l1.
Proof.
  intros.
  induction l1.
  - simpl in H.
    inversion H.
  - simpl in *.
    break_match ; auto.
    simpl in H. destruct H.
    auto.
    auto.
Qed.

Lemma is_consistent_one_lesss : forall a0 cert,
  is_consistent (a0 :: cert) ->
  is_consistent cert.
Proof.
  intros a0 cert H.
  unfold is_consistent in *.
  intros.
  destruct assign1.
  destruct assign2.
  intros.
  specialize (H (assign_cons v0 v1)).
  specialize (H (assign_cons v2 v3)).
  simpl in H.
  apply H ; auto.
Qed.

Lemma not_consistent_one_less : forall cert va0 va1,
  ~ is_consistent (assign_cons va0 va1 :: cert) ->
  (~ is_consistent cert \/ (exists v3, In (assign_cons va0 v3) cert /\ va1 <> v3)).
Proof.
  intros cert va0 va1 H.
  assert (is_consistent cert \/ ~is_consistent cert) as new.
  apply classic.
  destruct new as [new|neww].
  right.
  induction cert.
  + assert (is_consistent [assign_cons va0 va1]).
    unfold is_consistent.
    destruct assign1.
    destruct assign2.
    intros.
    inversion H0.
    inversion H1.
    apply <- asign_cons_eq_dec2 in H3.
    apply <- asign_cons_eq_dec2 in H4.
    destruct H3. destruct H4.
    rewrite <- H5. rewrite H6. auto.
    inversion H4.
    inversion H3.
    intuition.
  + assert (new' := new).
    apply is_consistent_one_lesss in new'.
    destruct a0.
    assert ((va0 = v0 /\ va1 <> v1) \/ ~ is_consistent (assign_cons va0 va1 :: cert)).
      clear new' IHcert.
      assert ((va0 = v0 /\ va1 <> v1) \/ ~(va0 = v0 /\ va1 <> v1)).
      apply classic.
      destruct H0.
      destruct H0.
      left. auto.
      assert (va0 <> v0 \/ va1 = v1).
      assert (va0 = v0 \/ va0 <> v0).
      apply classic.
      destruct H1.
      assert (va1 = v1 \/ va1 <> v1).
      apply classic.
      destruct H2.
      right. auto.
      rewrite H1 in H0. intuition.
      left. auto.
      right. clear H0.
      destruct H1.
        intuition.
        apply H.
        unfold is_consistent.
        destruct assign1. destruct assign2.
        intros. subst.
        simpl in *.
        destruct H2.
          apply <- asign_cons_eq_dec2 in H2. destruct H2. subst.
          destruct H3.
            apply <- asign_cons_eq_dec2 in H2. destruct H2. auto.
            destruct H2.
              apply <- asign_cons_eq_dec2 in H2. destruct H2. subst.
              intuition.
              unfold is_consistent in H1.
              apply (H1 (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
              simpl. left. auto.
              simpl. right. auto.
          destruct H2.
            apply <- asign_cons_eq_dec2 in H2. destruct H2. subst.
            destruct H3.
              apply <- asign_cons_eq_dec2 in H2. destruct H2. subst.
              intuition.
              destruct H2.
                apply <- asign_cons_eq_dec2 in H2. destruct H2. auto.
                unfold is_consistent in new.
                apply (new (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
                simpl. left. auto.
                simpl. right. auto.
            destruct H3.
            apply <- asign_cons_eq_dec2 in H3. destruct H3. subst.
            apply (H1 (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
            simpl. right. auto.
            simpl. left. auto.
            destruct H3.
            apply <- asign_cons_eq_dec2 in H3. destruct H3. subst.
            apply (new (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
            simpl. right. auto.
            simpl. left. auto.
            apply (is_consistent_one_lesss) in new.
          unfold is_consistent in new.
          apply (new (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.

        intuition.
        apply H.
        unfold is_consistent.
        intros.
        destruct assign1. destruct assign2.
        intros.
        subst.
        inversion H2.
          apply <- asign_cons_eq_dec2 in H0.
          destruct H0.
          subst.
          inversion H3.
            apply <- asign_cons_eq_dec2 in H0.
            destruct H0.
            subst.
            auto.
            inversion H0.
              apply <- asign_cons_eq_dec2 in H4.
              destruct H4. subst. auto.
              unfold is_consistent in H1.
              apply (H1 (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
              simpl. left. auto.
            simpl. right. auto.
          inversion H0.
            apply <- asign_cons_eq_dec2 in H4.
            destruct H4.
            subst.
            inversion H3.
              apply <- asign_cons_eq_dec2 in H4.
              destruct H4.
              auto.
              inversion H4.
              apply <- asign_cons_eq_dec2 in H5.
              destruct H5. auto.
            unfold is_consistent in new.
            apply (new (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
          inversion H3.
          apply <- asign_cons_eq_dec2 in H5. destruct H5. subst.
          unfold is_consistent in H1.
          apply (H1 (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
          simpl. right. auto.
          simpl. left. auto.
          inversion H5.
          apply <- asign_cons_eq_dec2 in H6. destruct H6. subst.
          unfold is_consistent in new.
          apply (new (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
          apply (is_consistent_one_lesss) in new.
          unfold is_consistent in new.
          apply (new (assign_cons v4 v3) (assign_cons v4 v5)) ; auto.
    destruct H0.
    exists v1.
    destruct H0.
    rewrite H0.
    split.
    simpl. left. auto.
    auto.
    apply IHcert in H0 ; auto.
    destruct H0.
    destruct H0.
    exists x.
    split.
    simpl. right. auto.
    auto.
  + left. auto.
Qed.

Lemma is_consistent_in_parts : forall c1 c2,
  is_consistent (c1 ++ c2) -> is_consistent c1 /\ is_consistent c2.
Proof.
  intros c1 c2 H.
  + induction c1.
    - simpl in *.
      split.
      unfold is_consistent.
      intros. destruct assign1. destruct assign2. intros. inversion H0.
      auto.
    - simpl in *.
      assert (H' := H).
      apply is_consistent_one_lesss in H'.
      apply IHc1 in H'.
      destruct H'.
      split.
      unfold is_consistent. unfold is_consistent in H.
      intros.
      specialize (H assign1 assign2).
      destruct assign1. destruct assign2.
      intros. apply H ; auto ; simpl.
      inversion H2 ; auto. right. apply in_or_app. left. auto.
      inversion H3 ; auto. right. apply in_or_app. left. auto.
      auto.
Qed.

Lemma not_consistent : forall cert,
 ~ is_consistent cert <->
  (exists v0 v1 v3, In (assign_cons v0 v1) cert /\ In (assign_cons v0 v3) cert /\ v1 <> v3).
Proof.
  intros cert.
  split ; intros.
  + induction cert.
    - assert (is_consistent []).
      unfold is_consistent.
      intros.
      destruct assign1. destruct assign2.
      intros.
      inversion H0.
      intuition.
    - destruct a0 as [va0 va1].
      assert (~ is_consistent cert \/ (exists v3, In (assign_cons va0 v3) cert /\ va1 <> v3)).
      apply not_consistent_one_less ; auto.
      destruct H0.
      apply IHcert in H0.
      destruct H0.
      destruct H0.
      destruct H0.
      destruct H0.
      destruct H1.
      exists x. exists x0. exists x1.
      split.
      simpl. right. auto.
      split.
      simpl. right. auto.
      auto.
      destruct H0.
      destruct H0.
      exists va0. exists va1. exists x.
      split.
      simpl. left. auto.
      split.
      simpl. right. auto.
      auto.
  + repeat destruct H.
    destruct H0.
    unfold is_consistent.
    intuition.
    specialize (H2 (assign_cons x x0) (assign_cons x x1)).
    simpl in H2.
    apply H1.
    apply H2 ; auto.
Qed.

Lemma is_consistent_one_less : forall a0 a1 cert,
  is_consistent (a0 :: a1 :: cert) ->
  is_consistent (a0 :: cert).
Proof.
  intros a0 a1 cert H.
  unfold is_consistent in *.
  intros.
  destruct assign1.
  destruct assign2.
  intros.
  specialize (H (assign_cons v0 v1)).
  specialize (H (assign_cons v2 v3)).
  simpl in H.
  apply H ; auto.
  inversion H0.
  left. auto.
  right. right. auto.
  inversion H1.
  left. auto.
  right. right. auto.
Qed.

Lemma is_alwayss: forall a0 cert,
  is_consistent (a0 :: cert) -> is_always a0 cert = true.
Proof.
  intros.
  destruct a0.
  induction cert.
  + auto.
  + simpl.
    assert (H' := H).
    apply is_consistent_one_less in H.
    apply IHcert in H.
    rewrite H in *.
    destruct a0.
    assert ({v0 = v2} + {v0 <> v2}).
    apply var_eq_dec.
    destruct H0.
      rewrite e in *.
      unfold var_beq.
      destruct (var_eq_dec v2 v2).
      unfold is_consistent in H'.
      assert (v1 = v3).
      specialize (H' (assign_cons v2 v1)).
      specialize (H' (assign_cons v2 v3)).
      simpl in H'.
      apply H' ; auto.
      rewrite H0.
      unfold val_beq.
      destruct (val_eq_dec v3 v3).
      auto.
      intuition.
      intuition.

      unfold var_beq.
      destruct (var_eq_dec v0 v2).
      intuition.
      reflexivity.
Qed.

Lemma is_alwayssss : forall v2 v1 a0 cert,
  is_always (assign_cons v2 v1) (a0 :: cert) = true ->
  is_always (assign_cons v2 v1) cert = true.
Proof.
  intros v2 v1 a0 cert H.
  simpl in H.
  destruct a0.
  unfold var_beq in H.
  unfold val_beq in H.
  destruct (var_eq_dec v2 v0) in H.
  destruct (val_eq_dec v1 v3) in H.
  apply andb_true_iff in H.
  destruct H ; auto.
  apply andb_true_iff in H.
  destruct H. inversion H.
  auto.
Qed.

Lemma is_alwaysss : forall v2 v1 v3 cert,
  is_always (assign_cons v2 v1) cert = true ->
  In (assign_cons v2 v3) cert ->
  v1 = v3.
Proof.
  intros v2 v1 v3 cert H H0.
  induction cert.
  + inversion H0.
  + assert (H' := H).
    assert (is_always (assign_cons v2 v1) cert = true).
    apply is_alwayssss in H ; auto.
    inversion H0.
    - rewrite H2 in *.
      simpl in H.
      unfold var_beq in H.
      destruct (var_eq_dec v2 v2).
      apply andb_true_iff in H.
        destruct H.
        unfold val_beq in H.
        destruct (val_eq_dec v1 v3).
        auto.
        inversion H.
        intuition.
    - apply IHcert in H1 ; auto.
Qed.

Lemma check_ass_list_works : forall (cert : Certificate),
  (check_ass_list cert) = true <-> is_consistent cert.
Proof.
  intros cert.
  induction cert.
  + unfold is_consistent.
    simpl.
    intuition.
    destruct assign1.
    destruct assign2.
    intuition.
  + split ; intros.
    - assert (check_ass_list cert = true).
      simpl in H.
      apply andb_true_iff in H.
      destruct H.
      auto.
      apply IHcert in H0.
      unfold is_consistent.
      destruct assign1.
      destruct assign2.
      intros.
      inversion H1.
        inversion H2.
          rewrite H5 in H4.
          apply <- asign_cons_eq_dec2 in H4.
          destruct H4 ; auto.
          unfold check_ass_list in H.
          apply andb_true_iff in H.
          destruct H.
          rewrite H4 in *.
          rewrite H3 in *.
          apply (is_alwaysss v2 v1 v3 cert) ; auto.
        inversion H2.
          unfold check_ass_list in H.
          apply andb_true_iff in H.
          destruct H.
          rewrite H3 in *.
          rewrite H5 in *.
          symmetry.
          apply (is_alwaysss v2 v3 v1 cert) ; auto.
          unfold is_consistent in H0.
          rewrite H3 in *.
          specialize (H0 (assign_cons v2 v1) (assign_cons v2 v3)).
          simpl in H0.
          apply H0 ; auto.
    - assert (check_ass_list cert = true).
      apply IHcert.
      unfold is_consistent in *.
      intros.
      specialize (H assign1 assign2).
      destruct assign1.
      destruct assign2.
      intros.
      apply H ; auto.
      simpl ; right ; auto.
      simpl ; right ; auto.
      simpl.
      rewrite H0.
      assert (is_always a0 cert = true).
      apply is_alwayss.
      auto.
      rewrite H1.
      auto.
Qed.

End Help_Lemmata.


Require Import Logic.Class.Eq.

Require Import Logic.Axiom.LEM.

Require Import Logic.Rel.Prop.

Require Import Logic.Nat.Fresh.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.
Require Import Logic.Set.Empty.
Require Import Logic.Set.ElemIncl.
Require Import Logic.Set.Foundation.
Require Import Logic.Set.Extensionality.

Require Import Logic.Fol.Syntax.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Context.

(* Just so the predicate Eval can have two arguments instead of three.          *)
Inductive Interpretation : Type :=
| mkInterp : forall (p:Formula) (A:Prop), Interpretation
.

Notation "p >> P" := (mkInterp p P)
    (at level 1, no associativity) : Context_scope.

Open Scope Context_scope.

Inductive Eval : Context -> Interpretation -> Prop :=
| EvalBot  : forall (G:Context), Eval G Bot >> False
| EvalElem : forall (G:Context) (n m:nat) (x y:set),
    G :> n~>x -> G :> m~>y -> Eval G (Elem n m) >> (x :: y)
| EvalImp  : forall (G:Context) (p1 p2:Formula) (A1 A2:Prop),
    Eval G p1 >> A1 -> Eval G p2 >> A2 -> Eval G (Imp p1 p2) >> (A1 -> A2)
| EvalAll  : forall (G:Context) (n:nat) (p1:Formula) (A1:set -> Prop),
    (forall (x:set), Eval (G ; n~>x) p1 >> (A1 x)) ->
    Eval G (All n p1) >> (forall (x:set), A1 x)
| EvalEqu  : forall (G:Context) (p:Formula) (A B:Prop),
    A <-> B -> Eval G p >> A -> Eval G p >> B
.

Notation "G :- I" := (Eval G I)
    (at level 60, no associativity).

Open Scope Context_scope.

(* Just restating constructor EvalBot with custom notations.                    *)
Lemma evalBot : forall (G:Context), G :- Bot >> False.
Proof.
    intros G. constructor.
Qed.

(* Just restating constructor EvalElem with custom notations.                   *)
Lemma evalElem : forall (G:Context) (n m:nat) (x y:set),
    G :> n~>x ->
    G :> m~>y ->
    G :- (Elem n m) >> (x :: y).
Proof.
    intros G n m x y H1 H2. constructor; assumption.
Qed.

(* Just restating constructor EvalImp with custom notations.                    *)
Lemma evalImp : forall (G:Context) (p1 p2:Formula) (A1 A2:Prop),
    G :- p1 >> A1 ->
    G :- p2 >> A2 ->
    G :- (Imp p1 p2) >> (A1 -> A2).
Proof.
    intros G p1 p2 A1 A2 H1 H2. constructor; assumption.
Qed.

(* Just restating constructor EvalAll with custom notations.                    *)
Lemma evalAll : forall (G:Context) (n:nat) (p1:Formula) (A1:set -> Prop),
    (forall (x:set), G ; n~>x :- p1 >> (A1 x)) ->
        G :- (All n p1) >> (forall (x:set), A1 x).
Proof.
    intros G n p1 A1 H1. constructor. assumption.
Qed.

Lemma evalMonotone : forall (G H:Context) (p:Formula) (A:Prop),
    G <= H      ->
    G :- p >> A ->
    H :- p >> A.
Proof.
    intros G H p A H1 H2. revert H H1. induction H2 as
        [G
        |G n m x y H1 H2
        |G p1 p2 A1 A2 H1 IH1 H2 IH2
        |G n p1 A1 H1 IH1
        |G p' A' B' H1 H2 IH2
        ];
    intros H H3.
    - apply evalBot.
    - apply evalElem; apply H3; assumption.
    - apply evalImp.
        + apply IH1. assumption.
        + apply IH2. assumption.
    - apply evalAll. intros x. apply IH1. apply ctxInclExtend. assumption.
    - apply EvalEqu with A'; try assumption. apply IH2. assumption.
Qed.

Lemma evalCompat : forall (G G':Context) (p:Formula) (A:Prop),
    ctxEqual G G' -> G :- p >> A -> G' :- p >> A.
Proof.
    intros G G' p A [H1 H2] H3. apply evalMonotone with G; assumption.
Qed.

Lemma evalWeaken : forall (G:Context) (p:Formula) (A:Prop),
    O :- p >> A ->
    G :- p >> A.
Proof.
    intros G p A. apply evalMonotone, ctxInclO.
Qed.

Lemma evalDrop : forall (G:Context) (p:Formula) (n:nat) (x y:set) (A : Prop),
    G ; n~>y ; n~>x :- p >> A ->
    G ; n~>x :- p >> A.
Proof.
    intros G p n x y A. apply evalMonotone. intros m z H1.
    destruct (eqDec n m) as [H2|H2].
    - subst. apply bindEqualRev in H1.
      apply FindE with x; try assumption. constructor.
    - apply bindDiff in H1; try assumption.
      apply bindDiff in H1; try assumption.
      apply bindDiff; assumption.
Qed.

Lemma evalSwap : forall (G:Context) (p:Formula) (n m:nat) (x y:set) (A:Prop),
    n <> m                      ->
    G ; m~>y ; n~>x :- p >> A   ->
    G ; n~>x ; m~>y :- p >> A.
Proof.
    intros G p n m x y A H1. apply evalMonotone. intros k z H2.
    destruct (eqDec n k) as [H3|H3].
    - subst. apply bindEqualRev in H2. apply bindDiff.
        + apply not_eq_sym. assumption.
        + apply FindE with x; try assumption. constructor.
    - destruct (eqDec m k) as [H4|H4].
        + subst. apply bindDiff in H2; try assumption.
          apply bindEqualRev in H2.
          apply FindE with y; try assumption. constructor.
        + apply bindDiff in H2; try assumption.
          apply bindDiff in H2; try assumption.
          apply bindDiff; try assumption.
          apply bindDiff; assumption.
Qed.

Lemma evalNot : forall (G:Context) (p:Formula) (A:Prop),
    G :- p >> A  ->
    G :- (Not p) >> ~A.
Proof.
    intros G p A H1. unfold Not. constructor; try assumption. constructor.
Qed.

Lemma evalOr : LEM -> forall (G:Context) (p q:Formula) (A B:Prop),
    G :- p >> A                 ->
    G :- q >> B                 ->
    G :- (Or p q) >> (A \/ B).
Proof.
    intros L G p q A B H1 H2. unfold Or.
    apply EvalEqu with (~A -> B).
    - apply LEMOr. assumption.
    - constructor; try assumption. apply evalNot. assumption.
Qed.

Lemma evalAnd : LEM -> forall (G:Context) (p q:Formula) (A B:Prop),
    G :- p >> A                 ->
    G :- q >> B                 ->
    G :- (And p q) >> (A /\ B).
Proof.
    intros L G p q A B H1 H2. unfold And, Or.
    apply EvalEqu with (~(~~A -> ~B)).
    - apply LEMAnd. assumption.
    - apply evalNot, evalImp.
        + apply evalNot, evalNot. assumption.
        + apply evalNot. assumption.
Qed.

Lemma evalExi : LEM -> forall (G:Context) (p:Formula) (n:nat) (A:set -> Prop),
    (forall (x:set), G ; n~>x :- p >> (A x))  ->
    G :- (Exi n p) >> exists (x:set), A x.
Proof.
    intros L G p n A H1. unfold Exi.
    apply EvalEqu with (~(forall (x:set), ~A x)).
    - apply LEMExist. assumption.
    - apply evalNot, evalAll. intros x. apply evalNot, H1.
Qed.

Lemma evalIff : LEM -> forall (G:Context) (p q:Formula) (A B:Prop),
    G :- p >> A                 ->
    G :- q >> B                 ->
    G :- (Iff p q) >> (A <-> B).
Proof.
    intros L G p q A B H1 H2. unfold Iff.
    apply evalAnd; try assumption; apply evalImp; assumption.
Qed.

(* Needed for set inclusion notation x <= y                                     *)
Open Scope Set_Incl_scope.

(* LEM is not needed for this one.                                              *)
Lemma evalSub : forall (G:Context) (n m:nat) (x y:set),
    G :> n~>x                   ->
    G :> m~>y                   ->
    G :- (Sub n m) >> (x <= y).
Proof.
    intros G n m x y H1 H2. unfold Sub.
    apply EvalEqu with (forall (z:set), z :: x -> z :: y).
    - rewrite elemIncl. split; auto.
    - apply evalAll. intros z. apply evalImp; apply evalElem; try (apply FindZ);
      apply bindDiff; try assumption.
          + apply freshNot_n.
          + apply freshNot_m.
Qed.

Lemma evalEqu : LEM -> forall (G:Context) (n m:nat) (x y:set),
    G :> n~>x                   ->
    G :> m~>y                   ->
    G :- (Equ n m) >> (x == y).
Proof.
    intros L G n m x y H1 H2. unfold Equ. apply evalAnd; try assumption;
    apply evalAll; intros z; apply evalIff; try assumption; apply evalElem;
    try (apply FindZ); apply bindDiff; try assumption;
    try (apply freshNot_n); apply freshNot_m.
Qed.

Lemma evalEmpty : forall (G:Context) (n:nat) (x:set),
    G :> n~>x                   ->
    G :- (Empty n) >> (x == Nil).
Proof.
    intros G n x H1. unfold Empty.
    apply EvalEqu with (forall (z:set), ~z :: x).
    - split.
        + apply emptyUnique.
        + intros H2. rewrite emptyIsNil in H2. rewrite H2. apply emptyCharac.
    - apply evalAll. intros z. apply evalNot, evalElem; try (apply FindZ).
      apply bindDiff; try assumption. apply freshNot_n.
Qed.

Lemma evalMin : LEM -> forall (G:Context) (n m:nat) (x y:set),
    G :> n~>x                   ->
    G :> m~>y                   ->
    G :- (Min n m) >> (minimal x y).
Proof.
    intros L G n m x y H1 H2. unfold Min, minimal.
    apply evalAnd; try assumption.
    - apply evalElem; assumption.
    - apply evalNot, evalExi; try assumption. intros z.
      apply evalAnd; try assumption; apply evalElem; try (apply FindZ);
      apply bindDiff; try assumption;
      try (apply freshNot_n); apply freshNot_m.
Qed.

Lemma evalDeterministic : forall (G:Context) (p:Formula) (A B:Prop),
    G :- p >> A -> G :- p >> B -> A <-> B.
Proof.
    intros G p A B H1. revert B. remember (p >> A) as b eqn:E.
    revert p A E. induction H1 as
        [G
        |G n m x y H1 H2
        |G p1 p2 A1 A2 H1 IH1 H2 IH2
        |G n p1 A1 H1 IH1
        |G p' A' B' H1 H2 IH2
        ];
    intros p A H3 B H4; inversion H3; subst; clear H3.
    - remember (Bot >> B) as b eqn:E. revert B E.
      induction H4 as
        [
        |
        |
        |
        | G p' A B H2 H3 IH
        ];
      intros B' H1; inversion H1; subst; clear H1.
        + split; auto.
        + apply equivTrans with A; try assumption. apply IH. reflexivity.
    - remember ((Elem n m) >> B) as b eqn:E. revert n m x y H1 H2 B E.
      induction H4 as
        [
        |
        |
        |
        | G p' A B H2 H3 IH
        ];
      intros n' m' x' y' H4 H5 B' H6; inversion H6; subst; clear H6.
        + split; apply elemCompatLR.
            { apply (bindDeterministic G n'); assumption. }
            { apply (bindDeterministic G m'); assumption. }
            { apply (bindDeterministic G n'); assumption. }
            { apply (bindDeterministic G m'); assumption. }
        + apply equivTrans with A; try assumption. apply (IH n' m' x' y');
          try assumption. reflexivity.
    - remember ((Imp p1 p2) >> B) as b eqn:E.
      revert p1 p2 A1 A2 H1 H2 IH1 IH2 B E.
      induction H4 as
        [
        |
        |
        |
        | G p' A B H2 H3 IH
        ];
      intros p1' p2' A1' A2' H4 H5 H6 H7 B' H9; inversion H9; subst; clear H9.
        + apply implyCompatLR.
            { apply H6 with p1'; try assumption. reflexivity. }
            { apply H7 with p2'; try assumption. reflexivity. }
        + apply equivTrans with A; try assumption.
          apply (IH p1' p2'); try assumption. reflexivity.
    - remember ((All n p1) >> B) as b eqn:E.
      revert n p1 A1 H1 IH1 B E.
      induction H4 as
        [
        |
        |
        |
        | G p' A B H2 H3 IH
        ];
        intros n' p1' A1' H4 H5 B' H6; inversion H6; subst; clear H6.
        + apply allCompat. intros x. apply (H5 x p1'); try reflexivity. apply H.
        + apply equivTrans with A; try assumption.
          apply (IH n' p1'); try assumption. reflexivity.
    - apply equivTrans with A'.
        + apply equivSym. assumption.
        + apply IH2 with p; try assumption. reflexivity.
Qed.


From Coq Require Import ProofIrrelevance.

Lemma proj1_sig_injective: forall {A:Type} (P:A->Prop)
  (a1 a2:{x:A | P x}), proj1_sig a1 = proj1_sig a2 -> a1 = a2.
Proof.
intros.
destruct a1, a2.
now apply subset_eq_compat.
Qed.


Require Import prosa.classic.model.time prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import Time SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: time;
      task_period: time;
      task_deadline: time
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        move: EQ => /orP [EQ | /eqP PERIOD].
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP COST].
        by apply ID; inversion BUG.
        by apply COST; inversion BUG.
        by apply PERIOD; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


(** This file contains the termination argument via logical relations *)

Require Export Semantics.
Open Scope t_scope.
Open Scope list_scope.

Section Definitions.

  (* Logical relation at 2 *)
  Inductive R2 : te -> Prop :=
  | RT : forall M (HRed : M ↦* TT), R2 M
  | RF : forall M (HRed : M ↦* FF), R2 M.

  (* Logical relation at type ω *)
  Inductive Rω : te -> Prop :=
  | Rω_z : forall M (HRed : M ↦* z), Rω M
  | Rω_s : forall M M' (HRed : M ↦* s M') (HR : Rω M'), Rω M.

  (* Logical relation at type stream, parameterised with the relation at element type *)
  CoInductive Rstream : (te -> Type) -> te -> Prop :=
  | Rs : forall M P (HHD : P (hd M)) (HTL : Rstream P (tl M)), Rstream P M.

  (* The reducibility relation: has to be defined as a fixpoint, since Coq doesn't allow
     for negative occurrences of a relation in the A₁ → A₂ case *)
  Fixpoint R A M : Prop :=
    match A with
      | 2 => R2 M
      | ω => Rω M
      | A₁ → A₂ => forall N (HTN : nil ⊢ N ::: A₁) (HR : R A₁ N), R A₂ (M @ N)
      | stream A => Rstream (R A) M
    end.

  (* Reduciblity for the whole contexts *)
  Fixpoint rctx γ Γ :=
    match γ, Γ with
      | nil, nil => True
      | M :: γ, A :: Γ => R A M /\ rctx γ Γ
      | _, _ => False
    end.

End Definitions.

Section Termination_proof.

  Lemma head_expansion : forall A M N
    (HR : R A N)
    (HS : M ↦ N),
    R A M.
  Proof.
    induction A; intros; simpl in *.
    (* bool *)
    inversion HR; [ apply RT | apply RF ]; econstructor; eassumption.
    (* nat *)
    inversion HR.
      apply Rω_z; unfold steps; econstructor; eassumption.
    apply Rω_s with M'; [| assumption]; econstructor; eassumption.
    (* arr *)
    intros.
    eapply IHA2; [| apply red_appC; eassumption].
    apply HR; assumption.
    (* stream *)
    (* We need coinduction to prove the property here, and a stronger lemma. *)
    assert (HT : exists K : te, (M ↦ K) /\ Rstream (R A) K)
      by (exists N; tauto).
    clear HS HR; destruct HT as [K [HRed HR]]; generalize dependent K; revert M.
    cofix; intros.
    inversion HR; subst; apply Rs.
      eapply IHA; [eassumption | apply red_hdC; eassumption].
    eapply head_expansion; [| eassumption].
    apply red_tlC; assumption.
  Qed.

  (* lifting of head expansion to reflexive transitive closure *)
  Lemma head_exp_star : forall A M N
    (HR : R A N)
    (HS : M ↦* N),
    R A M.
  Proof.
    intros; induction HS; [assumption |].
    eapply head_expansion; [| eassumption].
    tauto.
  Qed.

  Lemma types_red : forall Γ M A γ
    (HT : Γ ⊢ M ::: A)
    (HR : rctx γ Γ)
    (HΓ : tcmt γ Γ),
    R A [γ!0]M.
  Proof.
    intros; generalize dependent γ; induction HT; intros.
    (* var *)
    assert (HT := subst_var _ _ _ 0 _ HFind HΓ); rewrite plus_comm in HT; simpl in *.
    destruct HT as [HT _].
    revert HT; generalize ([γ ! 0](#n)) as M; intros M; generalize dependent Γ;
      revert n; induction γ; simpl; destruct Γ; intros; try contradiction; [|].
      destruct n; discriminate.
    destruct n; simpl in *.
      inversion HT; subst a.
      inversion HFind; subst t; tauto.
    destruct HR as [Ha HR]; destruct HΓ as [Ht HΓ]; eapply IHγ; eassumption.
    (* lam *)
    simpl; intros; rewrite sub_lam.
    eapply head_expansion; [| apply red_β].
    rewrite subcomp; apply IHHT; simpl; tauto.
    (* appl *)
    rewrite sub_app; simpl in IHHT1.
    apply IHHT1; intuition; [].
    eapply subst_types; simpl; eassumption.
    (* z *)
    apply Rω_z; rewrite sub_z; constructor.
    (* s *)
    simpl in *; rewrite sub_s; eapply Rω_s; [constructor | intuition].
    (* rec *)
    specialize (IHHT1 _ HR HΓ); specialize (IHHT2 _ HR HΓ); simpl in *.
    assert (HTR : nil ⊢ [γ ! 0]M ::: ω) by (eapply subst_types; simpl; eassumption).
    rewrite sub_rec; revert IHHT1 HTR; generalize ([γ ! 0]M); intros K HRK HTK;
      induction HRK.
      apply head_exp_star with (rec z [γ ! 0]M₀ [γ ! 2]M₁);
        [| apply rec_cong_star; assumption].
      eapply head_expansion; [| apply red_recz]; assumption.
    eapply head_exp_star with (rec (s M') [γ ! 0]M₀ [γ ! 2]M₁);
    [| apply rec_cong_star; assumption].
    eapply head_expansion; [| apply red_recs].
    assert (HST : nil ⊢ s M' ::: ω).
      induction HRed; [assumption |].
      eapply IHHRed, preservation; eassumption.
    inversion HST; subst.
    rewrite subcomp; apply IHHT3; simpl; intuition; [].
    apply tc_rec; [assumption | |]; eapply subst_types; simpl; eassumption.
    (* hd *)
    specialize (IHHT _ HR HΓ); inversion IHHT; subst.
    rewrite sub_hd; assumption.
    (* tl *)
    specialize (IHHT _ HR HΓ); inversion IHHT; subst.
    rewrite sub_tl; assumption.
    (* seed *)
    specialize (IHHT1 _ HR HΓ).
    assert (HTR : nil ⊢ [γ ! 0]M ::: A) by (eapply subst_types; simpl; eassumption).
    clear HT1; simpl; rewrite sub_seed.
    assert (exists K, (seed [γ ! 0]M [γ ! 1]M₀ [γ ! 1]M₁ ↦* seed K [γ ! 1]M₀ [γ ! 1]M₁)
      /\ (nil ⊢ K ::: A) /\ R A K).
    simpl; eexists; split; [constructor | split; assumption].
    simpl in H; destruct H as [K [HRed [HTK HRK]]]; generalize dependent K.
    generalize (seed [γ ! 0]M [γ ! 1]M₀ [γ ! 1]M₁) as N.
    cofix; intros; apply Rs.
      eapply head_exp_star; [| eapply hd_cong_star; eassumption].
      eapply head_expansion; [| apply red_hds].
      change (R A [K :: nil ! 0]([γ ! 1]M₀)); rewrite subcomp.
      apply IHHT2; simpl; tauto.
    apply types_red with [K ↑ 0]([γ ! 1]M₁); clear types_red.
        apply clos_rt_rt1n; eapply rt_trans;
          [apply clos_rt1n_rt, tl_cong_star; eassumption |].
        apply rt_step, red_tls.
      change (nil ⊢ [K :: nil ! 0]([γ ! 1]M₁) ::: A); rewrite subcomp.
      eapply subst_types; [| simpl; eassumption]; simpl; tauto.
    change (R A [K :: nil ! 0]([γ ! 1]M₁)); rewrite subcomp.
    apply IHHT3; simpl; tauto.
    (* TT *)
    rewrite sub_TT; apply RT; constructor.
    (* FF *)
    rewrite sub_FF; apply RF; constructor.
  Qed.

  Theorem termination : forall M (HT : nil ⊢ M ::: ω),
    exists V, value V /\ (M ↦* V).
  Proof.
    intros.
    apply types_red with (γ := nil) in HT; [| exact I | exact I].
    inversion HT; subst.
    (* z *)
    exists z; split; [apply val_z | assumption].
    (* s *)
    exists (s M'); split; [apply val_s | assumption].
  Qed.

End Termination_proof.


Require Import EnvListAux7.
Require Import IdModType.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Logic.ProofIrrelevance.

Lemma valTyp_irrelevance : forall (T: Type) (p1 p2: ValTyp T), p1 = p2.
intros.
eapply proof_irrelevance.
Qed.

Module IdModA_M2_b <: IdModType.

  Definition Id := string.

  Definition IdEqDec := string_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Inductive page :Type := P (v:nat).
  Inductive index :Type := I (v:nat).
  Definition vAddress :Type := list index.
  Inductive vEntry :Type := VE (a:vAddress).
  Inductive pEntry :Type := PE (p:page).
  Inductive sValue : Type := SP:page->sValue
                            |SI:index->sValue
                            |SVA:vAddress->sValue
                            |SVE:vEntry->sValue
                            |SPE:pEntry->sValue.

  Definition Vpage (p:page) :nat := match p with |P p' => p' end.
  Definition Vindex (i:index) :nat := match i with |I i' => i' end.
  Fixpoint VvAddress (a:vAddress) :(list nat) :=
        match a with
          | nil => nil
          |cons (I i) ls => cons i (VvAddress ls)
        end.
  Definition VvEntry (a:vEntry) :list nat := match a with
                    |VE a' => VvAddress a' end.
  Definition VpEntry (a:pEntry) :nat := match a with | PE a' => Vpage a' end.

  Definition paddr := prod page index.

  Definition IdEq := IdEq2.

  Record state : Type := {
   currentPartition : page;
   memory : list (paddr * sValue);
   partitions : list page
  }.

  Definition W := state.

  Definition Loc_PI := valTyp_irrelevance.

  Definition page0:page := P 0.

  Definition BInit := {|
          currentPartition := page0 ;
          memory:= @nil (paddr * sValue);
          partitions := @nil page
                      |}.

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End IdModA_M2_b.


Require Import BinPosDef.
Require Import Arith.
Require Import NArith.
Require Import Ascii String.
Require Import Coq.Strings.HexString.

(*
Module notation_mod.
Definition testop := N.succ_double.
Section notation_sec.
Variable op : N -> bool.

Notation "- x" := (op x).
Compute - 3%N.
End notation_sec.
Print testop.
End notation_mod.

Class ECF : Type := mkField {U : Type; wrp : N -> U; uwp : U -> N;
    id0 : U; id1 : U; eql : U -> U -> bool; opp : U -> U;
       inv : U -> U; add : U -> U -> U; sub : U -> U -> U;
         mul : U -> U -> U; div : U -> U -> U; dbl : U -> U;
           squ : U -> U; pow : U -> N -> U}.

Print ECF.
Notation "x + y" := (add x y).
Print "+".
*)


(** ** First-Order Logic *)

(* Version: 19.09. *)

Require Export axioms.

Notation fin := nat.
Definition shift  := S.

Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
          |0 => x
          |S n => xi n
          end.

Notation "s .: sigma" := (scons s sigma) (at level 70).

Definition var_zero := 0.

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

(** **** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(** **** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

Class Var X Y :=
  ids : X -> Y.

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (*fun x => g (f x)*) (at level 50) : subst_scope.
Open Scope subst_scope.

Definition up_ren (xi : nat -> nat) :=
  0 .: (xi >> S).

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

Lemma up_ren_ren (xi: nat -> nat) (zeta : nat -> nat) (rho: nat -> nat) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [|x].
  - reflexivity.
  - unfold up_ren. simpl. unfold funcomp. rewrite <- E. reflexivity.
Qed.

Definition id {X} (x: X) := x.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.

Ltac fsimpl :=
  unfold up_ren; repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) (* AsimplComp *)
         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma)var_zero) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h))
        | [|- context[?f >> (?x .: ?g)]] =>
           change (f >> (x .: g)) with g
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: shift >> ?f]] =>
           change x2 with (f 0); rewrite (@scons_eta _ _ f)
         | [|- context[(?v .: ?g) 0]] =>
           change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] =>
           change ((v .: g) (S n)) with (g n)
         | [|- context[?f 0 .: ?g]] =>
           change g with (shift >> f); rewrite scons_eta
         | _ => first [progress (rewrite ?scons_comp) | progress (rewrite ?scons_eta_id)]
 end.

Ltac fsimplc :=
  unfold up_ren; repeat match goal with
         | [H : context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id] |- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s] |- _]  => change (id s) with s in H
         | [H:  context[(?f >> ?g) >> ?h]  |- _] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) in H(* AsimplComp *)
         | [H : context[(?s.:?sigma) var_zero]  |- _] => change ((s.:sigma)var_zero) with s in H
         | [H: context[(?f >> ?g) >> ?h]  |- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H
        | [H: context[?f >> (?x .: ?g)]  |- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[var_zero]  |- _] =>  change var_zero with 0 in H
         | [H: context[?x2 .: shift >> ?f]  |- _] =>
           change x2 with (f 0) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[(?v .: ?g) 0]  |- _] =>
           change ((v .: g) 0) with v in H
         | [H: context[(?v .: ?g) (S ?n)]  |- _] =>
           change ((v .: g) (S n)) with (g n) in H
         | [H: context[?f 0 .: ?g]  |- _] =>
           change g with (shift >> f); rewrite scons_eta in H
         | _ => first [progress (rewrite ?scons_comp in *)  | progress (rewrite ?scons_eta_id in *) ]
 end.

Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

(** **** Notations *)

(* Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope. *)

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.
Instance idsRen : Var nat nat := id.

Notation "↑" := (shift).

Ltac auto_unfold := unfold subst1, ren1, subst2, ren2, ids; unfold Subst1, Ren1, Subst2, Ren2, Var.

Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : nat), _] => intros []; t
                                           end).

    Ltac unfold_funcomp := match goal with
                           | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                           end.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj30eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 (Succ lv1)) (mult (Succ lv1) lv0)).
Admitted.
QuickChick conj30eqsynthconj6.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m187_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.