Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.

Import ListNotations.

Require Import SfLib.
Require Import Maps.
Require Import Imp.

Definition aequiv  (a1 a2: aexp) : Prop :=
  forall st,
    aeval st a1 = aeval st a2.
Definition bequiv (b1 b2: bexp) : Prop :=
  forall st,
    beval st b1 = beval st b2.

Definition cequiv (c1 c2:com) : Prop :=
  forall st st',
    c1 / st \\ st' <-> c2 / st \\ st'.

Example aequiv_example:
  aequiv (AMinus (AId X) (AId X)) (ANum 0).

unfold aequiv. intros. simpl. omega.
Qed.

Theorem skip_left :
  forall c,
    cequiv (SKIP;;c)
           c.
  intro. unfold cequiv. split.
  intros. inversion H. inversion H2. auto.
  intros. eapply E_Seq. apply E_Skip. auto.
Qed.

Theorem skip_right:
  forall c,
    cequiv (c;;SKIP)
           c.
  unfold cequiv. split.
  intros. inversion H. inversion H5. rewrite H8 in H2. auto.
  intros. eapply E_Seq. apply H. apply E_Skip.
Qed.

Theorem IFB_true_simple :
  forall c1 c2,
    cequiv (IFB BTrue THEN c1 ELSE c2 FI)
           c1.
  unfold cequiv. split.
  intros. inversion H; auto. simpl in H5. discriminate.
  intros. apply E_IfTrue. auto. apply H.
Qed.

Theorem IFB_true :
  forall b c1 c2,
    bequiv b BTrue ->
    cequiv (IFB b THEN c1 ELSE c2 FI)
           c1.

  split. intros.
  inversion H0; auto. unfold bequiv in H. pose (H st). rewrite H6 in e. simpl in e. discriminate.
  intros. apply E_IfTrue. pose (H st). simpl in e; auto.
  auto.
Qed.

Theorem swap_if_branches:
  forall b e1 e2,
    cequiv (IFB b THEN e1 ELSE e2 FI)
           (IFB BNot b THEN e2 ELSE e1 FI).
  unfold cequiv.
  intros until st.
  destruct (beval st b) eqn: b1.
  split. intros. inversion H. apply E_IfFalse. simpl. rewrite H5. auto. auto.
  apply E_IfTrue. simpl. rewrite H5. auto. auto.
  intros. inversion H. simpl in H5. rewrite b1 in H5. simpl in H5. discriminate.
  apply E_IfTrue. auto. auto.
  split. intros. apply E_IfTrue. simpl; rewrite b1; auto. inversion H. rewrite b1 in H5; discriminate.
  auto.
  intros. apply E_IfFalse. auto. inversion H; auto. simpl in H5; rewrite b1 in H5; simpl in H5; discriminate.
Qed.

Theorem WHILE_false :
  forall b c,
    bequiv b BFalse ->
    cequiv (WHILE b DO c END)
           SKIP.

  intros. split. intros. pose (H st). simpl in e. inversion H0. rewrite e in H3; discriminate.
  apply E_Skip.
  intros. inversion H0. apply E_WhileEnd. pose (H st). simpl in e; subst st'; auto.
Qed.

Lemma WHILE_true_nonterm :
  forall b c st st',
    bequiv b BTrue ->
    ~( (WHILE b DO c END) / st \\ st').
  unfold not. intros. remember (WHILE b DO c END) as h. generalize Heqh.
  elim H0; try (simpl; intros; discriminate).
  intros. auto.
  intros. inversion Heqh0; subst b0.
  pose (H st0). simpl in e. rewrite e in H1. discriminate.
Qed.

Theorem WHILE_true :
  forall b c,
    bequiv b BTrue ->
    cequiv (WHILE b DO c END)
           (WHILE BTrue DO SKIP END).
  split. intros. pose (WHILE_true_nonterm b c st st'). elim (n H H0).
  intros. pose (WHILE_true_nonterm BTrue SKIP st st'). unfold bequiv in n.
  assert (False). apply n. intros; auto. auto. elim H1.
Qed.

Theorem seq_assoc :
  forall c1 c2 c3,
    cequiv ((c1 ;; c2) ;; c3)
           (c1 ;; (c2 ;; c3)).

  split. intros. inversion H. inversion H2. eapply E_Seq. apply H8. eapply E_Seq. apply H11. auto.
  intros. inversion H. inversion H5. eapply E_Seq. eapply E_Seq. apply H2. apply H8. apply H11.
Qed.

Theorem identity_assignment :
  forall (X:id),
    cequiv (X ::= AId X)
           SKIP.

  split. intros. inversion H.
  assert (st = t_update st X n).
  apply functional_extensionality.
  intro. unfold t_update.
  case (eq_id_dec X x0). intros. simpl in H4. subst x0. auto.
  auto. pattern st at 1. rewrite H5. apply E_Skip.
  intros. inversion H.
  assert (st' = t_update st' X (aeval st' (AId X))).
  apply functional_extensionality.
  intro; unfold t_update.
  case (eq_id_dec X x). simpl. intros; subst x; auto.
  auto.
  pattern st' at 2. rewrite H0. eapply E_Ass. auto.
Qed.

Theorem symm_cequiv:
  forall a b,
    cequiv a b <-> cequiv b a.
  unfold cequiv.
  intros. split; intros. split; apply (H st st').
  split; apply (H st st').
Qed.

Theorem assign_aequiv:
  forall X e,
    aequiv (AId X) e ->
    cequiv SKIP (X ::= e).
  intros. split; intros.
  pose (identity_assignment X).
  unfold cequiv in c. pose (c st st'). destruct i.
  pose (H2 H0). inversion c0. pose (H st). rewrite e0 in H7. rewrite <- H7.
  apply E_Ass. auto.
  apply (identity_assignment X). pose (H st).
  inversion H0. apply E_Ass. subst n; auto.
Qed.

Lemma refl_aequiv :
  forall a,
    aequiv a a.
  split.
Qed.

Lemma sym_aequiv:
  forall a1 a2,
    aequiv a1 a2 <-> aequiv a2 a1.
  split; intros;unfold aequiv; intros st; pose (H st); auto.
Qed.

Lemma trans_aequiv:
  forall a1 a2 a3,
    aequiv a1 a2 ->
    aequiv a2 a3 ->
    aequiv a1 a3.
  intros. unfold aequiv. intro. pose (H st); pose (H0 st). rewrite e; rewrite e0; auto.
Qed.

Lemma refl_bequiv:
  forall b,
    bequiv b b.
  split.
Qed.

Lemma symm_bequiv:
  forall b1 b2,
    bequiv b1 b2 -> bequiv b2 b2.
  unfold bequiv. intros. symmetry in H. auto.
Qed.

Lemma tran_bequiv:
  forall b1 b2 b3,
    bequiv b1 b2 ->
    bequiv b2 b3 ->
    bequiv b1 b3.
  unfold bequiv.
  intros.
  rewrite H; rewrite H0; auto.
Qed.

Lemma refl_cequiv:
  forall c,
    cequiv c c.
  split; auto.
Qed.

Lemma trans_cequiv :
  forall c1 c2 c3,
    cequiv c1 c2 ->
    cequiv c2 c3 ->
    cequiv c1 c3.

  unfold cequiv.
  split; intros.
  apply H0. apply H; auto.
  apply H. apply H0 ;auto.
Qed.

Theorem CAss_congruence :
  forall i a1 a1',
    aequiv a1 a1' ->
    cequiv (CAss i a1) (CAss i a1').
  split; intros.
  inversion H0. apply E_Ass. pose (H st). rewrite <- e. auto.
  inversion H0. apply E_Ass. pose (H st). rewrite e. auto.
Qed.

Theorem CWhile_congruence:
  forall b1 b1' c1 c1',
         bequiv b1 b1' ->
         cequiv c1 c1' ->
         cequiv (WHILE b1 DO c1 END)
                (WHILE b1' DO c1' END).

  split; intros. generalize dependent b1'. generalize dependent c1'.
  remember (WHILE b1 DO c1 END) as h1. generalize dependent Heqh1.
  elim H1; try (simpl; intros; discriminate).
  intros. pose (H4 Heqh1 c1' H5 b1' H6).
  eapply E_WhileLoop. inversion Heqh1. pose (H6 st0). rewrite <- e. rewrite <- H8. auto.
  inversion Heqh1. apply H5. rewrite <- H9. apply H0. apply c0.
  intros. pose (H2 st0). inversion Heqh1. subst b1. rewrite H in e. apply E_WhileEnd. auto.
  generalize dependent b1. generalize dependent c1.
  remember (WHILE b1' DO c1' END) as h1.
  generalize Heqh1. elim H1; try (simpl; intros; discriminate).
  intros. inversion Heqh0. pose (H4 Heqh0 c1 H5 b1 H6).
  eapply E_WhileLoop. rewrite H6. rewrite <- H8. auto.
  apply H5. rewrite <- H9. apply H0. auto.
  intros. apply E_WhileEnd. rewrite H2. inversion Heqh0. subst b1'. auto.
Qed.

Theorem CSeq_congruence :
  forall c1 c1' c2 c2',
    cequiv c1 c1' ->
    cequiv c2 c2' ->
    cequiv (c1;;c2) (c1';;c2).
  split.
  intros. inversion H1. eapply E_Seq. apply H. apply H4. apply H7.
  intros. inversion H1. eapply E_Seq. apply H. apply H4. apply H7.
Qed.

Theorem CIf_congruence:
  forall b b' c1 c1' c2 c2',
    bequiv b b' ->
    cequiv c1 c1' ->
    cequiv c2 c2' ->
    cequiv (IFB b THEN c1 ELSE c2 FI)
           (IFB b' THEN c1' ELSE c2' FI).
  split; intros.
  inversion H2. apply E_IfTrue. pose (H st). rewrite <- e. auto.
  apply H0. auto.
  apply E_IfFalse. rewrite <- H. auto.
  apply H1. auto.
  inversion H2. apply E_IfTrue. rewrite H. auto. apply H0. auto.
  apply E_IfFalse. rewrite H. auto. apply H1. auto.
Qed.

Definition atrans_sound (atrans: aexp -> aexp) : Prop :=
  forall (a:aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans: bexp -> bexp) : Prop :=
  forall (b:bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

Fixpoint fold_constants_aexp (a:aexp) : aexp :=
  match a with
    | ANum n => ANum n
    | AId i => AId i
    | APlus a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2)
      with
        | (ANum n1, ANum n2) => ANum (n1 + n2)
        | (a1' , a2') => APlus a1' a2'
      end
    | AMinus a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
        | (ANum n1, ANum n2) => ANum (n1 - n2)
        | (a1', a2') => AMinus a1' a2'
      end
    | AMult a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
        | (ANum n1, ANum n2) => ANum (n1 * n2)
        | (a1', a2') => AMult a1' a2'
      end
  end.

Example fold_aexp_ex1 :
  fold_constants_aexp (AMult (APlus (ANum 1) (ANum 2)) (AId X))
  = AMult (ANum 3) (AId X).
simpl; auto.
Qed.

Print eq_nat_dec.
SearchPattern ({_}+{_}).

Fixpoint fold_constants_bexp (b:bexp) : bexp :=
  match b with
    | BTrue => BTrue
    | BFalse => BFalse
    | BEq a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
        | (ANum n1, ANum n2) =>
          if (eq_nat_dec n1 n2) then BTrue else BFalse
        | (a1', a2') => BEq a1' a2'
      end
    | BLe a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
        | (ANum n1, ANum n2) =>
          if (le_dec n1 n2) then BTrue else BFalse
        | (a1' ,a2') => BLe a1' a2'
      end
    | BNot b1 =>
      match (fold_constants_bexp b1) with
        | BTrue => BFalse
        | BFalse => BTrue
        | b1' => BNot b1'
      end
    | BAnd b1 b2 =>
      match (fold_constants_bexp b1, fold_constants_bexp b2) with
        | (BTrue, BFalse) => BFalse
        | (BTrue, BTrue) => BTrue
        | (BFalse, BTrue) => BFalse
        | (BFalse, BFalse) => BFalse
        | (b1', b2') => BAnd b1' b2'
      end
  end.

Fixpoint fold_constants_com (c:com) : com :=
  match c with
    | SKIP => SKIP
    | i ::= a => CAss i (fold_constants_aexp a)
    | c1 ;; c2 => (fold_constants_com c1);;(fold_constants_com c2)
    | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
        | BTrue => fold_constants_com c1
        | BFalse => fold_constants_com c2
        | b' => IFB b' THEN (fold_constants_com c1) ELSE (fold_constants_com c2) FI
      end
    | WHILE b DO c END =>
      match fold_constants_bexp b with
        | BTrue => WHILE BTrue DO SKIP END
        | BFalse => SKIP
        | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Lemma fca_plus:
  forall a1 a2 st,
    aeval st (fold_constants_aexp (APlus a1 a2)) =
    aeval st (APlus (fold_constants_aexp a1) (fold_constants_aexp a2)).
  simpl. intros a1 a2. destruct (fold_constants_aexp a1) eqn: h1; destruct (fold_constants_aexp a2); try(simpl; auto; fail).
Qed.

Lemma fca_minus:
  forall a1 a2 st,
    aeval st (fold_constants_aexp (AMinus a1 a2)) =
    aeval st (AMinus (fold_constants_aexp a1) (fold_constants_aexp a2)).
  simpl. intros a1 a2. destruct (fold_constants_aexp a1) eqn: h1; destruct (fold_constants_aexp a2); try(simpl; auto; fail).
Qed.

Lemma fca_mult:
  forall a1 a2 st,
    aeval st (fold_constants_aexp (AMult a1 a2)) =
    aeval st (AMult (fold_constants_aexp a1) (fold_constants_aexp a2)).
  simpl. intros a1 a2. destruct (fold_constants_aexp a1) eqn: h1; destruct (fold_constants_aexp a2); try(simpl; auto; fail).
Qed.

Lemma aexp_plus_aplus:
  forall a1 a2 st,
    aeval st (APlus a1 a2) = aeval st a1 + aeval st a2.
  auto.
Qed.

Lemma aexp_minus_aminus:
  forall a1 a2 st,
    aeval st (AMinus a1 a2) = aeval st a1 - aeval st a2.
  auto.
Qed.

Lemma aexp_mult_amult:
  forall a1 a2 st,
    aeval st (AMult a1 a2) = aeval st a1 * aeval st a2.
  auto.
Qed.

Hint Rewrite aexp_plus_aplus aexp_minus_aminus aexp_mult_amult fca_plus fca_mult fca_minus : fca_rwbase.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
  unfold atrans_sound.
  unfold aequiv.
  intro. elim a; try (auto); try (intros; autorewrite with fca_rwbase);rewrite H; rewrite H0; autorewrite with fca_rwbase; auto.
Qed.

Theorem fold_constants_bexp_sound :
  btrans_sound fold_constants_bexp.
  unfold btrans_sound. unfold bequiv.
  intro. elim b; try (simpl; auto; fail);
         try (intros; simpl; rewrite (fold_constants_aexp_sound a); rewrite (fold_constants_aexp_sound a0); destruct (fold_constants_aexp a); destruct (fold_constants_aexp a0); try (simpl; auto; fail));
         try (intros; simpl; try (rewrite H); try (rewrite H0); try (rewrite H1); destruct (fold_constants_bexp b0); try (destruct (fold_constants_bexp b1)); try (simpl; auto; fail); fail).
  unfold beq_nat_bydec; intros; simpl; case (eq_nat_dec n n0); simpl; auto.
  unfold leb_bydec; intros; simpl; case (le_dec n n0); simpl; auto.
Qed.

Theorem fold_constants_com_sound:
  ctrans_sound fold_constants_com.

  unfold ctrans_sound. unfold cequiv.
  intro. split; generalize dependent st; generalize dependent st'.
  elim c; try (simpl; auto; fail); intros.
  simpl. inversion H. rewrite (fold_constants_aexp_sound a) in H4. rewrite <- H4.
  apply E_Ass; auto.
  simpl. inversion H1. pose (H _ _ H4). pose (H0 _ _ H7). eapply E_Seq. apply c4. apply c5.
  inversion H1. pose (H _ _ H8). pose (fold_constants_bexp_sound b st).
  rewrite H7 in e; symmetry in e.
  simpl; destruct (fold_constants_bexp b) eqn:hh ; try (simpl; auto; fail);
  try (rewrite H7 in hh; discriminate); try (rewrite e; simpl; auto); try (simpl in e; discriminate); try (apply E_IfTrue; auto).
  pose (H0 _ _ H8). pose (fold_constants_bexp_sound b st).
  rewrite H7 in e; symmetry in e.
 simpl; destruct (fold_constants_bexp b) eqn:hh ; try (simpl; auto; fail);
 try (rewrite H7 in hh; discriminate); try (rewrite e; simpl; auto); try (simpl in e; discriminate); try (apply E_IfFalse; auto).
 clear c. remember (WHILE b DO c0 END) as h. generalize dependent Heqh. elim H0; try (simpl; intros; discriminate).
 intros. inversion Heqh; subst b0; subst c0.
 destruct (fold_constants_bexp b) eqn: hh;
   pose (H5 eq_refl) as h2;
   simpl; simpl in h2; rewrite hh in h2; rewrite hh; pose (E_WhileLoop b c st0 st'0 st'' H1 H2 H4) as h0; (try auto).
 apply (WHILE_true b c). pose (fold_constants_bexp_sound b). rewrite hh in b0. auto.
 auto. pose (fold_constants_bexp_sound b st0) as h'; rewrite H1 in h'; rewrite hh in h'; simpl in h'; discriminate.
 eapply E_WhileLoop. rewrite <- hh. rewrite <- fold_constants_bexp_sound. auto. apply H. apply H2; auto. auto.
 eapply E_WhileLoop. rewrite <- hh. rewrite <- fold_constants_bexp_sound. auto. apply H. apply H2; auto. auto.
 eapply E_WhileLoop. rewrite <- hh. rewrite <- fold_constants_bexp_sound. auto. apply H. apply H2; auto. auto.
 eapply E_WhileLoop. rewrite <- hh. rewrite <- fold_constants_bexp_sound. auto. apply H. apply H2; auto. auto.
 intros. inversion Heqh; subst b0; subst c0.
 simpl; destruct (fold_constants_bexp b) eqn:hh; pose (fold_constants_bexp_sound b st0) as h1; rewrite H1 in h1; rewrite hh in h1; simpl in h1; (try discriminate); try ( apply E_WhileEnd; simpl; rewrite h1; auto).
 apply E_Skip.
 elim c; try auto.
 intros. pose (CAss_congruence i a (fold_constants_aexp a) (fold_constants_aexp_sound a) st st').
 destruct i0. auto.
 intros. inversion H1. Print E_Seq. apply (E_Seq _ _ st st'0); auto.
 intros. simpl in H1; destruct (fold_constants_bexp b) eqn:hh;
         try( apply E_IfTrue; pose (fold_constants_bexp_sound b st) as e; rewrite hh in e; try( rewrite e; auto); auto; fail);
         try( apply E_IfFalse; pose (fold_constants_bexp_sound b st) as e; rewrite hh in e; try( rewrite e; auto); auto; fail).
 inversion H1; [apply E_IfTrue | apply E_IfFalse]; pose (fold_constants_bexp_sound b st) as h3; rewrite hh in  h3; try( try rewrite h3; auto; apply H; auto; fail); try ( try rewrite h3; auto; apply H0; auto; fail).
 inversion H1; [apply E_IfTrue | apply E_IfFalse]; pose (fold_constants_bexp_sound b st) as h3; rewrite hh in  h3; try( try rewrite h3; auto; apply H; auto; fail); try ( try rewrite h3; auto; apply H0; auto; fail).
 inversion H1; [apply E_IfTrue | apply E_IfFalse]; pose (fold_constants_bexp_sound b st) as h3; rewrite hh in  h3; try( try rewrite h3; auto; apply H; auto; fail); try ( try rewrite h3; auto; apply H0; auto; fail).
 inversion H1; [apply E_IfTrue | apply E_IfFalse]; pose (fold_constants_bexp_sound b st) as h3; rewrite hh in  h3; try( try rewrite h3; auto; apply H; auto; fail); try ( try rewrite h3; auto; apply H0; auto; fail).
 intros. simpl in H0. destruct (fold_constants_bexp b) eqn:hh.
 apply (WHILE_true b c0). pose (fold_constants_bexp_sound b). rewrite hh in b0; auto. auto.
 inversion H0. apply E_WhileEnd. pose (fold_constants_bexp_sound b st'). rewrite hh in e; rewrite e; auto.
 rewrite <- hh in H0.
 remember (WHILE fold_constants_bexp b DO fold_constants_com c0 END) as h. generalize dependent Heqh. elim H0; try(simpl; intros; discriminate).
 intros. inversion Heqh; subst b0; subst c1. pose (H st'0 st0 H2). pose (H5 eq_refl). eapply E_WhileLoop. rewrite fold_constants_bexp_sound. auto. apply c1. apply c2.
 intros. inversion Heqh; subst b0 ; subst c1. apply E_WhileEnd. rewrite fold_constants_bexp_sound. auto.
 rewrite <- hh in H0.
 remember (WHILE fold_constants_bexp b DO fold_constants_com c0 END) as h. generalize dependent Heqh. elim H0; try(simpl; intros; discriminate).
 intros. inversion Heqh; subst b0; subst c1. pose (H st'0 st0 H2). pose (H5 eq_refl). eapply E_WhileLoop. rewrite fold_constants_bexp_sound. auto. apply c1. apply c2.
 intros. inversion Heqh; subst b0 ; subst c1. apply E_WhileEnd. rewrite fold_constants_bexp_sound. auto.
 rewrite <- hh in H0.
 remember (WHILE fold_constants_bexp b DO fold_constants_com c0 END) as h. generalize dependent Heqh. elim H0; try(simpl; intros; discriminate).
 intros. inversion Heqh; subst b1; subst c1. pose (H st'0 st0 H2). pose (H5 eq_refl). eapply E_WhileLoop. rewrite fold_constants_bexp_sound. auto. apply c1. apply c2.
 intros. inversion Heqh; subst b1 ; subst c1. apply E_WhileEnd. rewrite fold_constants_bexp_sound. auto.
 rewrite <- hh in H0.
 remember (WHILE fold_constants_bexp b DO fold_constants_com c0 END) as h. generalize dependent Heqh. elim H0; try(simpl; intros; discriminate).
 intros. inversion Heqh; subst b0; subst c1. pose (H st'0 st0 H2). pose (H5 eq_refl). eapply E_WhileLoop. rewrite fold_constants_bexp_sound. auto. apply c1. apply c2.
 intros. inversion Heqh; subst b0 ; subst c1. apply E_WhileEnd. rewrite fold_constants_bexp_sound. auto.
Qed.

Theorem inequiv_exercise:
  ~ cequiv (WHILE BTrue DO SKIP END)
    SKIP.

  unfold not; unfold cequiv. intros.
  pose (E_Skip (t_empty 0)).
  pose (H (t_empty 0) (t_empty 0)).
  destruct i. pose (H1 c).
  SearchPattern ( _ / _ \\ _).
  pose loop_never_stops.
  pose (n loop (t_empty 0) (t_empty 0) eq_refl). unfold loop in n0.
  unfold not in n0. auto.
Qed.

Module HIMP.

  Inductive com : Type :=
| CSkip : com
| CAss : id -> aexp -> com
| CSeq : com -> com -> com
| CIf : bexp -> com -> com -> com
| CWhile : bexp -> com -> com
| CHavoc : id -> com.

  Notation "'SKIP'" :=
    CSkip.

  Notation "X '::=' a":=
    (CAss X a) (at level 60).

  Notation "c1 ;; c2" :=
    (CSeq c1 c2) (at level 80, right associativity).

  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity).

  Notation "'IFB' b 'THEN' c1 'ELSE' c2 'END'" :=
    (CIf b c1 c2) (at level 80, right associativity).

  Notation "'HAVOC' l" := (CHavoc l) (at level 60).

  Reserved Notation "c1 '/' st '\\' st'"
           (at level 40, st at level 39).

End HIMP.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal47.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal47_theorem0_66_eqb_not_eq/goal47_lfind_orig.ml"  Coq.Init.Logic.not adtind.goal47.insort Coq.Init.Datatypes.orb adtind.goal47.eqb adtind.goal47.mem.
Success.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo270 : goal 270. Time solve_P. Time Qed.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about W-types (well-founded trees) *)

Require Import HoTT.Basics.
Require Import Types.Forall Types.Sigma Types.Paths Types.Unit.
Local Open Scope path_scope.

Generalizable Variables X A B C f g n.

(** Primitive projections do not work for recursive records; see bug #4648 - https://coq.inria.fr/bugs/show_bug.cgi?id=4648. *)
Local Unset Primitive Projections.
Inductive W (A : Type) (B : A -> Type) : Type :=
  sup { w_label : A ; w_arg : B w_label -> W A B }.
Local Set Primitive Projections.

Arguments w_label {A B} _.
Arguments w_arg {A B} _ _.

(** ** Paths *)

Definition path_wtype {A B} (u v : W A B)
  (pq : (w_label u;w_arg u) = (w_label v;w_arg v) :> {a : _ & B a -> W A B})
: u = v.
Proof.
  destruct u,v; apply (path_sigma_uncurried _ _ _)^-1 in pq.
  destruct pq as [p q]; cbn in p; destruct p; cbn in q; destruct q.
  exact idpath.
Defined.

Definition path_wtype_inv {A B} {u v : W A B} (pq : u = v)
: (w_label u;w_arg u) = (w_label v;w_arg v) :> {a : _ & B a -> W A B}
  := match pq with
       | 1 => match u with
                | sup _ _ => 1
              end
     end.

(** This lets us identify the path space of a W-type, up to equivalence. *)

Definition eisretr_path_wtype {A B} {z z' : W A B}
: Sect (@path_wtype_inv _ _ z z') (path_wtype z z')
  := fun p => match p as p in (_ = z') return
                    path_wtype z z' (path_wtype_inv p) = p
              with
                | 1 => match z as z return
                             path_wtype z z (path_wtype_inv 1) = 1
                       with
                         | sup _ _ => 1
                       end
              end.

Definition eissect_path_wtype {A B} {z z' : W A B}
: Sect (path_wtype z z') (@path_wtype_inv _ _ z z').
Proof.
  intro r; destruct z, z'; set (pq := (path_sigma_uncurried _ _ _)^-1 r).
  rewrite (eisretr _ _ : path_sigma_uncurried _ _ _ pq = r)^.
  destruct pq as [p q]; cbn in p; destruct p; cbn in q; destruct q.
  exact idpath.
Defined.

Global Instance isequiv_path_wtype {A B} {z z' : W A B}
: IsEquiv (path_wtype z z') | 0.
Proof.
  refine (isequiv_adjointify (path_wtype z z')
                       (@path_wtype_inv _ _ z z')
                       (@eisretr_path_wtype A B z z')
                       (@eissect_path_wtype A B z z')).
Defined.

Definition equiv_path_wtype {A B} (z z' : W A B)
  := Build_Equiv _ _ _ (@isequiv_path_wtype A B z z').

(** ** W-types preserve truncation *)

Global Instance trunc_wtype `{Funext} `{B : A -> Type}
         `{IsTrunc n.+1 A}
: IsTrunc n.+1 (W A B) | 100.
Proof.
  generalize dependent A; intros A B ac; intros z; induction z as [a w].
  intro y; destruct y as [a0 w0]; refine (trunc_equiv _ (equiv_path_wtype _ _)).
  apply (trunc_equiv' {p : a = a0 & forall b, w b = w0 (p # b)}).
  { transitivity {p : a = a0 & transport (fun a => B a -> W A B) p w = w0}.
    { apply equiv_functor_sigma_id; intro p; induction p.
      by apply equiv_path_forall. }
    by erapply (equiv_path_sigma _ (a;w) (a0;w0)). }
  apply (@trunc_sigma _ _ _ (ac a a0)); intro p; rapply @trunc_forall.
Defined.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo70 : goal 70. Time solve_P. Time Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (IHx:@eq natural (plus (mult x y) x) (mult x (Succ y))):@eq natural (Succ (plus (mult x y) (plus y x)))
  (plus (mult x (Succ y)) (Succ y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_mult_succ_78_plus_commut/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B0 C0 E Eprime B C Bprime : Universe, ((wd_ A B0 /\ (wd_ B0 C0 /\ (wd_ A C0 /\ (wd_ A B /\ (wd_ A Bprime /\ (wd_ B Bprime /\ (wd_ B C /\ (col_ A C0 C /\ (col_ A C0 Bprime /\ (col_ A B Bprime /\ (col_ A B0 B /\ col_ B0 E Eprime))))))))))) -> col_ A B0 C0)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 conj10synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj10synthconj4.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

(* Notation for proofs of the propositional Σ-type "∃x, P x", ie "ex P", for P : X → Prop *)

Notation "⟪ x , h ⟫ₚ" := (ex_intro _ x h) (at level 0, format "⟪ x ,  h ⟫ₚ").

(* Notations for terms of the Σ-type "{ x : X | P x }", ie "sig P", for P : X → Prop *)

Notation "⟪ x , h ⟫" := (exist _ x h) (at level 0, format "⟪ x ,  h ⟫").
Notation π₁ := proj1_sig.
Notation π₂ := proj2_sig.

Definition reify {X Y} {P : X → Y → Prop} : (∀ x, { y | P x y }) → { f : X → Y | ∀ x, P x (f x) } :=
  λ df, exist (λ f, ∀ x, P x (f x)) (λ x, π₁ (df x)) (λ x, π₂ (df x)).

Definition ex_monotonic {X: Set} {P Q : X → Prop} : (∀x, P x → Q x) → ex P → ex Q :=
  λ f xp, let (x, p) := xp in ex_intro _ x (f x p).

Definition sig_monotonic {X: Set} {P Q : X → Prop} : (∀x, P x → Q x) → sig P → sig Q :=
  λ f xp, let (x, p) := xp in exist _ x (f x p).

(* Functional composition is very convenient for chaining the strengthening of
   a precondition P, an algorithm of type ex P → sig Q and the weakening
   of its postcondition Q, in combination with ex_monotonic and sig_monotonic. *)

Definition comp {X Y Z : Type} (g : Y → Z) (f : X → Y) : X → Z := λ x, g (f x).
Notation "g '∘' f" := (comp g f) (at level 11, left associativity, format "g  ∘  f").


Require Import TM.Prelim.
Require Import TM.TM.
Require Import TM.Basic.Basic.
Require Import TM.Combinators.Combinators.
Require Import TM.Lifting.Lifting.

Require Import TM.Compound.TMTac.

(** * Simple compound multi-tape Machines *)

(** ** Nop *)

(** The n-tape Machine that does nothing *)
Section Nop.
  Variable sig : finType.
  Variable n : nat.

  Definition Nop : pTM sig unit n := LiftTapes Null (Vector.nil _).

  Definition Nop_Rel : pRel sig unit n :=
    ignoreParam (fun t t' => t' = t).

  Lemma Nop_Sem : Nop ⊨c(0) Nop_Rel.
  Proof.
    eapply RealiseIn_monotone.
    { unfold Nop. TM_Correct. }
    { reflexivity. }
    {
      intros tin ((), tout) (_&HInj). cbn in *.
      apply Vector.eq_nth_iff; intros i ? <-. apply HInj. vector_not_in.
    }
  Qed.
End Nop.

Arguments Nop_Rel {sig n} x y/.
Arguments Nop {sig n}.
Arguments Nop : simpl never.

(** ** Diverge *)

Section Diverge.
  Variable sig : finType.
  Variable n : nat.

  Definition Diverge : pTM sig unit n := While (Return Nop None).

  Definition Diverge_Rel : pRel sig unit n :=
    ignoreParam (fun t t' => False).

  Lemma Diverge_Realise : Diverge ⊨ Diverge_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Diverge. TM_Correct. eapply RealiseIn_Realise. apply Nop_Sem. }
    { eapply WhileInduction; intros; cbn in *; TMSimp; auto. }
  Qed.

End Diverge.

Arguments Diverge_Rel {sig n} x y/.
Arguments Diverge {sig n}.
Arguments Diverge : simpl never.

(** ** Move two tapes *)

Section MovePar.
  Variable sig : finType.
  Variable (D1 D2 : move).

  Definition MovePar_R : pRel sig unit 2 :=
    ignoreParam(fun (t t' : tapes sig 2) =>
                  t'[@Fin0] = tape_move t[@Fin0] D1 /\
                  t'[@Fin1] = tape_move t[@Fin1] D2).

  Definition MovePar : pTM sig unit 2 :=
    LiftTapes (Move D1) [|Fin0|];; LiftTapes (Move D2) [|Fin1|].

  Lemma MovePar_Sem : MovePar ⊨c(3) MovePar_R.
  Proof.
    eapply RealiseIn_monotone.
    { unfold MovePar. TM_Correct. }
    { reflexivity. }
    { hnf in *. intros tin (yout&tout) H. now TMSimp. }
  Qed.

End MovePar.

Arguments MovePar_R { sig } ( D1 D2 ) x y /.
Arguments MovePar {sig} (D1 D2).
Arguments MovePar : simpl never.

(** ** Copy Symbol *)

(** Copy the current symbol from tape 0 to tape 1 *)
Section Copy.
  Variable sig : finType.

  Variable f : sig -> sig.

  Definition CopyChar : pTM sig unit 2 :=
    Switch (LiftTapes ReadChar [|Fin0|])
          (fun s : option sig =>
             match s with
             | None =>  Nop
             | Some s => LiftTapes (Write (f s)) [|Fin1|]
             end).

  Definition CopyChar_Rel : pRel sig unit 2 :=
    ignoreParam (
        fun tin tout =>
          tout[@Fin0] = tin[@Fin0] /\
          tout[@Fin1] = tape_write tin[@Fin1] (map_opt f (current tin[@Fin0]))
      ).

  Lemma CopyChar_Sem : CopyChar ⊨c(3) CopyChar_Rel.
  Proof.
    eapply RealiseIn_monotone.
    {
      unfold CopyChar. eapply Switch_RealiseIn; cbn.
      - apply LiftTapes_RealiseIn. vector_dupfree. apply ReadChar_Sem.
      - instantiate (2 := fun o : option sig => match o with Some s => _ | None => _ end).
        intros [ s | ]; cbn.
        + eapply LiftTapes_RealiseIn. vector_dupfree. apply Write_Sem.
        + eapply RealiseIn_monotone'. apply Nop_Sem. omega.
    }
    { omega. }
    {
      intros tin ((), tout) H. cbn in *. TMSimp.
      destruct (current tin[@Fin0]) eqn:E; TMSimp; auto.
    }
  Qed.

End Copy.

Arguments CopyChar_Rel { sig } ( f ) x y /.
Arguments CopyChar { sig }.
Arguments CopyChar : simpl never.

(** ** Read Char *)

(** Read a char at an arbitrary tape *)
Section ReadChar.

  Variable sig : finType.
  Variable (n : nat) (k : Fin.t n).

  Definition ReadChar_at : pTM sig (option sig) n :=
    LiftTapes ReadChar [|k|].

  Definition ReadChar_at_Rel : pRel sig (option sig) n :=
    fun tin '(yout, tout) =>
      yout = current tin[@k] /\
      tout = tin.

  Lemma ReadChar_at_Sem :
    ReadChar_at ⊨c(1) ReadChar_at_Rel.
  Proof.
    eapply RealiseIn_monotone.
    { unfold ReadChar_at. TM_Correct. }
    { cbn. reflexivity. }
    {
      intros tin (yout, tout) H.
      hnf. TMSimp; clear_trivial_eqs. split; auto.
      eapply VectorSpec.eq_nth_iff; intros p ? <-.
      decide (p = k) as [->|HnEq]; TMSimp; auto.
      - apply H0. vector_not_in.
    }
  Qed.

End ReadChar.

Arguments ReadChar_at : simpl never.
Arguments ReadChar_at {sig n} k.
Arguments ReadChar_at_Rel { sig n } ( k ) x y /.

(** ** Tactic Support *)

Ltac smpl_TM_Multi :=
  lazymatch goal with
  | [ |- Nop ⊨ _ ] => eapply RealiseIn_Realise; apply Nop_Sem
  | [ |- Nop ⊨c(_) _ ] => eapply Nop_Sem
  | [ |- projT1 (Nop) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Nop_Sem

  | [ |- Diverge ⊨ _ ] => apply Diverge_Realise

  | [ |- MovePar _ _ ⊨ _ ] => eapply RealiseIn_Realise; eapply MovePar_Sem
  | [ |- MovePar _ _ ⊨c(_) _ ] => eapply MovePar_Sem
  | [ |- projT1 (MovePar _ _) ↓ _ ] => eapply RealiseIn_TerminatesIn; eapply MovePar_Sem

  | [ |- CopyChar _ ⊨ _ ] => eapply RealiseIn_Realise; eapply CopyChar_Sem
  | [ |- CopyChar _ ⊨c(_) _ ] => eapply CopyChar_Sem
  | [ |- projT1 (CopyChar _) ↓ _ ] => eapply RealiseIn_TerminatesIn; eapply CopyChar_Sem

  | [ |- ReadChar_at _ ⊨ _ ] => eapply RealiseIn_Realise; eapply ReadChar_at_Sem
  | [ |- ReadChar_at _ ⊨c(_) _ ] => eapply ReadChar_at_Sem
  | [ |- projT1 (ReadChar_at _) ↓ _ ] => eapply RealiseIn_TerminatesIn; eapply ReadChar_at_Sem
  end.

Smpl Add smpl_TM_Multi : TM_Correct.


Require Export Iron.Language.SystemF2Store.ExpBase.

(* Get the data constructor of an alternative. *)
Fixpoint dcOfAlt (aa: alt) : datacon :=
 match aa with
 | AAlt dc _ => dc
 end.
Hint Unfold dcOfAlt.

(* Get the alternative body that matches a given constructor. *)
Fixpoint getAlt (dc: datacon) (alts: list alt) {struct alts}
                : option alt :=
 match alts with
 |  nil  => None

 |  AAlt dc' x :: alts'
 => if datacon_beq dc dc'
     then Some (AAlt dc' x)
     else getAlt dc alts'
 end.

(* If we get a single alternative from a list,
   then that alternative was in the list. *)
Lemma getAlt_in
 :  forall dc alt alts
 ,  getAlt dc alts = Some alt
 -> In alt alts.
Proof.
 intros.
 induction alts.
  false.
  destruct a as [dc' tsArgs x].
  simpl in H.
  breaka (datacon_beq dc dc').
   inverts H.
    apply datacon_beq_eq in HeqX; auto.
Qed.
Hint Resolve getAlt_in.

(* Given a data constructor, if one of the alternatives in a
   list matches that data constructor then we can get the other
   information about the alternative from the list. *)
Lemma getAlt_exists
 :  forall d alts
 ,  In d (map dcOfAlt alts)
 -> (exists x, getAlt d alts = Some (AAlt d x)).
Proof.
 intros.
 induction alts.
  simpl in H. false.
  simpl in H. inverts H.
   destruct a. simpl.
   breaka (datacon_beq d d).
    exists e. auto.
    apply datacon_beq_false in HeqX. false.
   lets D: IHalts H0.
   destruct a. simpl.
    breaka (datacon_beq d d0).
     apply datacon_beq_eq in HeqX. subst. auto.
     exists e. auto.
Qed.
Hint Resolve getAlt_exists.


Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Lambda.ExprCore.
Require Import ExtLib.Core.RelDec.
Require Import MirrorCore.TypesI.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.Fun.
(*Require Import progs.list_dt.*)
Require Import floyd_funcs.
Require Import mc_reify.types.
Require Import mc_reify.bool_funcs.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import floyd.local2ptree.
Require Import mc_reify.local2list.

Inductive const :=
| fN : nat -> const
| fZ : Z -> const
| fint : int -> const
| fint64 : int64 -> const
| fPos : positive -> const
| fident : ident -> const
| fCtype : type -> const
| fCexpr : expr -> const
| fComparison : comparison -> const
| fbool : bool -> const
| ffloat : float -> const
| ffloat32 : float32 -> const
| fenv : type_id_env -> const
| fllrr : LLRR -> const
.

Definition typeof_const (c : const) : typ :=
 match c with
| fN _ => tynat
| fZ _ => tyZ
| fPos _ => typositive
| fident _ => tyident
| fCtype _ => tyc_type
| fCexpr _ => tyc_expr
| fComparison _ => tycomparison
| fbool _ => tybool
| fint _ => tyint
| fint64 _ => tyint64
| ffloat _ => tyfloat
| ffloat32 _ => tyfloat32
| fenv _ => tytype_id_env
| fllrr _ => tyllrr
end.

Definition constD (c : const)
: typD (typeof_const c) :=
match c with
| fN c | fZ c | fPos c | fident c | fCtype c | fCexpr c | fComparison c | fbool c | fint c
| fint64 c | ffloat c | ffloat32 c | fenv c | fllrr c
                                          => c
end.

(*
Instance RelDec_type_eq : RelDec (@eq type) :=
{ rel_dec := eqb_type }.

Instance RelDec_const_eq : RelDec (@eq const) :=
{ rel_dec := fun (a b : const) =>
               match a , b with
| N c1,  N c2 | Z c1,  Z c2 | Pos c1,  Pos c2 | Ctype c1,  Ctype c2
| Cexpr c1,  Cexpr c2 | Comparison c1,  Comparison c2 => c1 ?[ eq ] c2
| _, _ => false
end}.*)

Inductive z_op :=
| fZ_lt
| fZ_le
| fZ_gt
| fZ_ge
| fZ_add
| fZ_sub
| fZ_mul
| fZ_div
| fZ_mod
| fZ_land
| fZ_max
| fZ_opp.

Definition typeof_z_op z : typ :=
match z with
| fZ_lt
| fZ_le
| fZ_gt
| fZ_ge => (tyArr tyZ (tyArr tyZ typrop))
| fZ_add
| fZ_sub
| fZ_mul
| fZ_div
| fZ_mod
| fZ_land
| fZ_max => (tyArr tyZ (tyArr tyZ tyZ))
| fZ_opp => (tyArr tyZ tyZ)
end.

Definition z_opD (z : z_op) : typD  (typeof_z_op z) :=
match z with
| fZ_lt => Z.lt
| fZ_le => Z.le
| fZ_gt => Z.gt
| fZ_ge => Z.ge
| fZ_add => Z.add
| fZ_sub => Z.sub
| fZ_mul => Z.mul
| fZ_div => Z.div
| fZ_mod => Zmod
| fZ_land => Z.land
| fZ_max => Z.max
| fZ_opp => Z.opp
end.

(*Instance RelDec_func_eq : RelDec (@eq func) :=
{ rel_dec := fun (a b : func) =>
               match a , b with
                 | Plus , Plus => true*)

Inductive int_op :=
| fint_add
| fint_and
| fint_lt
| fint_ltu
| fint_mul
| fint_neg
| fint_sub
| fint_cmp
| fint_cmpu
| fint_repr
| fint_signed
| fint_unsigned
| fint_max_unsigned
| fint64_repr.

Definition typeof_int_op i : typ :=
match i with
| fint_lt
| fint_ltu => tyArr tyint (tyArr tyint tybool)
| fint_mul
| fint_sub
| fint_add => tyArr tyint (tyArr tyint tyint)
| fint_and => tyArr tyint (tyArr tyint tyint)
| fint_neg => tyArr tyint tyint
| fint_cmp
| fint_cmpu => tyArr tycomparison (tyArr tyint (tyArr tyint tybool))
| fint_repr => tyArr tyZ tyint
| fint_signed
| fint_unsigned  => tyArr tyint tyZ
| fint_max_unsigned => tyZ
| fint64_repr => tyArr tyZ tyint64
end.

Definition int_opD (i : int_op): typD  (typeof_int_op i) :=
match i with
| fint_add => Int.add
| fint_and => Int.and
| fint_lt => Int.lt
| fint_ltu => Int.ltu
| fint_mul => Int.mul
| fint_neg => Int.neg
| fint_sub => Int.sub
| fint_cmp => Int.cmp
| fint_cmpu => Int.cmpu
| fint_repr => Int.repr
| fint_signed => Int.signed
| fint_unsigned => Int.unsigned
| fint_max_unsigned => Int.max_unsigned
| fint64_repr => Int64.repr
end.

Inductive values :=
| fVint
| fVfloat
| fVlong
| fVptr
| fVundef
| fVsingle.

Definition typeof_value (v : values) :=
match v with
| fVint => tyArr tyint tyval
| fVfloat => tyArr tyfloat tyval
| fVlong => tyArr tyint64 tyval
| fVptr => tyArr typositive (tyArr tyint tyval)
| fVsingle => tyArr tyfloat32 tyval
| fVundef => tyval
end.

Definition valueD  (v : values): typD  (typeof_value v) :=
match v with
| fVint => Vint
| fVfloat => Vfloat
| fVlong => Vlong
| fVptr => Vptr
| fVsingle => Vsingle
| fVundef => Vundef
end.

Inductive eval :=
| feval_cast : type -> type -> eval
| fderef_noload : type -> eval
| feval_field : type -> ident -> eval
| feval_binop : binary_operation -> type -> type -> eval
| feval_unop : unary_operation -> type -> eval
| feval_id : ident -> eval.

Definition typeof_eval (e : eval) :=
 match e with
| feval_cast _ _ => (tyArr tyval tyval)
| fderef_noload _ => (tyArr tyval tyval)
| feval_field _ _ => (tyArr tyval tyval)
| feval_binop _ _ _=> (tyArr tyval (tyArr tyval tyval))
| feval_unop _ _ => (tyArr tyval tyval)
| feval_id _  => (tyArr tyenviron tyval)
end.

Definition evalD  (e : eval) : typD  (typeof_eval e) :=
match e with
| feval_id id => eval_id id
| feval_cast t1 t2 => eval_cast t1 t2
| fderef_noload t => deref_noload t
| feval_field t id => eval_field t id
| feval_binop op t1 t2 => eval_binop op t1 t2
| feval_unop op t => eval_unop op t
end.

(*TODO: classify these better*)
Inductive other :=
| ftwo_power_nat
| fforce_ptr
| fand
| falign
| ftyped_true
| feq : typ -> other
| fnone : typ -> other
| fsome : typ -> other
| ftypeof
| fTrue
| fFalse
.

Definition typeof_other (o : other) :=
match o with
| ftwo_power_nat => tyArr tynat tyZ
| fforce_ptr  => tyArr tyval tyval
| fand => tyArr typrop (tyArr typrop typrop)
| falign => tyArr tyZ (tyArr tyZ tyZ)
| ftyped_true => tyArr tyc_type (tyArr tyval typrop)
| feq t => tyArr t (tyArr t typrop)
| fnone t => tyoption t
| fsome t => tyArr t (tyoption t)
| ftypeof => tyArr tyc_expr tyc_type
| fTrue | fFalse => typrop
end.

Definition otherD  (o : other) : typD  (typeof_other o) :=
match o with
| ftwo_power_nat => (two_power_nat : typD (typeof_other ftwo_power_nat))
| fforce_ptr => force_ptr
| fand => and
| falign => align
| ftyped_true => typed_true
| feq t => @eq (typD t)
| fsome t => @Some (typD t)
| fnone t => @None (typD t)
| ftypeof => typeof
| fTrue => True
| fFalse => False
end.

Inductive data :=
| fnil : typ -> data
| fmap : typ -> typ -> data
| ffold_right : typ -> typ -> data
| ffold_left : typ -> typ -> data
| fcons : typ -> data
| fappend : typ -> data
| fnth_error : typ -> nat -> data
| freplace_nth : typ -> nat -> data
| fpair : typ -> typ -> data
| fget : typ -> positive -> data
| fset : typ -> positive -> data
| fleaf : typ -> data
| fnode : typ -> data
| fempty : typ -> data
.

Definition typeof_data (l : data) :=
match l with
| fmap a b => tyArr (tyArr a b) (tyArr (tylist a) (tylist b))
| fnil a => (tylist a)
| ffold_right a b => tyArr (tyArr b (tyArr a a)) (tyArr a (tyArr (tylist b) a))
| ffold_left a b => tyArr (tyArr a (tyArr b a)) (tyArr (tylist b) (tyArr a a))
| fcons a => tyArr a (tyArr (tylist a) (tylist a))
| fappend a => tyArr (tylist a) (tyArr (tylist a) (tylist a))
| fnth_error a _ => tyArr (tylist a) (tyoption a)
| freplace_nth a _ => tyArr (tylist a) (tyArr a (tylist a))
| fpair t1 t2 => tyArr t1 (tyArr t2 (typrod t1 t2))
| fleaf t => typtree t
| fnode t => tyArr (typtree t) (tyArr (tyoption t) (tyArr (typtree t) (typtree t)))
| fset t _ => tyArr t (tyArr (typtree t) (typtree t))
| fget t _ => (tyArr (typtree t) (tyoption t))
| fempty t => typtree t
end.

Definition dataD (l : data) : typD (typeof_data l) :=
match l with
| fmap t1 t2 => @map (typD  t1) (typD  t2)
| fnil t => (@nil (typD t) : typD (typeof_data (fnil t)))
| ffold_right a b => @fold_right (typD a) (typD b)
| ffold_left a b => @fold_left (typD a) (typD b)
| fcons a => @cons (typD a)
| fappend a => @app (typD a)
| fnth_error a n => fun l => @nth_error (typD a) l n
| freplace_nth a n => @canon.replace_nth (typD a) n
| fpair a b => ((@pair (typD a) (typD b)) : typD (typeof_data (fpair a b)))
| fleaf t => @PTree.Leaf (typD t)
| fnode t => @PTree.Node (typD t)
| fset t p => @PTree.set (typD t) p
| fget t p => @PTree.get (typD t) p
| fempty t => @PTree.empty (typD t)
end.

Inductive sep :=
| flocal
| fprop
| fdata_at : type -> sep
| ffield_at : type -> list gfield -> sep
| fproj_val : type -> sep
| fupd_val : type -> sep
(*| flseg : forall (t: type) (i : ident), listspec t i -> sep*)
.

Fixpoint reptyp (ty: type) : typ :=
  match ty with
  | Tvoid => tyunit
  | Tint _ _ _ => tyval
  | Tlong _ _ => tyval
  | Tfloat _ _ => tyval
  | Tpointer t1 a => tyval
  | Tarray t1 sz a => tylist (reptyp t1)
  | Tfunction t1 t2 _ => tyunit
  | Tstruct id fld a => reptyp_structlist fld
  | Tunion id fld a => reptyp_unionlist fld
  | Tcomp_ptr id a => tyval
  end
with reptyp_structlist (fld: fieldlist) : typ :=
  match fld with
  | Fnil => tyunit
  | Fcons id ty fld' =>
    if is_Fnil fld'
      then reptyp ty
      else typrod (reptyp ty) (reptyp_structlist fld')
  end
with reptyp_unionlist (fld: fieldlist) : typ :=
  match fld with
  | Fnil => tyunit
  | Fcons id ty fld' =>
    if is_Fnil fld'
      then reptyp ty
      else tysum (reptyp ty) (reptyp_unionlist fld')
  end.

Definition typeof_sep (s : sep) : typ :=
match s with
| fdata_at t => tyArr tyshare (tyArr (reptyp t) (tyArr tyval tympred))
| ffield_at t gfs => tyArr tyshare (tyArr (reptyp (nested_field_type2 t gfs)) (tyArr tyval tympred))
(*| flseg t i l => tyArr tyshare (tyArr (tylist (reptyp_structlist (@all_but_link i (list_fields))))
                                      (tyArr tyval (tyArr tyval tympred)))*)
| flocal => tyArr (tyArr tyenviron typrop) (tyArr tyenviron tympred)
| fprop => tyArr typrop tympred
| fproj_val t => tyArr (tylist tygfield)
                 (tyArr (reptyp t) tyval)
| fupd_val t => tyArr (tylist tygfield)
                 (tyArr (reptyp t)
                  (tyArr tyval (reptyp t)))
end.

Definition proj1T {A} {B} (x: A /\ B) :=
  match x with
  | conj y z => y
  end.

Definition proj2T {A} {B} (x: A /\ B) :=
  match x with
  | conj y z => z
  end.

Definition typD_reptyp_reptype: forall t, typD  (reptyp t) = reptype t.
Proof.
  intros.
  apply (type_mut (fun t => typD (reptyp t) = reptype t)
                  (fun tl => True)
                  (fun fld => typD (reptyp_structlist fld) = reptype_structlist fld /\
                              typD (reptyp_unionlist fld) = reptype_unionlist fld));
  try reflexivity; intros.
  + simpl.
    rewrite H.
    reflexivity.
  + simpl.
    apply (proj1T H).
  + simpl.
    apply (proj2T H).
  + split; reflexivity.
  + split; simpl.
    - destruct (is_Fnil f); simpl; rewrite H; try rewrite (proj1T H0); reflexivity.
    - destruct (is_Fnil f); simpl; rewrite H; try rewrite (proj2T H0); reflexivity.
Defined.

Definition reptyp_reptype ty (v: typD  (reptyp ty)): reptype ty :=
  eq_rect_r (fun x => x) v (eq_sym (typD_reptyp_reptype ty)).

Definition reptype_reptyp ty (v: reptype ty): typD  (reptyp ty) :=
  eq_rect_r (fun x => x) v (typD_reptyp_reptype ty).

Lemma reptyp_reptype_reptype_reptyp: forall t v, reptyp_reptype t (reptype_reptyp t v) = v.
Proof.
  intros.
  unfold reptyp_reptype, reptype_reptyp.
  unfold eq_rect_r.
  generalize (typD_reptyp_reptype t).
  revert v.
  rewrite (typD_reptyp_reptype t).
  intros.
  rewrite <- !eq_rect_eq.
  reflexivity.
Qed.

(*
Fixpoint reptyp_reptype  ty {struct ty} : typD  (reptyp ty) -> reptype ty :=
  match ty as ty0 return (typD  (reptyp ty0) -> reptype ty0) with
    | Tvoid => fun x : unit => x
    | Tint i s a => fun x : val => x
    | Tlong s a => fun x : val => x
    | Tfloat f a => fun x : val => x
    | Tpointer t a => fun x : val => x
    | Tarray t z a => map (reptyp_reptype  t)
    | Tfunction t t0 c => fun x : unit => x
    | Tstruct i f a => reptyp_structlist_reptype  f
    | Tunion i f a => reptyp_unionlist_reptype  f
    | Tcomp_ptr i a => fun x : val => x
  end
with reptyp_structlist_reptype  fl {struct fl} : typD  (reptyp_structlist fl) -> reptype_structlist fl :=
  match
    fl as fl0
    return (typD  (reptyp_structlist fl0) -> reptype_structlist fl0)
  with
    | Fnil => fun x : typD  (reptyp_structlist Fnil) => x
    | Fcons i t fl0 =>
      let b := is_Fnil fl0 in
      if b as b0
         return
         (typD
               (if b0
                then reptyp t
                else typrod (reptyp t) (reptyp_structlist fl0)) ->
          if b0
          then reptype t
          else (reptype t * reptype_structlist fl0)%type)
      then reptyp_reptype  t
      else
        fun x : typD  (reptyp t) * typD  (reptyp_structlist fl0) =>
          (reptyp_reptype  t (fst x),
           reptyp_structlist_reptype  fl0 (snd x))
  end
with reptyp_unionlist_reptype  fl {struct fl} : typD  (reptyp_unionlist fl) -> reptype_unionlist fl :=
match
     fl as fl0
     return (typD  (reptyp_unionlist fl0) -> reptype_unionlist fl0)
   with
   | Fnil => fun x : typD  (reptyp_unionlist Fnil) => x
   | Fcons i t fl0 =>
       let b := is_Fnil fl0 in
       if b as b0
        return
          (typD
             (if b0
              then reptyp t
              else tysum (reptyp t) (reptyp_unionlist fl0)) ->
           if b0 then reptype t else (reptype t + reptype_unionlist fl0)%type)
       then reptyp_reptype  t
       else
        fun x : typD  (reptyp t) + typD  (reptyp_unionlist fl0) =>
        match x with
        | inl y => inl (reptyp_reptype  t y)
        | inr y => inr (reptyp_unionlist_reptype  fl0 y)
        end
   end.

Fixpoint reptype_reptyp ty {struct ty} : reptype ty -> typD (reptyp ty) :=
  match ty as ty0 return (reptype ty0 -> typD  (reptyp ty0)) with
    | Tvoid => fun x : unit => x
    | Tint i s a => fun x : val => x
    | Tlong s a => fun x : val => x
    | Tfloat f a => fun x : val => x
    | Tpointer t a => fun x : val => x
    | Tarray t z a => map (reptype_reptyp  t)
    | Tfunction t t0 c => fun x : unit => x
    | Tstruct i f a => reptype_structlist_reptyp  f
    | Tunion i f a => reptype_unionlist_reptyp  f
    | Tcomp_ptr i a => fun x : val => x
  end
with reptype_structlist_reptyp fl {struct fl} : reptype_structlist fl -> typD (reptyp_structlist fl) :=
  match
    fl as fl0
    return (reptype_structlist fl0 -> typD  (reptyp_structlist fl0))
  with
    | Fnil => fun x : reptype_structlist Fnil => x
    | Fcons i t fl0 =>
      let b := is_Fnil fl0 in
      if b as b0
         return
         ((if b0
          then reptype t
          else (reptype t * reptype_structlist fl0)%type) ->
          typD
               (if b0
                then reptyp t
                else typrod (reptyp t) (reptyp_structlist fl0)))
      then reptype_reptyp t
      else
        fun x : (reptype t * reptype_structlist fl0)%type =>
          (reptype_reptyp t (fst x),
           reptype_structlist_reptyp fl0 (snd x))
  end
with reptype_unionlist_reptyp  fl {struct fl} : reptype_unionlist fl -> typD  (reptyp_unionlist fl) :=
match
     fl as fl0
     return (reptype_unionlist fl0 -> typD  (reptyp_unionlist fl0))
   with
   | Fnil => fun x : reptype_unionlist Fnil => x
   | Fcons i t fl0 =>
       let b := is_Fnil fl0 in
       if b as b0
        return
          ((if b0 then reptype t else (reptype t + reptype_unionlist fl0)%type) ->
           typD
             (if b0
              then reptyp t
              else tysum (reptyp t) (reptyp_unionlist fl0)))
       then reptype_reptyp t
       else
        fun x : (reptype t + reptype_unionlist fl0)%type =>
        match x with
        | inl y => inl (reptype_reptyp t y)
        | inr y => inr (reptype_unionlist_reptyp fl0 y)
        end
   end.

Lemma reptyp_reptype_reptype_reptyp: forall t v, reptyp_reptype t (reptype_reptyp t v) = v.
Proof.
  intros.
  eapply (type_mut
    (fun t => forall v, reptyp_reptype t (reptype_reptyp t v) = v)
    (fun tl => True)
    (fun fld => (forall v, reptyp_structlist_reptype fld (reptype_structlist_reptyp fld v) = v) /\
                (forall v, reptyp_unionlist_reptype fld (reptype_unionlist_reptyp fld v) = v)));
  intros; simpl; auto.
  + rewrite map_map.
    induction v0; simpl; auto.
    rewrite H, IHv0.
    reflexivity.
  + apply (proj1 H).
  + apply (proj2 H).
  + split.
    - if_tac; [apply H |].
      intros.
      unfold fst, snd.
      rewrite H, (proj1 H0).
      destruct v0; reflexivity.
    - if_tac; [apply H |].
      intros.
      destruct v0; [rewrite H; auto |].
      rewrite (proj2 H0).
      reflexivity.
Qed.
*)
Definition sepD  (s : sep) : typD  (typeof_sep s).
refine
match s with
| flocal => (local : typD (typeof_sep flocal))
| fprop => prop
| fdata_at ty =>  _ (*fun sh (t : reptype ty) v => data_at sh ty t v *)
| ffield_at t ids => _
| fproj_val ty => _
| fupd_val ty => _
(*| flseg t id ls => _*)
end.
{ simpl. intros sh rt v.
  exact (data_at sh ty (reptyp_reptype  _ rt) v). }
{ simpl. intros sh ty v.
  exact (field_at sh t ids (reptyp_reptype  _ ty) v). }
{ simpl. intros gfs v.
  exact (proj_val ty gfs (reptyp_reptype  _ v)). }
{ simpl. intros gfs v v0.
  exact (reptype_reptyp _ (upd_val ty gfs (reptyp_reptype _ v) v0)). }
(*{ simpl.
  intros sh lf v1 v2.
  exact (@lseg t id ls sh (List.map (reptyp_structlist_reptype  _) lf) v1 v2). }*)
Defined.

Inductive smx :=
| fenviron : environ -> smx
| fsemax
| fstatement : statement -> smx
| fretassert : ret_assert -> smx
| ftycontext : PTree.t (type * bool) -> PTree.t type -> type -> PTree.t type ->  smx
| fupdate_tycon
(*| fPROPx
| fLOCALx
| fSEPx *)
| fnormal_ret_assert
(*| flocalD : PTree.t val -> PTree.t (type * val) -> list (environ -> Prop) -> smx *)
| fassertD
| flocalD
| fvaltree : PTree.t val -> smx
| fdenote_tc_assert_b_norho
| ftc_expr_b_norho
| ftc_temp_id_b_norho : positive -> type ->  smx
(*| fmsubst_eval_expr_norho*)
(*| fmsubst_eval_lvalue_norho*)
| flater
| flater_lift
| fnested_field_type2
| fis_neutral_cast
| fmsubst_efield_denote : list efield -> smx
| flegal_nested_efield : list type -> smx
| fmsubst_eval_LR
| ftc_LR_b_norho
| ftc_environ
| ftc_efield_b_norho : list efield -> smx
| fnested_efield
| ftypeof_temp
| ftc_val
| flegal_nested_field
| fstruct_field
| funion_field
| farray_subsc
| fwritable_share
| fTsh
| fEws
| ftype_is_by_value
.

Definition typeof_smx (t : smx) :=
match t with
| fsemax => tyArr tyOracleKind (tyArr tytycontext (tyArr (tyArr tyenviron tympred) (tyArr tystatement (tyArr tyret_assert typrop))))
| fstatement s => tystatement
| fretassert r => tyret_assert
| ftycontext _ _ _ _ => tyArr (typtree tyfunspec) tytycontext
(*| fPROPx => tyArr (tylist typrop) (tyArr (tyArr tyenviron tympred) (tyArr tyenviron tympred))
| fLOCALx => tyArr (tylist (tyArr tyenviron typrop)) (tyArr (tyArr tyenviron tympred) (tyArr tyenviron tympred))
| fSEPx => tyArr (tylist (tyArr tyenviron tympred)) (tyArr tyenviron tympred)*)
| fnormal_ret_assert => tyArr (tyArr tyenviron tympred) (tyret_assert)
| fenviron e => tyenviron
| flocalD  => tyArr (typtree tyval)
                    (tyArr (typtree (typrod tyc_type tyval)) (tylist (tyArr tyenviron typrop)))
| fupdate_tycon => tyArr tytycontext (tyArr tystatement tytycontext)
| fvaltree t => typtree tyval
| fassertD => tyArr  (tylist typrop) (tyArr (tylist (tyArr tyenviron typrop)) (tyArr (tylist tympred) (tyArr tyenviron tympred)))
| fdenote_tc_assert_b_norho => tyArr tytc_assert tybool
| ftc_expr_b_norho => tyArr tytycontext (tyArr tyc_expr tybool)
| ftc_temp_id_b_norho _ _  => tyArr tytycontext (tyArr tyc_expr tybool)
(*| fmsubst_eval_expr_norho => tyArr (typtree tyval) (tyArr (typtree (typrod tyc_type tyval)) (tyArr tyc_expr (tyoption tyval)))*)
(*| fmsubst_eval_lvalue_norho =>  tyArr (typtree tyval) (tyArr (typtree (typrod tyc_type tyval)) (tyArr tyc_expr (tyoption tyval)))*)
| flater => tyArr tympred tympred
| flater_lift => tyArr (tyArr tyenviron tympred) (tyArr tyenviron tympred)
| fnested_field_type2 => tyArr tyc_type (tyArr (tylist tygfield) tyc_type)
| fis_neutral_cast => tyArr tyc_type (tyArr tyc_type tybool)
| fmsubst_efield_denote _ => tyArr (typtree tyval)
                           (tyArr (typtree (typrod tyc_type tyval))
                                 (tyoption (tylist tygfield)))
| flegal_nested_efield _ => tyArr tytype_id_env
                          (tyArr tyc_type
                           (tyArr tyc_expr
                            (tyArr (tylist tygfield)
                              (tyArr tyllrr tybool))))
| fmsubst_eval_LR => tyArr (typtree tyval)
                     (tyArr (typtree (typrod tyc_type tyval))
                      (tyArr tyc_expr
                       (tyArr tyllrr (tyoption tyval))))
| ftc_LR_b_norho => tyArr tytycontext (tyArr tyc_expr (tyArr tyllrr tybool))
| ftc_environ => tyArr tytycontext (tyArr tyenviron typrop)
| ftc_efield_b_norho efs => tyArr tytycontext tybool
| fnested_efield => tyArr tyc_expr
                    (tyArr (tylist tyefield)
                     (tyArr (tylist tyc_type) tyc_expr))
| ftypeof_temp => tyArr tytycontext (tyArr tyident (tyoption tyc_type))
| ftc_val => tyArr tyc_type (tyArr tyval typrop)
| flegal_nested_field => tyArr tyc_type (tyArr (tylist tygfield) typrop)
| fstruct_field => tyArr tyident tygfield
| funion_field => tyArr tyident tygfield
| farray_subsc => tyArr tyZ tygfield
| fwritable_share => tyArr tyshare typrop
| fTsh => tyshare
| fEws => tyshare
| ftype_is_by_value => tyArr tyc_type tybool
end.

Definition smxD (t : smx) : typD (typeof_smx t) :=
match t with
| fsemax => (@semax : typD (typeof_smx fsemax))
| fstatement s | fretassert s  => s
| ftycontext t v r gt => fun gf => mk_tycontext t v r gt gf
(*| fPROPx => PROPx
| fLOCALx => LOCALx
| fSEPx => SEPx*)
| fnormal_ret_assert => normal_ret_assert
| fenviron e => (e : typD (typeof_smx (fenviron e)))
| flocalD => localD
| fupdate_tycon => update_tycon
| fvaltree t => t
| fassertD => assertD
| fdenote_tc_assert_b_norho => (denote_tc_assert_b_norho : typD (typeof_smx fdenote_tc_assert_b_norho))
| ftc_expr_b_norho => tc_expr_b_norho
| ftc_temp_id_b_norho id ty  => tc_temp_id_b_norho id ty
(*| fmsubst_eval_expr_norho => msubst_eval_expr*)
(*| fmsubst_eval_lvalue_norho => msubst_eval_lvalue*)
| flater => later
| flater_lift => later
| fnested_field_type2 => nested_field_type2
| fis_neutral_cast => is_neutral_cast
| fmsubst_efield_denote efs => (fun T1 T2 => msubst_efield_denote T1 T2 efs)
| flegal_nested_efield tts => (fun e t_root e1 gfs => legal_nested_efield e t_root e1 gfs tts)
| fmsubst_eval_LR => msubst_eval_LR
| ftc_LR_b_norho => tc_LR_b_norho
| ftc_environ => tc_environ
| ftc_efield_b_norho efs => (fun tycon => tc_efield_b_norho tycon efs)
| fnested_efield => nested_efield
| ftypeof_temp => typeof_temp
| ftc_val => tc_val
| flegal_nested_field => legal_nested_field
| fstruct_field => StructField
| funion_field => UnionField
| farray_subsc => ArraySubsc
| fwritable_share => writable_share
| fTsh => SeparationLogic.Tsh
| fEws => assert_lemmas.Ews
| ftype_is_by_value => client_lemmas.type_is_by_value
end.

Inductive func' :=
| Const : const -> func'
| Zop : z_op -> func'
| Intop : int_op -> func'
| Value : values -> func'
| Eval_f : eval -> func'
| Other : other -> func'
| Sep : sep -> func'
| Data : data -> func'
| Smx : smx -> func'.

Definition func := (SymEnv.func + @ilfunc typ + @bilfunc typ + func')%type.

Definition typeof_func (f: func') : typ :=
match f with
| Const c => typeof_const c
| Zop z => typeof_z_op z
| Intop i => typeof_int_op i
| Value v => typeof_value v
| Eval_f e => typeof_eval e
| Other o => typeof_other o
| Sep s => typeof_sep s
| Data l => typeof_data l
| Smx t => typeof_smx t
end.

Definition funcD  (f : func') : typD  (typeof_func f) :=
match f with
| Const c => constD  c
| Zop z => z_opD  z
| Intop i => int_opD  i
| Value v => valueD  v
| Eval_f e => evalD  e
| Other o => otherD  o
| Sep s => sepD  s
| Data l => dataD l
| Smx t => smxD t
end.


From stdpp Require Import prelude.
From sets Require Import Ensemble.
From AML Require Import Signature Pattern Variables Substitution.
From AML.Proofs Require Import TautologicalProof ProofSystem.
From AML.Semantics Require Import Tautology.

Section sec_theorems.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  .

Section sec_parameterized_definition.

Context (single_premise_rule : Pattern -> Pattern -> Prop).

Inductive MLXGammaTheorem (Gamma : PatternSet) : Pattern -> Prop :=
| ml_thm_assumption : forall ϕ, ϕ ∈ Gamma -> MLXGammaTheorem Gamma ϕ
| ml_thm_tautology : forall ϕ, Tautology ϕ -> MLXGammaTheorem Gamma ϕ
| ml_thm_axiom : forall ϕ, MLAxiom ϕ -> MLXGammaTheorem Gamma ϕ
| ml_thm_modus_ponens : forall ϕ ψ χ,
    MLModusPonens ϕ ψ χ ->
    MLXGammaTheorem Gamma ϕ ->
    MLXGammaTheorem Gamma ψ ->
    MLXGammaTheorem Gamma χ
| ml_thm_single_premise : forall ϕ ψ,
    single_premise_rule ϕ ψ ->
    MLXGammaTheorem Gamma ϕ ->
    MLXGammaTheorem Gamma ψ
.

Definition x_set_deduction (Gamma Delta : PatternSet) : Prop :=
  forall ϕ, ϕ ∈ Delta -> MLXGammaTheorem Gamma ϕ.

End sec_parameterized_definition.

Definition MLStrongGammaTheorem := MLXGammaTheorem MLStrongSinglePremiseRule.
Definition MLLocalGammaTheorem := MLXGammaTheorem MLLocalSinglePremiseRule.
Definition MLGammaTheorem := MLXGammaTheorem MLGlobalSinglePremiseRule.
Definition strong_set_deduction := x_set_deduction MLStrongSinglePremiseRule.
Definition local_set_deduction := x_set_deduction MLLocalSinglePremiseRule.
Definition set_deduction := x_set_deduction MLGlobalSinglePremiseRule.

End sec_theorems.

Notation "Gamma ⊢[ spr ] phi " := (MLXGammaTheorem spr Gamma phi) (at level 60, no associativity).
Notation "Gamma |-[ spr ] Delta " := (x_set_deduction spr Gamma Delta) (at level 60, no associativity).

Infix "⊢ₛ" := MLStrongGammaTheorem (at level 60, no associativity) : ml_scope.
Infix "|-ₛ" := strong_set_deduction (at level 60, no associativity) : ml_scope.

Infix "⊢ₗ" := MLLocalGammaTheorem (at level 60, no associativity) : ml_scope.
Infix "|-ₗ" := local_set_deduction (at level 60, no associativity) : ml_scope.

Infix "⊢" := MLGammaTheorem (at level 60, no associativity) : ml_scope.
Infix "|-" := set_deduction (at level 60, no associativity) : ml_scope.

Section sec_theorem_properties.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  (single_premise_rule : Pattern -> Pattern -> Prop).

Definition MLXTheorem spr (ϕ : Pattern) : Prop :=
  MLXGammaTheorem (PatternSet := PatternSet) spr ∅ ϕ.
Definition MLTheorem := MLXTheorem MLGlobalSinglePremiseRule.
Definition MLLocalTheorem := MLXTheorem MLLocalSinglePremiseRule.
Definition MLStrongTheorem := MLXTheorem MLStrongSinglePremiseRule.

Lemma x_gamma_theorem_subsumption spr :
  forall (Gamma Delta : PatternSet), Delta ⊆ Gamma ->
  forall ϕ, Delta ⊢[spr] ϕ -> Gamma ⊢[spr] ϕ.
Proof.
  intros * Hincl ϕ HDelta.
  induction HDelta.
  - by apply ml_thm_assumption, Hincl.
  - by apply ml_thm_tautology.
  - by apply ml_thm_axiom.
  - by eapply ml_thm_modus_ponens.
  - by eapply ml_thm_single_premise.
Qed.

Definition gamma_theorem_subsumption := x_gamma_theorem_subsumption MLGlobalSinglePremiseRule.
Definition local_gamma_theorem_subsumption := x_gamma_theorem_subsumption MLLocalSinglePremiseRule.
Definition strong_gamma_theorem_subsumption := x_gamma_theorem_subsumption MLStrongSinglePremiseRule.

Lemma strong_local_deduction_subsumption (Γ : PatternSet) ϕ :
  Γ ⊢ₛ ϕ -> Γ ⊢ₗ ϕ.
Proof.
  induction 1 as [| | | | ? ? Hspr].
  - by apply ml_thm_assumption.
  - by apply ml_thm_tautology.
  - by apply ml_thm_axiom.
  - by eapply ml_thm_modus_ponens.
  - by inversion Hspr.
Qed.

Lemma strong_local_set_deduction_subsumption (Γ Δ : PatternSet) :
  Γ |-ₛ Δ -> Γ |-ₗ Δ.
Proof. by intros Hincl ϕ Hϕ; apply strong_local_deduction_subsumption, Hincl. Qed.

Lemma local_deduction_subsumption (Γ : PatternSet) ϕ :
  Γ ⊢ₗ ϕ -> Γ ⊢ ϕ.
Proof.
  induction 1 as [| | | | ? ? Hspr].
  - by apply ml_thm_assumption.
  - by apply ml_thm_tautology.
  - by apply ml_thm_axiom.
  - by eapply ml_thm_modus_ponens.
  - by eapply ml_thm_single_premise; [apply rule_local_premise |].
Qed.

Lemma local_set_deduction_subsumption (Γ Δ : PatternSet) :
  Γ |-ₗ Δ -> Γ |- Δ.
Proof. by intros Hincl ϕ Hϕ; apply local_deduction_subsumption, Hincl. Qed.

Lemma strong_deduction_subsumption (Γ : PatternSet) ϕ :
  Γ ⊢ₛ ϕ -> Γ ⊢ ϕ.
Proof. by intro; apply local_deduction_subsumption, strong_local_deduction_subsumption. Qed.

Lemma strong_set_deduction_subsumption (Γ Δ : PatternSet) :
  Γ |-ₛ Δ -> Γ |- Δ.
Proof. by intros Hincl ϕ Hϕ; apply strong_deduction_subsumption, Hincl. Qed.

Lemma x_theorem_subsumption spr :
  forall (Gamma : PatternSet) (ϕ : Pattern),
  MLXTheorem spr ϕ -> Gamma ⊢[spr] ϕ.
Proof. by intro Gamma; apply x_gamma_theorem_subsumption; set_solver. Qed.

Definition theorem_subsumption := x_theorem_subsumption MLGlobalSinglePremiseRule.
Definition local_theorem_subsumption := x_theorem_subsumption MLLocalSinglePremiseRule.
Definition strong_theorem_subsumption := x_theorem_subsumption MLStrongSinglePremiseRule.

Lemma x_set_deduction_premises_subsumption spr :
  forall (Gamma Delta : PatternSet), Gamma |-[spr] Delta ->
  forall ϕ, Delta ⊢[spr] ϕ -> Gamma ⊢[spr] ϕ.
Proof.
  intros * Hincl ϕ HDelta.
  induction HDelta.
  - by apply Hincl.
  - by apply ml_thm_tautology.
  - by apply ml_thm_axiom.
  - by eapply ml_thm_modus_ponens.
  - by eapply ml_thm_single_premise.
Qed.

Definition set_deduction_premises_subsumption := x_set_deduction_premises_subsumption MLGlobalSinglePremiseRule.
Definition local_set_deduction_premises_subsumption := x_set_deduction_premises_subsumption MLLocalSinglePremiseRule.
Definition strong_set_deduction_premises_subsumption := x_set_deduction_premises_subsumption MLStrongSinglePremiseRule.

End sec_theorem_properties.

Section sec_theorem_ensemble.

Context `{signature}.

Definition x_set_of_gamma_theorems spr (Gamma : Ensemble Pattern) : Ensemble Pattern :=
  fun ϕ => Gamma ⊢[spr] ϕ.

Lemma x_set_of_gamma_theorems_idem spr (Gamma : Ensemble Pattern) :
  x_set_of_gamma_theorems spr (x_set_of_gamma_theorems spr Gamma)
    ≡
  x_set_of_gamma_theorems spr Gamma.
Proof.
  intro ϕ; split.
  - by apply x_set_deduction_premises_subsumption; intro.
  - apply x_gamma_theorem_subsumption.
    by intros ? ?; apply ml_thm_assumption.
Qed.

End sec_theorem_ensemble.

Section sec_derived_rules.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  (Γ : PatternSet).

Lemma ml_assumption spr ϕ : ϕ ∈ Γ -> Γ ⊢[spr] ϕ.
Proof. by apply ml_thm_assumption. Qed.

Lemma ml_tautology spr ϕ : Tautology ϕ -> Γ ⊢[spr] ϕ.
Proof. by apply ml_thm_tautology. Qed.

Lemma ml_ax_ex_quantifier spr (x y : EVar) (ϕ : Pattern) :
  EFreeFor x (PEVar y) ϕ ->
  Γ ⊢[spr] evar_sub0 x (PEVar y) ϕ →ₚ PEx x ϕ.
Proof. by intros; apply ml_thm_axiom, ax_ex_quantifier. Qed.

Lemma ml_propagation_bot_l spr (ϕ : Pattern) :
  Γ ⊢[spr] PApp (⊥ₚ) ϕ →ₚ ⊥ₚ.
Proof. by apply ml_thm_axiom, ax_propagation_bot_l. Qed.

Lemma ml_propagation_bot_r spr (ϕ : Pattern) :
  Γ ⊢[spr] PApp ϕ (⊥ₚ) →ₚ ⊥ₚ.
Proof. by apply ml_thm_axiom, ax_propagation_bot_r. Qed.

Lemma ml_propagation_or_l spr (ϕ ψ χ : Pattern) :
  Γ ⊢[spr] PApp (ϕ ∨ₚ ψ) χ →ₚ PApp ϕ χ ∨ₚ PApp ψ χ.
Proof. by apply ml_thm_axiom, ax_propagation_or_l. Qed.

Lemma ml_propagation_or_r spr (ϕ ψ χ : Pattern) :
  Γ ⊢[spr] PApp χ (ϕ ∨ₚ ψ) →ₚ PApp χ ϕ ∨ₚ PApp χ ψ.
Proof. by apply ml_thm_axiom, ax_propagation_or_r. Qed.

Lemma ml_propagation_ex_l spr x (ϕ χ : Pattern) (Hχ : x ∉ FEV χ) :
  Γ ⊢[spr] PApp (PEx x ϕ) χ →ₚ PEx x (PApp ϕ χ).
Proof. by apply ml_thm_axiom, ax_propagation_ex_l. Qed.

Lemma ml_propagation_ex_r spr x (ϕ χ : Pattern) (Hχ : x ∉ FEV χ) :
  Γ ⊢[spr] PApp χ (PEx x ϕ) →ₚ PEx x (PApp χ ϕ).
Proof. by apply ml_thm_axiom, ax_propagation_ex_r. Qed.

Lemma ml_pre_fixpoint spr : forall X ϕ,
  OccursPositively X ϕ ->
  SFreeFor X (μₚ X ϕ) ϕ ->
  Γ ⊢[spr] (svar_sub0 X (μₚ X ϕ) ϕ) →ₚ (μₚ X ϕ).
Proof. by intros; apply ml_thm_axiom, ax_pre_fixpoint. Qed.

Lemma ml_existence spr : forall x,
  Γ ⊢[spr] PEx x (PEVar x).
Proof. by intros; apply ml_thm_axiom, ax_existence. Qed.

Lemma ml_singleton_variable spr : forall x ϕ C1 C2,
  Γ ⊢[spr] ¬ₚ (csubst C1 (PEVar x ∧ₚ ϕ) ∧ₚ csubst C2 (PEVar x ∧ₚ ¬ₚ ϕ)).
Proof. by intros; apply ml_thm_axiom, ax_singleton_variable. Qed.

Lemma ml_ex_quantifier : forall x ϕ ψ,
  ~ x ∈ FEV ψ ->
  Γ ⊢ ϕ →ₚ ψ ->
  Γ ⊢ PEx x ϕ →ₚ ψ.
Proof. by intros; eapply ml_thm_single_premise; [apply rule_ex_quantifier |]. Qed.

Lemma local_ml_framing_l : forall ϕ ψ χ,
  Γ ⊢ₗ ϕ →ₚ ψ ->
  Γ ⊢ₗ PApp ϕ χ →ₚ PApp ψ χ.
Proof.
  by intros; eapply ml_thm_single_premise; [apply rule_framing_l |].
Qed.

Lemma ml_framing_l : forall ϕ ψ χ,
  Γ ⊢ ϕ →ₚ ψ ->
  Γ ⊢ PApp ϕ χ →ₚ PApp ψ χ.
Proof.
  by intros; eapply ml_thm_single_premise;
    [apply rule_local_premise, rule_framing_l |].
Qed.

Lemma local_ml_framing_r : forall ϕ ψ χ,
  Γ ⊢ₗ ϕ →ₚ ψ ->
  Γ ⊢ₗ PApp χ ϕ →ₚ PApp χ ψ.
Proof.
  by intros; eapply ml_thm_single_premise; [apply rule_framing_r |].
Qed.

Lemma ml_framing_r : forall ϕ ψ χ,
  Γ ⊢ ϕ →ₚ ψ ->
  Γ ⊢ PApp χ ϕ →ₚ PApp χ ψ.
Proof.
  by intros; eapply ml_thm_single_premise;
    [apply rule_local_premise, rule_framing_r |].
Qed.

Lemma ml_set_variable_substitution : forall ϕ X ψ,
    SFreeFor X ψ ϕ ->
    Γ ⊢ ϕ ->
    Γ ⊢ svar_sub0 X ψ ϕ.
Proof.
  by intros; eapply ml_thm_single_premise; [apply rule_set_variable_substitution |].
Qed.

Lemma local_ml_knaster_tarsky : forall ϕ X ψ,
    SFreeFor X ψ ϕ ->
    Γ ⊢ₗ svar_sub0 X ψ ϕ →ₚ ψ ->
    Γ ⊢ₗ μₚ X ϕ →ₚ ψ.
Proof.
  by intros; eapply ml_thm_single_premise; [apply rule_knaster_tarsky |].
Qed.

Lemma ml_knaster_tarsky : forall ϕ X ψ,
    SFreeFor X ψ ϕ ->
    Γ ⊢ svar_sub0 X ψ ϕ →ₚ ψ ->
    Γ ⊢ μₚ X ϕ →ₚ ψ.
Proof.
  by intros; eapply ml_thm_single_premise;
    [apply rule_local_premise, rule_knaster_tarsky |].
Qed.

Lemma ml_modus_ponens spr : forall ϕ ψ,
  Γ ⊢[spr] ϕ ->
  Γ ⊢[spr] ϕ →ₚ ψ ->
  Γ ⊢[spr] ψ.
Proof. by intros ? ?; eapply ml_thm_modus_ponens. Qed.

Lemma ml_equivalent_goal spr ϕ ψ :
  Tautology (ϕ ↔ₚ ψ) ->
  Γ ⊢[spr] ϕ ->
  Γ ⊢[spr] ψ.
Proof.
  intros.
  eapply ml_modus_ponens; [done |].
  eapply ml_modus_ponens; [by apply ml_tautology |].
  by apply ml_tautology, tautology_ϕ_and_ψ_impl_ϕ.
Qed.

End sec_derived_rules.


From Coq Require Import Arith ZArith Psatz Bool String List FSets Program.Equality.
Require Import Sequences IMP Constprop.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope list_scope.

(** * 10.  Liveness analysis and dead code elimination *)

Module IdentSet := FSetWeakList.Make(Ident_Decidable).
Module ISFact := FSetFacts.WFacts(IdentSet).
Module ISProp := FSetProperties.WProperties(IdentSet).
Module ISDecide := FSetDecide.Decide(IdentSet).
Import ISDecide.

(** ** 10.1 Liveness analysis *)

(** Computation of the set of variables appearing in an expression or command. *)

Fixpoint fv_aexp (a: aexp) : IdentSet.t :=
  match a with
  | CONST n => IdentSet.empty
  | VAR v => IdentSet.singleton v
  | PLUS a1 a2 => IdentSet.union (fv_aexp a1) (fv_aexp a2)
  | MINUS a1 a2 => IdentSet.union (fv_aexp a1) (fv_aexp a2)
  end.

Fixpoint fv_bexp (b: bexp) : IdentSet.t :=
  match b with
  | TRUE => IdentSet.empty
  | FALSE => IdentSet.empty
  | EQUAL a1 a2 => IdentSet.union (fv_aexp a1) (fv_aexp a2)
  | LESSEQUAL a1 a2 => IdentSet.union (fv_aexp a1) (fv_aexp a2)
  | NOT b1 => fv_bexp b1
  | AND b1 b2 => IdentSet.union (fv_bexp b1) (fv_bexp b2)
  end.

Fixpoint fv_com (c: com) : IdentSet.t :=
  match c with
  | SKIP => IdentSet.empty
  | ASSIGN x a => fv_aexp a
  | SEQ c1 c2 => IdentSet.union (fv_com c1) (fv_com c2)
  | IFTHENELSE b c1 c2 => IdentSet.union (fv_bexp b) (IdentSet.union (fv_com c1) (fv_com c2))
  | WHILE b c => IdentSet.union (fv_bexp b) (fv_com c)
  end.

(** To analyze loops, we will need, again!, to compute post-fixpoints
  of a function from sets of variables to sets of variables.
  We reuse the ``engineer's approach'' from file [Constprop.v]. *)

Section FIXPOINT.

Variable F: IdentSet.t -> IdentSet.t.
Variable default: IdentSet.t.

Fixpoint fixpoint_rec (fuel: nat) (x: IdentSet.t) : IdentSet.t :=
  match fuel with
  | O => default
  | S fuel =>
      let x' := F x in
      if IdentSet.subset x' x then x else fixpoint_rec fuel x'
  end.

Definition fixpoint : IdentSet.t :=
  fixpoint_rec 20%nat IdentSet.empty.

Lemma fixpoint_charact:
  IdentSet.Subset (F fixpoint) fixpoint \/ fixpoint = default.
Proof.
  unfold fixpoint. generalize 20%nat, IdentSet.empty. induction n; intros; cbn.
- auto.
- destruct (IdentSet.subset (F t) t) eqn:SUBSET.
+ left. apply IdentSet.subset_2; auto.
+ apply IHn.
Qed.

Hypothesis F_stable:
  forall x, IdentSet.Subset x default -> IdentSet.Subset (F x) default.

Lemma fixpoint_upper_bound:
  IdentSet.Subset fixpoint default.
Proof.
  assert (forall n x, IdentSet.Subset x default -> IdentSet.Subset (fixpoint_rec n x) default).
  { induction n; intros; cbn.
  - red; auto.
  - destruct (IdentSet.subset (F x) x) eqn:SUBSET.
    + auto.
    + apply IHn; auto.
  }
  unfold fixpoint. apply H. apply ISProp.subset_empty.
Qed.

End FIXPOINT.

(** ** Liveness analysis. *)

(** [L] is the set of variables live "after" command [c].
  The result of [live c L] is the set of variables live "before" [c]. *)

Fixpoint live (c: com) (L: IdentSet.t) : IdentSet.t :=
  match c with
  | SKIP => L
  | ASSIGN x a =>
      if IdentSet.mem x L
      then IdentSet.union (IdentSet.remove x L) (fv_aexp a)
      else L
  | SEQ c1 c2 =>
      live c1 (live c2 L)
  | IFTHENELSE b c1 c2 =>
      IdentSet.union (fv_bexp b) (IdentSet.union (live c1 L) (live c2 L))
  | WHILE b c =>
      let L' := IdentSet.union (fv_bexp b) L in
      let default := IdentSet.union (fv_com (WHILE b c)) L in
      fixpoint (fun x => IdentSet.union L' (live c x)) default
  end.

Lemma live_upper_bound:
  forall c L,
  IdentSet.Subset (live c L) (IdentSet.union (fv_com c) L).
Proof.
  induction c; intros; simpl.
- fsetdec.
- destruct (IdentSet.mem x L) eqn:MEM. fsetdec. fsetdec.
- specialize (IHc1 (live c2 L)). specialize (IHc2 L). fsetdec.
- specialize (IHc1 L). specialize (IHc2 L). fsetdec.
- apply fixpoint_upper_bound. intro x. specialize (IHc x). fsetdec.
Qed.

Lemma live_while_charact:
  forall b c L,
  let L' := live (WHILE b c) L in
  IdentSet.Subset (fv_bexp b) L' /\ IdentSet.Subset L L' /\ IdentSet.Subset (live c L') L'.
Proof.
  intros.
  specialize (fixpoint_charact
    (fun x : IdentSet.t => IdentSet.union (IdentSet.union (fv_bexp b) L) (live c x))
          (IdentSet.union (IdentSet.union (fv_bexp b) (fv_com c)) L)).
  simpl in L'. fold L'. intros [A|A].
- split. fsetdec. split; fsetdec.
- split. rewrite A. fsetdec.
  split. rewrite A. fsetdec.
  eapply ISProp.subset_trans. apply live_upper_bound. rewrite A. fsetdec.
Qed.

(** ** 10.2 The optimization: dead code elimination *)

(** Dead code elimination turns assignments [x := a] to dead variables [x]
  into [SKIP] statements. *)

Fixpoint dce (c: com) (L: IdentSet.t): com :=
  match c with
  | SKIP => SKIP
  | ASSIGN x a => if IdentSet.mem x L then ASSIGN x a else SKIP
  | SEQ c1 c2 => SEQ (dce c1 (live c2 L)) (dce c2 L)
  | IFTHENELSE b c1 c2 => IFTHENELSE b (dce c1 L) (dce c2 L)
  | WHILE b c => WHILE b (dce c (live (WHILE b c) L))
  end.

(** Example of optimization. *)

Compute (dce Euclidean_division (IdentSet.singleton "r")).

(** Result is:
<<
   r := a;                 ===>   r := a;
   q := 0;                        skip;
   while b <= r do                while b <= r do
     r := r - b;                    r := r - b;
     q := q + 1;                    skip;
   done                           done
>>
*)

Compute (dce Euclidean_division (IdentSet.singleton "q")).

(** Program is unchanged. *)

(** ** 10.3  Correctness of the optimization *)

(** Two stores agree on a set [L] of live variables if they assign
  the same values to each live variable. *)

Definition agree (L: IdentSet.t) (s1 s2: store) : Prop :=
  forall x, IdentSet.In x L -> s1 x = s2 x.

(** Monotonicity property. *)

Lemma agree_mon:
  forall L L' s1 s2,
  agree L' s1 s2 -> IdentSet.Subset L L' -> agree L s1 s2.
Proof.
  unfold IdentSet.Subset, agree; intros. auto.
Qed.

(** Agreement on the free variables of an expression implies that this
    expression evaluates identically in both stores. *)

Lemma aeval_agree:
  forall L s1 s2, agree L s1 s2 ->
  forall a, IdentSet.Subset (fv_aexp a) L -> aeval s1 a = aeval s2 a.
Proof.
  induction a; simpl; intros.
- auto.
- apply H. fsetdec.
- f_equal. apply IHa1. fsetdec. apply IHa2. fsetdec.
- f_equal. apply IHa1. fsetdec. apply IHa2. fsetdec.
Qed.

Lemma beval_agree:
  forall L s1 s2, agree L s1 s2 ->
  forall b, IdentSet.Subset (fv_bexp b) L -> beval s1 b = beval s2 b.
Proof.
  induction b; simpl; intros.
- auto.
- auto.
- rewrite ! (aeval_agree L s1 s2); auto; fsetdec.
- rewrite ! (aeval_agree L s1 s2); auto; fsetdec.
- f_equal; apply IHb; auto.
- f_equal. apply IHb1; fsetdec. apply IHb2; fsetdec.
Qed.

(** Agreement is preserved by simultaneous assignment to a live variable. *)

Lemma agree_update_live:
  forall s1 s2 L x v,
  agree (IdentSet.remove x L) s1 s2 ->
  agree L (update x v s1) (update x v s2).
Proof.
  intros; red; intros. unfold update. destruct (string_dec x x0).
- auto.
- apply H. apply IdentSet.remove_2. auto. auto.
Qed.

(** Agreement is also preserved by unilateral assignment to a dead variable. *)

Lemma agree_update_dead:
  forall s1 s2 L x v,
  agree L s1 s2 -> ~IdentSet.In x L ->
  agree L (update x v s1) s2.
Proof.
  intros; red; intros. unfold update. destruct (string_dec x x0).
- subst x0. contradiction.
- apply H; auto.
Qed.

(** We now show that dead code elimination preserves semantics for terminating
  source program.  We use big-step semantics to show the following diagram:
<<
                agree (live c L) s s1
     c / s ----------------------------- dce C L / s1
       |                                          |
       |                                          |
       |                                          |
       v                                          v
      s' -------------------------------------- s1'
                    agree L s' s1'
>>
  The proof is a simple induction on the big-step evaluation derivation on the left. *)

Theorem dce_correct_terminating:
  forall s c s', cexec s c s' ->
  forall L s1, agree (live c L) s s1 ->
  exists s1', cexec s1 (dce c L) s1' /\ agree L s' s1'.
Proof.
  induction 1; intros; cbn [dce].

- (* skip *)
  exists s1; split. apply cexec_skip. auto.

- (* assign *)
  cbn in H. destruct (IdentSet.mem x L) eqn:LIVE_AFTER.
  + (* x is live after *)
    assert (EQ: aeval s a = aeval s1 a).
    { eapply aeval_agree. eauto. fsetdec. }
    exists (update x (aeval s1 a) s1); split.
    apply cexec_assign.
    rewrite EQ. apply agree_update_live. eapply agree_mon. eauto. fsetdec.
  + (* x is dead after *)
    exists s1; split.
    apply cexec_skip.
    apply agree_update_dead. auto.
    rewrite ISFact.mem_iff. congruence.

- (* seq *)
  cbn in H1.
  destruct (IHcexec1 _ _ H1) as [s1' [E1 A1]].
  destruct (IHcexec2 _ _ A1) as [s2' [E2 A2]].
  exists s2'; split.
  apply cexec_seq with s1'; auto.
  auto.

- (* ifthenelse *)
  cbn in H0.
  assert (EQ: beval s b = beval s1 b).
  { eapply beval_agree. eauto. fsetdec. }
  destruct (IHcexec L s1) as [s1' [E A]].
    eapply agree_mon; eauto. destruct (beval s b); fsetdec.
  exists s1'; split.
  apply cexec_ifthenelse. rewrite <- EQ. destruct (beval s b); auto.
  auto.

- (* while done *)
  destruct (live_while_charact b c L) as [P [Q R]].
  assert (beval s1 b = false).
  { rewrite <- H. symmetry. eapply beval_agree; eauto. }
  exists s1; split.
  apply cexec_while_done. auto.
  eapply agree_mon; eauto.

- (* while loop *)
  destruct (live_while_charact b c L) as [P [Q R]].
  assert (beval s1 b = true).
  { rewrite <- H. symmetry. eapply beval_agree; eauto. }
  destruct (IHcexec1 (live (WHILE b c) L) s1) as [s2 [E1 A1]].
    eapply agree_mon; eauto.
  destruct (IHcexec2 L s2) as [s3 [E2 A2]].
    auto.
  exists s3; split.
  apply cexec_while_loop with s2; auto.
  auto.
Qed.

(** *** Exercise (3 stars, optional) *)

(** To prove semantic preservation both for terminating and diverging programs.
  complete the following simulation proof, which uses the small-step semantics
  of Imp, without continuations. *)

Fixpoint measure (c: com) : nat :=
  match c with
  | ASSIGN x a => 1%nat
  | SEQ c1 c2 => measure c1
  | _ => 0%nat
  end.

Theorem dce_simulation:
  forall c s c' s',
  red (c, s) (c', s') ->
  forall L s1,
  agree (live c L) s s1 ->
  (exists s1',
   red (dce c L, s1) (dce c' L, s1') /\ agree (live c' L) s' s1')
  \/
  (measure c' < measure c /\ dce c L = dce c' L /\ agree (live c' L) s' s1)%nat.
Proof.
   intros until s'. intro STEP. dependent induction STEP; intros; cbn [dce].
  (* FILL IN HERE *)
Abort.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.

(* Why3 goal *)
Definition nth: forall {a:Type} {a_WT:WhyType a}, Z -> (list a) -> a.
intros a a_WT.
exact (fix nth n l := match l with nil => why_inhabitant | cons h t => if Zeq_bool n Z0 then h else nth (n - 1)%Z t end).
Defined.

(* Why3 goal *)
Lemma nth_cons_0 : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (r:(list a)), ((nth 0%Z (Init.Datatypes.cons x r)) = x).
Proof.
now intros a a_WT x r.
Qed.

(* Why3 goal *)
Lemma nth_cons_n : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (r:(list a)) (n:Z), (0%Z < n)%Z -> ((nth n
  (Init.Datatypes.cons x r)) = (nth (n - 1%Z)%Z r)).
Proof.
intros a a_WT x r n h1.
simpl.
generalize (Zeq_bool_if n 0).
case Zeq_bool ; try easy.
now intros ->.
Qed.


Require Export Structure.FiniteCompleteClosed.
Require Export Structure.Pullback.

Module Topos.

Structure mixin_of (C: FCClosed) := Mixin {
  Subobj: C;
  truth: 1 ~> Subobj;
  sub {X Y: C} (f: X ~> Y): monic f -> Y ~> Subobj;
  sub_pullback {X Y: C} (f: X ~> Y) (Hf: monic f): is_pullback truth (sub f Hf) ! f;
  sub_unique {X Y: C} (f: X ~> Y) (g: Y ~> Subobj) (Hf: monic f): is_pullback truth g ! f -> sub f Hf = g;
}.

Section ClassDef.

Structure class_of (C: Category) := Class {
  base: FCClosed.class_of C;
  mixin: mixin_of (FCClosed.Pack C base);
}.

Local Coercion base: class_of >-> FCClosed.class_of.
Local Coercion mixin: class_of >-> mixin_of.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable (C: type).
Definition class := match C return class_of C with Pack _ c => c end.

Let xC := match C with Pack C _ => C end.
Notation xclass := (class: class_of xC).

Definition TopCategory := TopCategory.Pack C xclass.
Definition ProdCategory := ProdCategory.Pack C xclass.
Definition CartCategory := CartCategory.Pack C xclass.
Definition ExpCategory := ExpCategory.Pack C (ExpCategory.Class _ xclass xclass).
Definition CCC := CCC.Pack C xclass.
Definition EqCategory := EqCategory.Pack C xclass.
Definition FCClosed := FCClosed.Pack C xclass.

End ClassDef.

Module Exports.

Coercion base: class_of >-> FCClosed.class_of.
Coercion mixin: class_of >-> mixin_of.
Coercion sort: type >-> Category.
Coercion TopCategory: type >-> TopCategory.type.
Canonical TopCategory.
Coercion ProdCategory: type >-> ProdCategory.type.
Canonical ProdCategory.
Coercion CartCategory: type >-> CartCategory.type.
Canonical CartCategory.
Coercion ExpCategory: type >-> ExpCategory.type.
Canonical ExpCategory.
Coercion CCC: type >-> CCC.type.
Canonical CCC.
Coercion EqCategory: type >-> EqCategory.type.
Canonical EqCategory.
Coercion FCClosed: type >-> FCClosed.type.
Canonical FCClosed.
Notation Topos := type.

End Exports.

End Topos.

Export Topos.Exports.

Section ToposTheory.
Context {T: Topos}.

Definition Subobj: T := Topos.Subobj T (Topos.class T).
Definition truth: 1 ~> Subobj := Topos.truth T (Topos.class T).
Definition sub: forall {X Y: T} (f: X ~> Y), monic f -> Y ~> Subobj := @Topos.sub T (Topos.class T).

Notation Ω := Subobj.
Notation χ := sub.

Lemma sub_pullback: forall {X Y: T} (f: X ~> Y) (Hf: monic f), is_pullback truth (sub f Hf) ! f.
Proof. exact (@Topos.sub_pullback T (Topos.class T)). Qed.

Lemma sub_unique: forall {X Y: T} (f: X ~> Y) (g: Y ~> Subobj) (Hf: monic f), is_pullback truth g ! f -> sub f Hf = g.
Proof. exact (@Topos.sub_unique T (Topos.class T)). Qed.

End ToposTheory.


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

(***
Modulus : 2^130 - 5
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 64;
    bitwidth := 64;
    s := 2^130;
    c := [(1, 5)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.