Set Warnings "-notation-overridden,-parsing".
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From LF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Logic.FunctionalExtensionality.
Import ListNotations.
From LF Require Import Imp.

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st : state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st : state),
    beval st b1 = beval st b2.

Example aequiv_example : aequiv (X - X) 0.
Proof.
  unfold aequiv. intro st. simpl.
  destruct (st X).
  - omega.
  - omega.
Qed.

Example bequiv_example : bequiv (X - X = 0)%imp true.
Proof.
  unfold bequiv. intro st. unfold beval.
  rewrite aequiv_example. simpl. reflexivity.
Qed.

(* two commands are behaviorally equivalent if the first one
terminates in a particular state then so does the second, and vice
versa. *)
Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (st =[ c1 ]=> st') <-> (st =[ c2 ]=> st').

Theorem skip_left : forall c,
    cequiv (SKIP ;; c) c.
Proof.
  unfold cequiv. split.
  - intro H. inversion H. inversion H2.
    subst. apply H5.
  - intro H. eapply E_Seq.
    + apply E_Skip.
    + apply H.
Qed.

Theorem skip_right : forall c,
    cequiv (c ;; SKIP) c.
Proof.
  unfold cequiv. split.
  - intro H. inversion H. inversion H5. subst. apply H2.
  - intro H. eapply E_Seq.
    + apply H.
    + apply E_Skip.
Qed.

Theorem TEST_true_simple : forall c1 c2,
    cequiv (TEST true THEN c1 ELSE c2 FI) c1.
Proof.
  unfold cequiv. split.
  - intro H. inversion H.
    + apply H6.
    + simpl in H5. discriminate H5.
  - intro H. apply E_IfTrue.
    + reflexivity.
    + apply H.
Qed.

Theorem TEST_true : forall b c1 c2,
    bequiv b BTrue ->
    cequiv (TEST b THEN c1 ELSE c2 FI) c1.
Proof.
  unfold bequiv, cequiv. intros b c1 c2 H1.
  split.
  - intro H2. inversion H2.
    + apply H7.
    + rewrite H1 in H6. inversion H6.
  - intro H2. apply E_IfTrue.
    + apply H1.
    + apply H2.
Qed.

Theorem TEST_false : forall b c1 c2,
    bequiv b BFalse ->
    cequiv (TEST b THEN c1 ELSE c2 FI) c2.
Proof.
  unfold bequiv, cequiv. intros b c1 c2 H1. split.
  - intro H2. inversion H2.
    + rewrite H1 in H6. inversion H6.
    + apply H7.
  - intro H2. apply E_IfFalse.
    + apply H1.
    + apply H2.
Qed.

Theorem swap_if_branches : forall b e1 e2,
    cequiv
      (TEST b THEN e1 ELSE e2 FI)
      (TEST BNot b THEN e2 ELSE e1 FI).
Proof.
  unfold cequiv. split.
  - intro H. inversion H.
    + apply E_IfFalse.
      * simpl. rewrite H5. reflexivity.
      * apply H6.
    + apply E_IfTrue.
      * simpl. rewrite H5. reflexivity.
      * apply H6.
  - intro H. inversion H.
    + apply E_IfFalse.
      * simpl in H5. rewrite negb_true_iff in H5. apply H5.
      * apply H6.
    + apply E_IfTrue.
      * simpl in H5. rewrite negb_false_iff in H5. apply H5.
      * apply H6.
Qed.

Theorem WHILE_false : forall b c,
    bequiv b BFalse ->
    cequiv
      (WHILE b DO c END)
      SKIP.
Proof.
  unfold bequiv, cequiv. intros. split.
  - intro H1. inversion H1.
    + apply E_Skip.
    + rewrite H in H3. inversion H3.
  - intro H1. inversion H1. apply E_WhileFalse.
    apply H.
Qed.

Lemma WHILE_true_nonterm : forall b c st st',
    bequiv b BTrue ->
    ~( st =[WHILE b DO c END]=> st').
Proof.
  unfold bequiv, not. intros b c.
  remember (WHILE b DO c END)%imp as while eqn: Heqwhile.
  intros. induction H0.
  - inversion Heqwhile.
  - inversion Heqwhile.
  - inversion Heqwhile.
  - inversion Heqwhile.
  - inversion Heqwhile.
  - inversion Heqwhile. subst. rewrite H in H0.
    inversion H0.
  - apply IHceval2. apply Heqwhile.
Qed.

Theorem WHILE_true : forall b c,
    bequiv b true ->
    cequiv
      (WHILE b DO c END)
      (WHILE true DO SKIP END).
Proof.
  intros b c H.
  unfold cequiv. split.
  - intro H1. apply (WHILE_true_nonterm b c st st') in H.
    contradiction.
  - intro H1.
    assert (Heq: bequiv true true).
    { unfold bequiv. reflexivity. }
    apply (WHILE_true_nonterm true SKIP st st') in Heq.
    contradiction.
Qed.

Theorem loop_unrolling : forall b c,
    cequiv
      (WHILE b DO c END)
      (TEST b THEN (c ;; WHILE b DO c END) ELSE SKIP FI).
Proof.
  unfold cequiv. split.
  - intro H. inversion H.
    + apply E_IfFalse.
      * apply H4.
      * apply E_Skip.
    + apply E_IfTrue.
      * apply H2.
      * apply (E_Seq _ _ st st'0).
        { apply H3. }
        { apply H6. }
  - intro H. inversion H.
    + subst. inversion H6. apply (E_WhileTrue _ _ st'0).
      * apply H5.
      * apply H2.
      * apply H7.
    + inversion H6. subst. apply E_WhileFalse. apply H5.
Qed.

Theorem seq_assoc : forall c1 c2 c3,
    cequiv ((c1;;c2);;c3) (c1;;(c2;;c3)).
Proof.
  unfold cequiv. split.
  - intro H. inversion H. inversion H2.
    apply (E_Seq _ _ _ st'1).
    + apply H8.
    + apply (E_Seq _ _ _ st'0).
      * apply H11.
      * apply H5.
  - intro H. inversion H. inversion H5.
    apply (E_Seq _ _ _ st'1).
    * apply (E_Seq _ _ _ st'0); assumption.
    * assumption.
Qed.

Theorem identity_assignment : forall x,
    cequiv ( x ::= 0 ;; x ::= x ) ( x ::= 0 ;; SKIP).
Proof.
  unfold cequiv. split.
  - intro H. inversion H. inversion H2.  inversion H5. subst.
    apply (E_Seq _ _ _ (x !-> aeval st 0; st)).
    + apply E_Ass. reflexivity.
    + assert (Heq : (x !-> aeval st 0; st) = (x !-> aeval (x !-> aeval st 0; st) x; x !-> aeval st 0; st)).
      { apply functional_extensionality.
        intro x0. destruct (string_dec x x0).
        * rewrite e. rewrite t_update_eq. rewrite t_update_eq.
          simpl. rewrite t_update_eq. reflexivity.
        * assert (Heq1 : (x !-> aeval (x !-> aeval st 0; st) x; x !-> aeval st 0; st) x0 = (x !-> aeval st 0; st) x0).
          { apply t_update_neq. apply n. }
          rewrite Heq1. reflexivity.
      }
      rewrite <- Heq. apply E_Skip.
  - intro H. inversion H. inversion H2. inversion H5. subst.
    apply (E_Seq _ _ _ (x !-> aeval st 0; st)).
    + apply E_Ass. reflexivity.
    + assert (Heq : (x !-> aeval st 0; st) = (x !-> aeval (x !-> aeval st 0; st) x; x !-> aeval st 0; st)).
      { apply functional_extensionality.
        intro x0. destruct (string_dec x x0).
        * rewrite e. rewrite t_update_eq. rewrite t_update_eq.
          simpl. rewrite t_update_eq. reflexivity.
        * assert (Heq1 : (x !-> aeval (x !-> aeval st 0; st) x; x !-> aeval st 0; st) x0 = (x !-> aeval st 0; st) x0).
          { apply t_update_neq. apply n. }
          rewrite Heq1. reflexivity.
      }
      assert (Heq1 : (x !-> aeval st 0; st) =[ x ::= x ]=> (x !-> aeval st 0; st) =
                                                           (x !-> aeval st 0; st) =[ x ::= x ]=> (x !-> aeval (x !-> aeval st 0; st) x; x !-> aeval st 0; st)).
      { rewrite <- Heq. reflexivity. }
      rewrite Heq1. apply E_Ass. reflexivity.
Qed.

Theorem assign_aequiv : forall (x : string) e,
    aequiv x e ->
    cequiv SKIP (x ::= e).
Proof.
  unfold aequiv, cequiv. split.
  - intro H1. inversion H1. subst.
    assert (Heq : (x !-> aeval st' e; st') = st').
    { apply functional_extensionality.
      intro x0. destruct (string_dec x x0).
      + rewrite e0. rewrite t_update_eq.
        simpl. destruct (st' x0) eqn:E.
        * rewrite <- H. subst. simpl. apply E.
        * rewrite <- H. subst. simpl. apply E.
      + apply t_update_neq. apply n.
    }
    assert (Heq1 : st' =[ x ::= e ]=> st' =
                  st' =[ x ::= e ]=> (x !-> aeval st' e; st')
           ).
    { rewrite Heq. reflexivity. }
    rewrite Heq1. apply E_Ass. reflexivity.
  - intro H1. inversion H1. subst.
    assert (Heq : (x !-> aeval st e; st) = st).
    { apply functional_extensionality.
      intro x0. destruct (string_dec x x0).
      + rewrite e0. rewrite t_update_eq.
        simpl. destruct (st x0) eqn:E.
        * rewrite <- H. subst. simpl. apply E.
        * rewrite <- H. subst. simpl. apply E.
      + apply t_update_neq. apply n.
    }
    rewrite Heq. apply E_Skip.
Qed.

Definition prog_a : com :=
  (WHILE ~(X <= 0) DO
     X ::= X + 1
   END)%imp.

Definition prog_b : com :=
  (TEST X = 0 THEN
     X ::= X + 1;;
     Y ::= 1
   ELSE
     Y ::= 0
   FI;;
   X ::= X - Y;;
   Y ::= 0)%imp.

Definition prog_c : com :=
  SKIP%imp.

Definition prog_d : com :=
  (WHILE ~(X = 0) DO
     X ::= (X * Y) + 1
   END)%imp.

Definition prog_e : com :=
  (Y ::= 0)%imp.

Definition prog_f : com :=
  (Y ::= X + 1;;
   WHILE ~(X = Y) DO
     Y ::= X + 1
   END)%imp.

Definition prog_g : com :=
  (WHILE true DO
    SKIP
   END)%imp.

Definition prog_h : com :=
  (WHILE ~(X = X) DO
    X ::= X + 1
   END)%imp.

Definition prog_i : com :=
  (WHILE ~(X = Y) DO
    X ::= Y + 1
   END)%imp.

Definition equiv_classes : list (list com) :=
  [[prog_c; prog_h];
   [prog_a; prog_b; prog_d; prog_e; prog_f; prog_g; prog_i]].

Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof. unfold aequiv. reflexivity. Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
    aequiv a1 a2 -> aequiv a2 a1.
Proof.
  unfold aequiv. intros. rewrite H. reflexivity.
Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
    aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  unfold aequiv. intros. rewrite H. rewrite H0. reflexivity.
Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof. unfold bequiv. reflexivity. Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
    bequiv b1 b2 -> bequiv b2 b1.
Proof. unfold bequiv. intros. rewrite H. reflexivity. Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
    bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  unfold bequiv. intros. rewrite H. rewrite H0. reflexivity.
Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof. unfold cequiv. reflexivity. Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
    cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros. rewrite H. reflexivity.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
    (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros. rewrite H. rewrite H0. reflexivity.
Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
    cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv. intros.
  apply iff_trans with (P2 := (st =[ c2 ]=> st')).
  - apply H.
  - apply H0.
Qed.

Lemma test_congruence : forall (b : bool),
    b = true -> b = false -> False.
Proof. intros. congruence. Qed.

Theorem CAss_congruence : forall x a1 a1',
    aequiv a1 a1' ->
    cequiv (CAss x a1) (CAss x a1').
Proof.
  unfold aequiv, cequiv.
  intros. split.
  - intro H1. inversion H1. apply E_Ass.
    rewrite H in H5. apply H5.
  - intro H1. inversion H1. apply E_Ass.
    rewrite <- H in H5. apply H5.
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).
Proof.
  unfold bequiv, cequiv.
  intros. split.
  - intro H1. remember (WHILE b1 DO c1 END)%imp as while eqn: Heqwhile. induction H1.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile. subst. apply E_WhileFalse.
      rewrite H in H1. apply H1.
    + inversion Heqwhile. subst. apply (E_WhileTrue _ _ st').
      * rewrite H in H1. apply H1.
      * apply H0. apply H1_.
      * apply IHceval2. reflexivity.
  - intro H1. remember (WHILE b1' DO c1' END)%imp as while eqn: Heqwhile. induction H1.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile.
    + inversion Heqwhile. subst. apply E_WhileFalse.
      rewrite <- H in H1. apply H1.
    + inversion Heqwhile. subst. apply (E_WhileTrue _ _ st').
      * rewrite <- H in H1. apply H1.
      * apply H0. apply H1_.
      * apply IHceval2. reflexivity.
Qed.

Theorem CSeq_congruence : forall c1 c1' c2 c2',
    cequiv c1 c1' -> cequiv c2 c2' ->
    cequiv (c1;;c2) (c1';;c2').
Proof.
  unfold cequiv. intros. split.
  - intro H1. inversion H1. subst. apply (E_Seq _ _ _ st'0).
    + apply H. apply H4.
    + apply H0. apply H7.
  - intro H1. inversion H1. subst. apply (E_Seq _ _ _ st'0).
    + apply H. apply H4.
    + apply H0. apply H7.
Qed.

Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
    bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
    cequiv (TEST b THEN c1 ELSE c2 FI)
           (TEST b' THEN c1' ELSE c2' FI).
Proof.
  unfold bequiv, cequiv.
  intros. split.
  - intro H2. inversion H2.
    + subst. apply E_IfTrue.
      * rewrite H in H8. apply H8.
      * apply H0. apply H9.
    + subst. apply E_IfFalse.
      * rewrite H in H8. apply H8.
      * apply H1. apply H9.
  - intro H2. inversion H2.
     + subst. apply E_IfTrue.
      * rewrite <- H in H8. apply H8.
      * apply H0. apply H9.
    + subst. apply E_IfFalse.
      * rewrite <- H in H8. apply H8.
      * apply H1. apply H9.
Qed.

Example congruence_example:
  cequiv
    (* Program 1: *)
    (X ::= 0;;
     TEST X = 0
     THEN
       Y ::= 0
     ELSE
       Y ::= 42
     FI)
    (* Program 2: *)
    (X ::= 0;;
     TEST X = 0
     THEN
       Y ::= X - X (* <--- Changed here *)
     ELSE
       Y ::= 42
     FI).
Proof.
  apply CSeq_congruence.
  - apply CAss_congruence. apply refl_aequiv.
  - apply CIf_congruence.
    + apply refl_bequiv.
    + unfold cequiv. split.
      * intro H. inversion H. subst. apply E_Ass.
        simpl. apply sub_diag.
      * intro H. inversion H. subst. simpl.
        rewrite sub_diag. apply E_Ass. reflexivity.
    + apply refl_cequiv.
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 x => AId x
  | 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 ((1 + 2) * X) = (3 * X)%imp.
Proof. simpl. reflexivity. Qed.

Example fold_aexp_ex2 :
  fold_constants_aexp (X - ((0 * 6) + Y))%imp = (X - (0 + Y))%imp.
Proof. simpl. reflexivity. Qed.

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 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 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, BTrue) => BTrue
    | (BTrue, BFalse) => BFalse
    | (BFalse, BTrue) => BFalse
    | (BFalse, BFalse) => BFalse
    | (b1', b2') => BAnd b1' b2'
    end
  end.

Example fold_bexp_ex1 :
  fold_constants_bexp (true && ~(false && true))%imp
  = true.
Proof. reflexivity. Qed.

Example fold_bexp_ex2 :
  fold_constants_bexp ((X = Y) && (0 = (2 - (1 + 1))))%imp
  = ((X = Y) && true)%imp.
Proof. reflexivity. Qed.

Open Scope imp.
Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP => SKIP
  | x ::= a => x ::= (fold_constants_aexp a)
  | c1 ;; c2 =>
    (fold_constants_com c1) ;; (fold_constants_com c2)
  | TEST b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => TEST 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.
Close Scope imp.

Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    (X ::= 4 + 5;;
     Y ::= X - 3;;
     TEST (X - Y) = (2 + 4) THEN SKIP
     ELSE Y ::= 0 FI;;
     TEST 0 <= (4 - (2 + 1)) THEN Y ::= 0
     ELSE SKIP FI;;
     WHILE Y = 0 DO
       X ::= X + 1
     END)%imp
  = (* After constant folding: *)
    (X ::= 9;;
     Y ::= X - 3;;
     TEST (X - Y) = 6 THEN SKIP
     ELSE Y ::= 0 FI;;
     Y ::= 0;;
     WHILE Y = 0 DO
       X ::= X + 1
     END)%imp.
Proof. simpl. reflexivity. Qed.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound.
  unfold aequiv. intro a.
  induction a.
  - intro st. reflexivity.
  - intro st. reflexivity.
  - intro st. simpl. rewrite IHa1. rewrite IHa2.
    destruct (fold_constants_aexp a1);
      destruct (fold_constants_aexp a2); simpl; reflexivity.
  - intro st. simpl. rewrite IHa1. rewrite IHa2.
    destruct (fold_constants_aexp a1);
      destruct (fold_constants_aexp a2); simpl; reflexivity.
  - intro st. simpl. rewrite IHa1. rewrite IHa2.
    destruct (fold_constants_aexp a1);
      destruct (fold_constants_aexp a2); simpl; reflexivity.
Qed.

Theorem fold_constants_bexp_sound :
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv.
  induction b.
  - intro st. reflexivity.
  - intro st. reflexivity.
  - intro st. simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
        (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
        (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
    simpl. destruct (n =? n0); reflexivity.
  - intro st. simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
        (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
        (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
    simpl. destruct (n <=? n0); reflexivity.
  - intro st. simpl.
    remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb. destruct b'; reflexivity.
  - intro st. simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity.
Qed.

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  induction c.
  - simpl. apply refl_cequiv.
  - simpl. apply CAss_congruence. apply fold_constants_aexp_sound.
  - simpl. apply CSeq_congruence; assumption.
  - simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    destruct b'.
    + unfold cequiv in *.
      intros st st'. rewrite <- IHc1. apply TEST_true.
      rewrite Heqb'. apply fold_constants_bexp_sound.
    + unfold cequiv in *.
      intros st st'. rewrite <- IHc2. apply TEST_false.
      rewrite Heqb'. apply fold_constants_bexp_sound.
    + apply CIf_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc1.
      * apply IHc2.
    + apply CIf_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc1.
      * apply IHc2.
    + apply CIf_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc1.
      * apply IHc2.
    + apply CIf_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc1.
      * apply IHc2.
  - simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    destruct b'.
    + apply WHILE_true. unfold bequiv. intro st. simpl.
      rewrite fold_constants_bexp_sound. rewrite <- Heqb'.
      reflexivity.
    + apply WHILE_false. rewrite Heqb'.
      apply fold_constants_bexp_sound.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply fold_constants_bexp_sound.
      * apply IHc.
Qed.

Fixpoint optimize_0plus_aexp (a : aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | AId x => AId x
  | APlus (ANum 0) a2 => optimize_0plus_aexp a2
  | APlus a1 a2 => APlus (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | AMinus a1 a2 => AMinus (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | AMult a1 a2 => AMult (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  end.

Theorem optimize_0plus_aexp_sound :
  atrans_sound optimize_0plus_aexp.
Proof.
  unfold atrans_sound.
  apply aexp_ind.
  - intros n. simpl. apply refl_aequiv.
  - intros x. simpl. apply refl_aequiv.
  - intros. unfold aequiv. simpl. destruct a1.
    + intro st. simpl. rewrite H0. destruct n; reflexivity.
    + intro st. simpl; rewrite H0; reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
  - intros. unfold aequiv. simpl. destruct a1.
    + intro st. simpl. unfold aequiv in *. rewrite H0; reflexivity.
    + intro st. simpl; rewrite H0; reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
  - intros. unfold aequiv. simpl. destruct a1.
    + intro st. simpl. unfold aequiv in *. rewrite H0; reflexivity.
    + intro st. simpl; rewrite H0; reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
    + intro st. unfold aequiv in *. rewrite H0.
      simpl in *. rewrite H. reflexivity.
Qed.

Fixpoint optimize_0plus_bexp (b : bexp) : bexp :=
  match b with
  | BTrue | BFalse => b
  | BEq a1 a2 => BEq (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BLe a1 a2 => BLe (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BNot b1 => BNot (optimize_0plus_bexp b1)
  | BAnd b1 b2 => BAnd (optimize_0plus_bexp b1) (optimize_0plus_bexp b2)
  end.

Theorem optimize_0plus_bexp_sound :
      btrans_sound optimize_0plus_bexp.
Proof.
  unfold btrans_sound.
  apply bexp_ind.
    - apply refl_bequiv.
    - apply refl_bequiv.
    - intros a1 a2. unfold bequiv.
      intro st. simpl.
      rewrite (optimize_0plus_aexp_sound a1).
      rewrite (optimize_0plus_aexp_sound a2).
      reflexivity.
    - intros a1 a2. unfold bequiv.
      intro st. simpl.
      rewrite (optimize_0plus_aexp_sound a1).
      rewrite (optimize_0plus_aexp_sound a2).
      reflexivity.
    - intros b H. unfold bequiv. simpl. intro st.
      rewrite H. reflexivity.
    - intros b1 H1 b2 H2. unfold bequiv. intro st.
      simpl. rewrite H1, H2. reflexivity.
Qed.

Open Scope imp.
Fixpoint optimize_0plus_com (c : com) : com :=
  match c with
  | SKIP => SKIP
  | x ::= a => x ::= (optimize_0plus_aexp a)
  | c1 ;; c2 =>
    (optimize_0plus_com c1) ;; (optimize_0plus_com c2)
  | TEST b THEN c1 ELSE c2 FI =>
      match optimize_0plus_bexp b with
      | BTrue => optimize_0plus_com c1
      | BFalse => optimize_0plus_com c2
      | b' => TEST b' THEN optimize_0plus_com c1
              ELSE optimize_0plus_com c2 FI
      end
  | WHILE b DO c END =>
      match optimize_0plus_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (optimize_0plus_com c) END
      end
  end.
Close Scope imp.

Theorem optimize_0plus_com_sound :
      ctrans_sound optimize_0plus_com.
Proof.
  unfold ctrans_sound.
  intro c. induction c.
  - simpl. apply refl_cequiv.
  - simpl. apply CAss_congruence. apply optimize_0plus_aexp_sound.
  - simpl. apply CSeq_congruence; assumption.
  - simpl. remember (optimize_0plus_bexp b) as b' eqn:Heqb'.
    destruct b'.
    + unfold cequiv in *.
      intros st st'. rewrite <- IHc1. apply TEST_true.
      rewrite Heqb'. apply optimize_0plus_bexp_sound.
    + unfold cequiv in *.
      intros st st'. rewrite <- IHc2. apply TEST_false.
      rewrite Heqb'. apply optimize_0plus_bexp_sound.
    + apply CIf_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc1.
      * apply IHc2.
    + apply CIf_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc1.
      * apply IHc2.
    + apply CIf_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc1.
      * apply IHc2.
    + apply CIf_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc1.
      * apply IHc2.
  - simpl. remember (optimize_0plus_bexp b) as b' eqn:Heqb'.
    destruct b'.
    + apply WHILE_true. unfold bequiv. intro st. simpl.
      rewrite optimize_0plus_bexp_sound. rewrite <- Heqb'.
      reflexivity.
    + apply WHILE_false. rewrite Heqb'.
      apply optimize_0plus_bexp_sound.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc.
    + apply CWhile_congruence.
      * rewrite Heqb'. apply optimize_0plus_bexp_sound.
      * apply IHc.
Qed.

Fixpoint subst_aexp (x : string) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n => a
  | AId x' => if eqb_string x x' then u else a
  | APlus a1 a2 =>
    APlus (subst_aexp x u a1) (subst_aexp x u a2)
  | AMinus a1 a2 =>
    AMinus (subst_aexp x u a1) (subst_aexp x u a2)
  | AMult a1 a2 =>
    AMult (subst_aexp x u a1) (subst_aexp x u a2)
  end.

Example subst_aexp_ex :
  subst_aexp X (42 + 53) (Y + X)%imp = (Y + (42 + 53))%imp.
Proof. reflexivity. Qed.

Definition subst_equiv_property := forall x1 x2 a1 a2,
    cequiv (x1 ::= a1;; x2 ::= a2)
           (x1 ::= a1;; x2 ::= subst_aexp x1 a1 a2).

Theorem subst_inequiv : ~ subst_equiv_property.
Proof.
  unfold subst_equiv_property. unfold not.
  intros. unfold cequiv in H.
  destruct (H X Y (X + 1)%imp X%imp (X !-> 0) (Y !-> 1; X !-> 1; X !-> 0)).
  simpl in *.
  assert (HTrue : (X !-> 0) =[ X ::= X + 1;; Y ::= X ]=> (Y !-> 1; X !-> 1; X !-> 0)).
  { apply (E_Seq _ _ _ (X !-> 1; X !-> 0)).
    - apply E_Ass. reflexivity.
    - apply E_Ass. reflexivity.
  }
  apply H0 in HTrue. inversion HTrue. inversion H4. subst. simpl in H7.
  inversion H7. simpl in H6. subst.
  assert (Heq : (Y !-> 2; X !-> 1; X !-> 0) Y = (Y !-> 1; X !-> 1; X !-> 0) Y).
  rewrite H8. reflexivity.
  rewrite t_update_eq in Heq. rewrite t_update_eq in Heq. inversion Heq.
Qed.

Inductive var_not_used_in_aexp (x : string) : aexp -> Prop :=
| VNUNum : forall n, var_not_used_in_aexp x (ANum n)
| VNUId : forall y, x <> y -> var_not_used_in_aexp x (AId y)
| VNUPlus : forall a1 a2,
    var_not_used_in_aexp x a1 ->
    var_not_used_in_aexp x a2 ->
    var_not_used_in_aexp x (APlus a1 a2)
| VNUMinus : forall a1 a2,
    var_not_used_in_aexp x a1 ->
    var_not_used_in_aexp x a2 ->
    var_not_used_in_aexp x (AMinus a1 a2)
| VNUMult : forall a1 a2,
    var_not_used_in_aexp x a1 ->
    var_not_used_in_aexp x a2 ->
    var_not_used_in_aexp x (AMult a1 a2).

Lemma aeval_weakening : forall x st a ni,
    var_not_used_in_aexp x a ->
    aeval (x !-> ni ; st) a = aeval st a.
Proof.
  intros x st a ni H. induction H.
  - reflexivity.
  - apply (t_update_neq nat st x y ni) in H.
    simpl. rewrite H. reflexivity.
  - simpl. rewrite IHvar_not_used_in_aexp1.
    rewrite IHvar_not_used_in_aexp2.
    reflexivity.
  - simpl. rewrite IHvar_not_used_in_aexp1.
    rewrite IHvar_not_used_in_aexp2.
    reflexivity.
  - simpl. rewrite IHvar_not_used_in_aexp1.
    rewrite IHvar_not_used_in_aexp2.
    reflexivity.
Qed.

Theorem inequiv_exrcise :
  ~ cequiv (WHILE true DO SKIP END) SKIP.
Proof.
  unfold not, cequiv. intro H.
  destruct (H empty_st empty_st).
  assert (Hskip : empty_st =[ SKIP ]=> empty_st).
  { apply E_Skip. }
  apply H1 in Hskip.
  remember (WHILE true DO SKIP END)%imp as while eqn:Heqwhile.
  induction Hskip; try inversion Heqwhile.
  - subst. inversion H2.
  - subst. apply IHHskip2.
    + reflexivity.
    + apply H.
    + apply H0.
    + apply H1.
Qed.

Module Himp.

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

  Notation "'SKIP'" :=
    CSkip : imp_scope.
  Notation "X '::=' a" :=
    (CAss X a) (at level 60) : imp_scope.
  Notation "c1 ;; c2" :=
    (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity) : imp_scope.
  Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
    (CIf e1 e2 e3) (at level 80, right associativity) : imp_scope.
  Notation "'HAVOC' l" :=
    (CHavoc l) (at level 60) : imp_scope.

  Reserved Notation "st '=[' c ']=>' st'" (at level 40).

  Open Scope imp_scope.
  Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st, st =[ SKIP ]=> st
  | E_Ass : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st =[ WHILE b DO c END ]=> st''
  | E_Havoc : forall st x n,
      st =[ HAVOC x ]=> ( x !-> n; st)

  where "st =[ c ]=> st'" := (ceval c st st').
  Close Scope imp_scope.

  Example havoc_example1 : empty_st =[ (HAVOC X)%imp ]=> (X !-> 0).
  Proof. apply E_Havoc. Qed.

  Example havoc_example2 :
    empty_st =[ (SKIP ;; HAVOC Z)%imp ]=> (Z !-> 42).
  Proof.
    eapply E_Seq.
    - apply E_Skip.
    - apply E_Havoc.
  Qed.

  Definition cequiv (c1 c2 : com) : Prop := forall st st' : state,
      st =[ c1 ]=> st' <-> st =[ c2 ]=> st'.

  Definition pXY :=
    (HAVOC X;; HAVOC Y)%imp.
  Definition pYX :=
    (HAVOC Y;; HAVOC X)%imp.

  Theorem pXY_cequiv_pYX :
    cequiv pXY pYX \/ ~ cequiv pXY pYX.
  Proof.
    left. unfold pXY, pYX, cequiv.
    split.
    - intro H. inversion H. subst.
      inversion H2. subst.
      inversion H5. subst.
      assert (HeqSt: (Y !-> n0; X !-> n; st) = (X !-> n; Y !-> n0; st)).
      { apply (t_update_permute nat st n0 n Y X). unfold not.
        intro H3. inversion H3.
      }
      rewrite HeqSt.
      apply (E_Seq _ _ _ (Y !-> n0; st)).
      + apply E_Havoc.
      + apply E_Havoc.
    - intro H. inversion H. subst.
      inversion H2. subst.
      inversion H5. subst.
      assert (HeqSt: (X !-> n0; Y !-> n; st) = (Y !-> n; X !-> n0; st)).
      { apply (t_update_permute nat st n0 n X Y). unfold not.
        intro H3. inversion H3.
      }
      rewrite HeqSt.
      apply (E_Seq _ _ _ (X !-> n0; st)).
      + apply E_Havoc.
      + apply E_Havoc.
  Qed.

  Definition ptwice :=
    (HAVOC X;; HAVOC Y)%imp.
  Definition pcopy :=
    (HAVOC X;; Y ::= X)%imp.

  Theorem ptwice_cequiv_pcopy :
    cequiv ptwice pcopy \/ ~ cequiv ptwice pcopy.
  Proof.
    right. unfold not, ptwice, cequiv, pcopy.
    intro H. destruct (H empty_st (Y !-> 1; X !-> 0)).
    assert (H2: empty_st =[ (HAVOC X;; HAVOC Y)%imp ]=> (Y !-> 1; X !-> 0)).
    { apply (E_Seq _ _ _ (X !-> 0)).
      - apply E_Havoc.
      - apply E_Havoc.
    }
    apply H0 in H2. inversion H2. subst.
    inversion H8. subst.
    inversion H5. subst.
    simpl in H9. rewrite t_update_eq in H9.
    assert (Hcontr: n = 1 /\ n = 0).
    { split.
      assert (Heq : (Y !-> n; X !-> n) Y = (Y !-> 1; X !-> 0) Y).
      { rewrite H9. reflexivity. }
      rewrite t_update_eq in Heq. rewrite t_update_eq in Heq.
      apply Heq.
      assert (Heq : (Y !-> n; X !-> n) X = (Y !-> 1; X !-> 0) X).
      { rewrite H9. reflexivity. }
      rewrite t_update_neq in Heq. rewrite t_update_eq in Heq.
      rewrite t_update_neq in Heq. rewrite t_update_eq in Heq.
      apply Heq.
      intro HYX. inversion HYX.
      intro HYX. inversion HYX.
    }
    destruct Hcontr. congruence.
  Qed.

  Definition p1 : com :=
    (WHILE ~(X = 0) DO
       HAVOC Y;;
       X ::= X + 1
     END)%imp.

  Definition p2 : com :=
    (WHILE ~(X = 0) DO
       SKIP
     END)%imp.

  Lemma p1_may_diverge : forall st st',
      st X <> 0 ->
      ~ st =[ p1 ]=> st'.
  Proof.
    intros st st' H1 H2.
    unfold p1 in H2.
    remember ((WHILE ~ X = 0 DO HAVOC Y;; X ::= X + 1 END)%imp) as
        while eqn:Heqwhile.
    induction H2; try (inversion Heqwhile).
    - rewrite H2 in H. simpl in H.
      rewrite negb_false_iff in H.
      rewrite eqb_eq in H.
      congruence.
    - apply IHceval2.
      + subst. inversion H2_. subst. inversion H3.
        subst. inversion H6. subst.
        rewrite t_update_eq. simpl. rewrite t_update_neq. intro Hneq.
        destruct (st X).
        * contradiction.
        * simpl in Hneq. inversion Hneq.
        * intro HYX. inversion HYX.
      + subst. inversion H2_. subst. inversion H3.
        subst. inversion H6. subst.
        reflexivity.
  Qed.

  Lemma p2_may_diverge : forall st st',
      st X <> 0 ->
      ~ st =[ p2 ]=> st'.
  Proof.
    intros st st' H1 H2.
    unfold p2 in H2.
    remember (WHILE ~ X = 0 DO SKIP END)%imp as while eqn:Heqwhile.
    induction H2; try (inversion Heqwhile).
    - rewrite H2 in H. simpl in H.
      rewrite negb_false_iff in H.
      rewrite eqb_eq in H.
      destruct (st X).
      + apply H1. reflexivity.
      + congruence.
    - apply IHceval2.
      + subst. inversion H2_. subst. assumption.
      + subst. inversion H2_. subst. assumption.
  Qed.

  Theorem p1_p2_equiv : cequiv p1 p2.
  Proof.
    unfold cequiv, p1, p2. split.
    - intro H.
      remember ((WHILE ~ X = 0 DO HAVOC Y;; X ::= X + 1 END)%imp) as
          while eqn:Heqwhile.
      induction H; try inversion Heqwhile.
      + apply E_WhileFalse. rewrite H1 in H. apply H.
      + apply IHceval2 in Heqwhile.
        inversion Heqwhile.
        * subst. inversion H0. subst.
          inversion H4. subst. inversion H7. subst.
          simpl in H8. rewrite negb_false_iff in H8.
          rewrite eqb_eq in H8.
          rewrite t_update_eq in H8.
          destruct ((Y !-> n; st) X).
          inversion H8. inversion H8.
        * subst.
          remember (WHILE ~ X = 0 DO SKIP END)%imp as while1 eqn:Heqwhile1.
          induction H10; try inversion Heqwhile1.
          { inversion H7. subst. congruence. }
          { subst. inversion H7. subst. apply IHceval4.
            { reflexivity. }
            { apply Heqwhile. }
            { intro. apply Heqwhile. }
            { intro H11. inversion H11. }
            { apply H1. }
            { apply H10_. }
          }
    - intro H.
      remember (WHILE ~ X = 0 DO SKIP END)%imp as while1 eqn:Heqwhile.
      induction H; try inversion Heqwhile.
      + apply E_WhileFalse. rewrite H1 in H. apply H.
      + apply IHceval2 in Heqwhile.
        inversion Heqwhile.
        * subst. inversion H0. subst. congruence.
        * subst. inversion H0. subst. apply IHceval2.
          reflexivity.
  Qed.

  Definition p3 : com :=
    (Z ::= 1;;
     WHILE ~(X = 0) DO
       HAVOC X;;
       HAVOC Z
     END)%imp.

  Definition p4 : com :=
    (X ::= 0;;
     Z ::= 1)%imp.

  Theorem p3_p4_inequiv : ~ cequiv p3 p4.
  Proof.
    unfold cequiv, p3, p4. intro H.
    destruct (H (X !-> 1) (Z !-> 2;X !-> 0; X !-> 1)).
    assert (HFalse : (X !-> 1) =[ (Z ::= 1;; WHILE ~ X = 0 DO HAVOC X;; HAVOC Z END)%imp
                                ]=> (Z !-> 2; X !-> 0; X !-> 1)).
    { eapply E_Seq. apply E_Ass. reflexivity. simpl. eapply E_WhileTrue. reflexivity. eapply E_Seq. apply (E_Havoc _ _ 0).
      apply (E_Havoc _ _ 2).
      assert (Heq : (Z !-> 2; X !-> 0; Z !-> 1; X !-> 1)
                    = (Z !-> 2; X !-> 0; X !-> 1)).
      { apply functional_extensionality. intro x.
        destruct (string_dec Z x).
        - rewrite e. repeat rewrite t_update_eq. reflexivity.
        - assert (Heq1 :  (Z !-> 2; X !-> 0; Z !-> 1; X !-> 1) x =
                          (X !-> 0; Z !-> 1; X !-> 1) x).
          { apply t_update_neq. apply n. }
          rewrite Heq1.
          assert (Heq2 : (Z !-> 2; X !-> 0; X !-> 1) x =
                 (X !-> 0; X !-> 1) x).

          { apply t_update_neq. apply n. }
          rewrite Heq2.
          destruct (string_dec X x).
          + rewrite e. repeat rewrite t_update_eq. reflexivity.
          + assert (Heq3 : (X !-> 0; Z !-> 1; X !-> 1) x
                           = (Z !-> 1; X !-> 1) x).
            { apply t_update_neq. apply n0. }
            rewrite Heq3.
            assert (Heq4 : (X !-> 0; X !-> 1) x = (X !-> 1) x).
            { apply t_update_neq. apply n0. }
            rewrite Heq4.
            apply t_update_neq. apply n.
      }
      rewrite Heq. apply E_WhileFalse. reflexivity.
    }
    apply H0 in HFalse.
    inversion HFalse. subst.
    inversion H4. subst.
    inversion H7. subst. simpl in H8.
    assert (Heq : (Z !-> 1; X !-> 0; X !-> 1) Z = (Z !-> 2; X !-> 0; X !-> 1) Z).
    { rewrite H8. reflexivity. }
    repeat rewrite t_update_eq in Heq.
    inversion Heq.

  Qed.

  Definition p5 : com :=
  (WHILE ~(X = 1) DO
     HAVOC X
   END)%imp.

  Definition p6 : com :=
    (X ::= 1)%imp.

  Theorem p5_p6_equiv : cequiv p5 p6.
  Proof.
    unfold cequiv, p5, p6.
    split.
    - remember (WHILE ~ X = 1 DO HAVOC X END)%imp as while eqn:Heqwhile.
      intro H. induction H; try inversion Heqwhile.
      + subst. simpl in H. rewrite negb_false_iff in H.
        rewrite eqb_eq in H.
        assert (Heq1 : st = (X !-> 1; st)).
        { apply functional_extensionality.
          intro x. destruct (string_dec X x).
          * rewrite <- e. rewrite t_update_eq. apply H.
          * apply (t_update_neq nat st X x 1) in n. symmetry. apply n.
        }
        assert (Heq2 : st =[ (X ::= 1)%imp ]=> st <->
                       st =[ (X ::= 1)%imp ]=> (X !-> 1; st)
               ).
        { rewrite <- Heq1. reflexivity. }
        rewrite Heq2. apply E_Ass. reflexivity.
      + subst. simpl in H. rewrite negb_true_iff in H.
        rewrite eqb_neq in H.
        inversion H0. subst.
        apply IHceval2 in Heqwhile. inversion Heqwhile.
        subst. simpl.
        assert (Heq: (X !-> 1; X !-> n; st) = (X !-> 1; st)).
        { apply functional_extensionality.
          intro x. rewrite t_update_shadow. reflexivity.
        }
        rewrite Heq. apply E_Ass. reflexivity.
    - intro H. inversion H. subst. simpl in *.
      destruct (st X) eqn: HstX.
      + eapply E_WhileTrue.
        * simpl. rewrite HstX. reflexivity.
        * apply E_Havoc.
        * apply E_WhileFalse. simpl. reflexivity.
      + destruct n as [| n'].
        * assert (Heq : (X !-> 1; st) = st).
          { apply functional_extensionality.
            intro x. destruct (string_dec X x).
            { rewrite <- e. rewrite t_update_eq.
              symmetry. apply HstX.
            }
            { apply (t_update_neq nat st X x 1) in n. apply n. }
          }
          rewrite Heq. apply E_WhileFalse. simpl. rewrite HstX.
          reflexivity.
        * eapply E_WhileTrue.
          { simpl. rewrite HstX. reflexivity. }
          { apply E_Havoc. }
          { apply E_WhileFalse. reflexivity. }
  Qed.

End Himp.

Theorem swap_noninterfering_assignments : forall l1 l2 a1 a2,
    l1 <> l2 ->
    var_not_used_in_aexp l1 a2 ->
    var_not_used_in_aexp l2 a1 ->
    cequiv
      (l1 ::= a1;; l2 ::= a2)
      (l2 ::= a2;; l1 ::= a1).
Proof.
  intros l1 l2 a1 a2 H1 H2 H3.
  unfold cequiv. split.
  - intro H4.
    inversion H4. subst.
    inversion H5. subst.
    inversion H8. subst.
    eapply E_Seq.
    + apply E_Ass. reflexivity.
    + assert (Heq :
      (l2 !-> aeval (l1 !-> aeval st a1; st) a2; l1 !-> aeval st a1; st)
      =
      (l1 !-> aeval st a1; l2 !-> aeval (l1 !-> aeval st a1; st) a2; st)).
      { apply t_update_permute. apply H1. }
      rewrite Heq.
      assert (Heq1 : aeval st a2 = aeval (l1 !-> aeval st a1; st) a2).
      { symmetry. apply aeval_weakening. apply H2. }
      rewrite <- Heq1. apply E_Ass.
      apply aeval_weakening. apply H3.
  - intro H4.
    inversion H4. subst.
    inversion H5. subst.
    inversion H8. subst.
    eapply E_Seq.
    + apply E_Ass. reflexivity.
    + assert (Heq :
      (l1 !-> aeval (l2 !-> aeval st a2; st) a1; l2 !-> aeval st a2; st)
      =
      (l2 !-> aeval st a2; l1 !-> aeval (l2 !-> aeval st a2; st) a1; st)).
      { apply t_update_permute. auto. }
      rewrite Heq.
      assert (Heq1 : aeval st a1 = aeval (l2 !-> aeval st a2; st) a1).
      { symmetry. apply aeval_weakening. apply H3. }
      rewrite <- Heq1. apply E_Ass.
      apply aeval_weakening. apply H2.
Qed.

Definition capprox (c1 c2 : com) : Prop := forall (st st' : state),
    st =[ c1 ]=> st' -> st =[ c2 ]=> st'.

Definition c3 : com :=
  X ::= 1.

Definition c4 : com :=
  X ::= 2.

Theorem c3_c4_different : ~capprox c3 c4 /\ ~ capprox c4 c3.
Proof.
  split.
  - unfold not, capprox. intros.
    assert (Hf : empty_st =[ c3 ]=> (X !-> 1) -> empty_st =[ c4 ]=> (X !-> 1)).
    { apply H. }
    assert (Hf1 : empty_st =[ c4 ]=> (X !-> 1)).
    { apply Hf. apply E_Ass. reflexivity. }
    inversion Hf1. simpl in H3. subst.
    assert (Heq : (X !-> 2; empty_st) X = (X !-> 1) X).
    { rewrite H4. reflexivity. }
    rewrite t_update_eq in Heq. rewrite t_update_eq in Heq.
    inversion Heq.
  - unfold not, capprox. intros.
    assert (Hf : empty_st =[ c4 ]=> (X !-> 2) -> empty_st =[ c3 ]=> (X !-> 2)).
    { apply H. }
    assert (Hf1 : empty_st =[ c3 ]=> (X !-> 2)).
    { apply Hf. apply E_Ass. reflexivity. }
    inversion Hf1. simpl in H3. subst.
    assert (Heq : (X !-> 1; empty_st) X = (X !-> 2) X).
    { rewrite H4. reflexivity. }
    rewrite t_update_eq in Heq. rewrite t_update_eq in Heq.
    inversion Heq.
Qed.

Definition cmin : com :=
  WHILE true DO
    SKIP
  END.

Theorem cmin_minimal : forall c, capprox cmin c.
Proof.
  unfold capprox. intros.
  assert (H' : ~ (st =[ cmin ]=> st')).
  { apply WHILE_true_nonterm. simpl. apply refl_bequiv. }
  congruence.
Qed.

Definition zprop (c : com) : Prop :=
  forall c1, capprox c1 c.

Theorem zprop_preserving : forall c c',
    zprop c -> capprox c c' -> zprop c'.
Proof.
  unfold zprop. unfold capprox. intros.
  apply H0. apply (H c1). apply H1.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Rewriter.Util.Tactics.BreakMatch.
Require Import Rewriter.Util.Tactics.DestructHead.
Require Import Rewriter.Util.Notations.

Scheme Equality for option.
Arguments option_beq {_} _ _ _.

(* We would use [Scheme Minimality for option Sort Type.], but we want
   [option_rect_nodep] to unfold directly to [option_rect] so that
   unification doesn't have a hard time unifying [option_rect] and
   [option_rect_nodep] on large arguments. *)
Definition option_rect_nodep {A P} : (A -> P) -> P -> option A -> P
  := @option_rect A (fun _ => P).
Global Instance option_rect_nodep_Proper {A P}
  : Proper ((eq ==> eq) ==> eq ==> eq ==> eq) (@option_rect_nodep A P) | 10.
Proof. cbv; intros; subst; destruct_head' option; eauto. Qed.

Module Thunked.
  Definition option_rect {A} P (S_case : A -> P) (N_case : unit -> P) (o : option A) : P
    := Datatypes.option_rect (fun _ => P) S_case (N_case tt) o.
  Global Instance option_rect_Proper {A P}
    : Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq ==> eq) (@option_rect A P) | 10.
  Proof. repeat intro; eapply option_rect_nodep_Proper; eauto. Qed.
End Thunked.
(** Strongly prefer unfolding these versions of [option_rect] to the
    underlying [option_rect] principle.  Possibly -1 would suffice rather
    than expand, but I don't think there's harm in [expand] because
    [option_rect] ought not be much more complicated than any of these *)
Global Strategy expand [option_rect_nodep Thunked.option_rect].

Definition option_beq_hetero {A B} (AB_beq : A -> B -> bool) (x : option A) (y : option B) : bool
  := match x, y with
     | Some x, Some y => AB_beq x y
     | None, None => true
     | Some _, _
     | None, _
       => false
     end.

(** In general, [lift : M (option A) -> option (M A)].  This is a bit
    confusing for [option] because [M = option].  We want to return
    [None] if the thing contained in the [M (option A)] is [None], and
    say [Some] otherwise. *)
Definition lift {A} (x : option (option A)) : option (option A)
  := match x with
     | Some None => None (* the contained thing is bad/not present *)
     | Some (Some x) => Some (Some x)
     | None => Some None
     end.

Notation map := option_map (only parsing). (* so we have [Option.map] *)

Definition bind {A B} (v : option A) (f : A -> option B) : option B
  := match v with
     | Some v => f v
     | None => None
     end.

Definition sequence {A} (v1 v2 : option A) : option A
  := match v1 with
     | Some v => Some v
     | None => v2
     end.
Definition sequence_return {A} (v1 : option A) (v2 : A) : A
  := match v1 with
     | Some v => v
     | None => v2
     end.
Global Arguments sequence {A} !v1 v2.
Global Arguments sequence_return {A} !v1 v2.
Notation or_else := sequence (only parsing).
(* After OCaml's [value] *)
Notation value := sequence_return (only parsing).
Notation get_default := sequence_return (only parsing).

Module Export Notations.
  Declare Scope option_scope.
  Delimit Scope option_scope with option.
  Bind Scope option_scope with option.

  Notation "'olet' x .. y <- X ; B" := (bind X (fun x => .. (fun y => B%option) .. )) : option_scope.
  Notation "A <- X ; B" := (bind X (fun A => B%option)) : option_scope.
  Infix ";;" := sequence : option_scope.
  Infix ";;;" := sequence_return : option_scope.
End Notations.
Local Open Scope option_scope.

Definition combine {A B} (x : option A) (y : option B) : option (A * B)
  := match x, y with
     | Some x, Some y => Some (x, y)
     | _, _ => None
     end.

Section Relations.
  Definition option_eq {A B} eq (x : option A) (y : option B) :=
    match x with
    | None    => y = None
    | Some ax => match y with
                 | None => False
                 | Some ay => eq ax ay
                 end
    end.

  Local Ltac t :=
    cbv; repeat (break_match || intro || intuition congruence ||
                 solve [ apply reflexivity
                       | apply symmetry; eassumption
                       | eapply transitivity; eassumption
                       | eauto ] ).

  Global Instance Reflexive_option_eq {T} {R} {Reflexive_R:@Reflexive T R}
    : Reflexive (option_eq R) | 1. Proof. t. Qed.

  Lemma option_eq_sym {A B} {R1 R2 : _ -> _ -> Prop} (HR : forall v1 v2, R1 v1 v2 -> R2 v2 v1)
    : forall v1 v2, @option_eq A B R1 v1 v2 -> option_eq R2 v2 v1.
  Proof. t. Qed.

  Lemma option_eq_trans {A B C} {R1 R2 R3 : _ -> _ -> Prop}
        (HR : forall v1 v2 v3, R1 v1 v2 -> R2 v2 v3 -> R3 v1 v3)
    : forall v1 v2 v3, @option_eq A B R1 v1 v2 -> @option_eq B C R2 v2 v3 -> @option_eq A C R3 v1 v3.
  Proof. t. Qed.

  Global Instance Transitive_option_eq {T} {R} {Transitive_R:@Transitive T R}
    : Transitive (option_eq R) | 1 := option_eq_trans Transitive_R.

  Global Instance Symmetric_option_eq {T} {R} {Symmetric_R:@Symmetric T R}
    : Symmetric (option_eq R) | 1 := option_eq_sym Symmetric_R.

  Global Instance Equivalence_option_eq {T} {R} {Equivalence_R:@Equivalence T R}
    : Equivalence (option_eq R). Proof. split; exact _. Qed.
End Relations.

Lemma option_bl_hetero {A B} {AB_beq : A -> B -> bool} {AB_R : A -> B -> Prop}
      (AB_bl : forall x y, AB_beq x y = true -> AB_R x y)
      {x y}
  : option_beq_hetero AB_beq x y = true -> option_eq AB_R x y.
Proof using Type.
  destruct x, y; cbn in *; eauto; congruence.
Qed.

Lemma option_lb_hetero {A B} {AB_beq : A -> B -> bool} {AB_R : A -> B -> Prop}
      (AB_lb : forall x y, AB_R x y -> AB_beq x y = true)
      {x y}
  : option_eq AB_R x y -> option_beq_hetero AB_beq x y = true.
Proof using Type.
  destruct x, y; cbn in *; eauto; intuition congruence.
Qed.

Lemma option_beq_hetero_uniform {A : Type} A_beq {x y}
  : option_beq_hetero A_beq x y = @option_beq A A_beq x y.
Proof. destruct x, y; reflexivity. Qed.

Lemma option_bl_hetero_eq {A}
      {A_beq : A -> A -> bool}
      (A_bl : forall x y, A_beq x y = true -> x = y)
      {x y}
  : option_beq_hetero A_beq x y = true -> x = y.
Proof using Type. rewrite option_beq_hetero_uniform; now apply internal_option_dec_bl. Qed.

Lemma option_lb_hetero_eq {A}
      {A_beq : A -> A -> bool}
      (A_lb : forall x y, x = y -> A_beq x y = true)
      {x y}
  : x = y -> option_beq_hetero A_beq x y = true.
Proof using Type. rewrite option_beq_hetero_uniform; now apply internal_option_dec_lb. Qed.

Global Instance bind_Proper {A B}
  : Proper (eq ==> (pointwise_relation _ eq) ==> eq) (@bind A B).
Proof.
  cbv [respectful bind pointwise_relation Proper]; intros; subst; break_innermost_match; auto.
Qed.

Global Instance bind_Proper_pointwise_option_eq {A B RB}
  : Proper (eq ==> (pointwise_relation _ (option_eq RB)) ==> option_eq RB) (@bind A B) | 90.
Proof.
  cbv [respectful bind pointwise_relation Proper]; intros; subst; break_innermost_match; cbn [option_eq]; auto.
Qed.

Lemma bind_Proper_option_eq_hetero {A A' B B'} {RA RB : _ -> _ -> Prop}
      a a' (HA : option_eq RA a a') b b' (HB : forall a a', RA a a' -> option_eq RB (b a) (b' a'))
  : option_eq RB (@bind A B a b) (@bind A' B' a' b').
Proof.
  cbv [bind].
  destruct a as [a|], a' as [a'|]; try (reflexivity || congruence || exfalso; assumption).
  cbn [option_eq] in *; auto.
Qed.

Global Instance bind_Proper_option_eq {A B RA RB}
  : Proper (option_eq RA ==> (RA ==> option_eq RB) ==> option_eq RB) (@bind A B) | 100.
Proof.
  cbv [Proper respectful]; eapply bind_Proper_option_eq_hetero.
Qed.

Global Instance Proper_option_rect_nd_changebody
      {A B:Type} {RB:relation B} {a:option A}
  : Proper (pointwise_relation _ RB ==> RB ==> RB) (fun S N => option_rect (fun _ => B) S N a).
Proof. cbv; repeat (intro || break_match); intuition. Qed.

(* FIXME: there used to be a typeclass resolution hint here, something like
  #[global] Hint Extern 1 (Proper _ (@option_rect ?A (fun _ => ?B))) => exact (@Proper_option_rect_nd_changebody A B _ _) : typeclass_instances.
 but I could not get it working after generalizing [RB] from [Logic.eq] ~ andreser *)

Global Instance Proper_option_rect_nd_changevalue
      {A B RA RB} some {Proper_some: Proper (RA==>RB) some}
  : Proper (RB ==> option_eq RA ==> RB) (@option_rect A (fun _ => B) some).
Proof. cbv; repeat (intro || break_match || f_equiv || intuition congruence). Qed.

Lemma bind_zero_l {A B} f : @bind A B None f = None.
Proof. reflexivity. Qed.
Lemma bind_zero_r {A B} v : @bind A B v (fun _ => None) = None.
Proof. destruct v; reflexivity. Qed.
Lemma bind_zero_r_ext {A B} v f : (forall v, f v = None) -> @bind A B v f = None.
Proof. destruct v; cbn; auto. Qed.

Lemma option_rect_false_returns_true_iff
      {T} {R} {reflexiveR:Reflexive R}
      (f:T->bool) {Proper_f:Proper(R==>eq)f} (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, option_eq R o (Some s) /\ f s = true.
Proof.
  unfold option_rect; break_match; repeat intuition (destruct_head ex; eauto);
    solve [ congruence
          | repeat esplit; simpl; easy
          | match goal with [H : f _ = true |- f _ = true ] =>
                            solve [rewrite <- H; eauto] end ].
Qed.

Lemma option_rect_false_returns_true_iff_eq
      {T} (f:T->bool) (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, Logic.eq o (Some s) /\ f s = true.
Proof. unfold option_rect; break_match; repeat intuition (destruct_head ex; eauto); congruence. Qed.

Lemma option_rect_option_map : forall {A B C} (f:A->B) some none v,
    option_rect (fun _ => C) (fun x => some (f x)) none v = option_rect (fun _ => C) some none (option_map f v).
Proof.
  destruct v; reflexivity.
Qed.

Lemma option_map_map : forall {A B C} (f:A->B) (g:B->C) v,
    option_map g (option_map f v) = option_map (fun v => g (f v)) v.
Proof.
  destruct v; reflexivity.
Qed.

Lemma option_rect_function {A B C S' N' v} f
  : f (option_rect (fun _ : option A => option B) S' N' v)
    = option_rect (fun _ : option A => C) (fun x => f (S' x)) (f N') v.
Proof. destruct v; reflexivity. Qed.

(*
Ltac commute_option_rect_Let_In := (* pull let binders out side of option_rect pattern matching *)
  idtac;
  lazymatch goal with
  | [ |- ?LHS = option_rect ?P ?S ?N (Let_In ?x ?f) ]
    => (* we want to just do a [change] here, but unification is stupid, so we have to tell it what to unfold in what order *)
    cut (LHS = Let_In x (fun y => option_rect P S N (f y))); cbv beta;
    [ set_evars;
      let H := fresh in
      intro H;
      rewrite H;
      clear;
      abstract (cbv [Let_In]; reflexivity)
    | ]
  end.
*)

Ltac replace_option_match_with_option_rect :=
  idtac;
  lazymatch goal with
  | [ |- _ = ?RHS :> ?T ]
    => lazymatch RHS with
       | match ?a with None => ?N | Some x => @?S x end
         => replace RHS with (option_rect (fun _ => T) S N a) by (destruct a; reflexivity)
       end
  end.

Ltac simpl_option_rect := (* deal with [option_rect _ _ _ None] and [option_rect _ _ _ (Some _)] *)
  repeat match goal with
         | [ |- context[option_rect ?P ?S ?N None] ]
           => change (option_rect P S N None) with N
         | [ |- context[option_rect ?P ?S ?N (Some ?x) ] ]
           => change (option_rect P S N (Some x)) with (S x); cbv beta
         end.

Definition option_leq_to_eq {A} (x y : option A) : x = y -> option_eq eq x y.
Proof. destruct x; intro; subst; simpl; reflexivity. Defined.

Definition option_eq_to_leq {A} (x y : option A) : option_eq eq x y -> x = y.
Proof.
  destruct x, y; simpl;
    try solve [ intros []
              | apply f_equal
              | reflexivity
              | apply eq_sym ].
Defined.

Lemma option_leq_to_eq_to_leq {A x y} v : @option_eq_to_leq A x y (@option_leq_to_eq A x y v) = v.
Proof.
  destruct x; subst; simpl; reflexivity.
Qed.

Lemma option_eq_to_leq_to_eq {A x y} v : @option_leq_to_eq A x y (@option_eq_to_leq A x y v) = v.
Proof.
  compute in *.
  repeat first [ progress subst
               | progress break_innermost_match_step
               | reflexivity ].
Qed.

Lemma UIP_None {A} (p q : @None A = @None A) : p = q.
Proof.
  rewrite <- (option_leq_to_eq_to_leq p), <- (option_leq_to_eq_to_leq q); simpl; reflexivity.
Qed.

Definition is_None {A} (x : option A) : bool
  := match x with
     | Some _ => false
     | None => true
     end.

Definition is_Some {A} (x : option A) : bool
  := match x with
     | Some _ => true
     | None => false
     end.

Lemma is_None_eq_None_iff {A x} : @is_None A x = true <-> x = None.
Proof. destruct x; cbv; split; congruence. Qed.

Definition invert_Some {A} (x : option A) : match x with
                                            | Some _ => A
                                            | None => unit
                                            end
  := match x with
     | Some x' => x'
     | None => tt
     end.

Lemma invert_eq_Some {A x y} (p : Some x = Some y) : { pf : x = y | @option_eq_to_leq A (Some x) (Some y) pf = p }.
Proof.
  refine (exist _ _ (option_leq_to_eq_to_leq _)).
Qed.

Definition always_invert_Some {A} (x : option A) {pf : x <> None} : A
  := match x return x <> None -> A with
     | Some v => fun _ => v
     | None => fun pf => False_rect _ (pf eq_refl)
     end pf.

Lemma push_always_invert_Some' {A B} (f : A -> B) (x : option A)
      (pf : x <> None)
      (pf' : option_map f x <> None)
  : f (@always_invert_Some _ x pf) = @always_invert_Some _ (option_map f x) pf'.
Proof.
  destruct x; [ reflexivity | congruence ].
Qed.

Definition pull_always_invert_Some {A B} (f : A -> B) (x : option A)
      (pf : option_map f x <> None)
  : f (@always_invert_Some _ x (fun H => pf (f_equal (option_map f) H)))
    = @always_invert_Some _ (option_map f x) pf
  := push_always_invert_Some' f x _ pf.

Lemma option_map_neq_None_iff {A B} (f : A -> B) x
  : x <> None <-> option_map f x <> None.
Proof. destruct x; cbn in *; split; congruence. Qed.

Definition push_always_invert_Some {A B} (f : A -> B) (x : option A)
      (pf : x <> None)
  : f (@always_invert_Some _ x pf)
    = @always_invert_Some _ (option_map f x)
                         (proj1 (option_map_neq_None_iff f x) pf)
  := push_always_invert_Some' f x pf _.

Definition always_invert_Some_bind' {A B} (x : option A) (f : A -> option B)
           pf pf' pf''
  : @always_invert_Some _ (bind x f) pf
    = @always_invert_Some _ (f (@always_invert_Some _ x pf')) pf''.
Proof.
  destruct x as [x|]; cbn in *; [ destruct (f x); cbn in * | ];
    congruence.
Qed.

Lemma bind_neq_None_iff {A B} (x : option A) (f : A -> option B)
  : (bind x f <> None) <-> (x <> None /\ forall pf, f (@always_invert_Some _ x pf) <> None).
Proof.
  destruct x as [x|]; cbn; [ destruct (f x); cbn | ]; intuition congruence.
Qed.

Lemma bind_neq_None_iff' {A B} (x : option A) (f : A -> option B)
  : (bind x f <> None) <-> (exists pf : x <> None, f (@always_invert_Some _ x pf) <> None).
Proof.
  destruct x as [x|]; cbn; [ destruct (f x); cbn | ];
    split; intros; destruct_head'_ex; try unshelve econstructor;
      congruence.
Qed.

Definition push_always_invert_Some_bind {A B} (x : option A) (f : A -> option B)
           pf
           (pf' := proj1 (proj1 (bind_neq_None_iff x f) pf))
           (pf'' := proj2 (proj1 (bind_neq_None_iff x f) pf) pf')
  : @always_invert_Some _ (bind x f) pf
    = @always_invert_Some _ (f (@always_invert_Some _ x pf')) pf''
  := always_invert_Some_bind' x f _ _ _.

Definition pull_always_invert_Some_bind {A B} (x : option A) (f : A -> option B)
           pf pf'
           (pf'' := proj2 (bind_neq_None_iff' x f) (ex_intro _ pf pf'))
  : @always_invert_Some _ (f (@always_invert_Some _ x pf)) pf'
    = @always_invert_Some _ (bind x f) pf''
  := eq_sym (always_invert_Some_bind' x f _ _ _).

Ltac inversion_option_step :=
  match goal with
  | [ H : Some _ = Some _ |- _ ] => apply option_leq_to_eq in H; unfold option_eq in H
  | [ H : Some _ = Some _ |- _ ]
    => let H' := fresh in
       rename H into H';
       destruct (invert_eq_Some H') as [H ?]; subst H'
  | [ H : None = Some _ |- _ ] => solve [ inversion H ]
  | [ H : Some _ = None |- _ ] => solve [ inversion H ]
  | [ H : None = None |- _ ] => clear H
  | [ H : None = None |- _ ]
    => assert (eq_refl = H) by apply UIP_None; subst H
  end.

Ltac inversion_option := repeat inversion_option_step.


Require Import Bool Arith Max List.
Import List.ListNotations.
Require Import Omega.
Require Import Cecoa.Lib.

Set Implicit Arguments.
Unset Strict Implicit.

Section Syntax.

(* AST *)

Variables variable function constructor : Type.
Variable max_arity : nat.

Inductive value : Type :=
| c_capply : constructor -> list value -> value.

Inductive term : Type :=
| var : variable -> term
| capply : constructor -> list term -> term
| fapply : function -> list term -> term.

Inductive pattern : Type :=
| p_var : variable -> pattern
| p_capply : constructor -> list pattern -> pattern.

Inductive rule : Type :=
| rule_intro : function -> list pattern -> term -> rule.

(* Smarter induction principles than the ones automatically generated *)

Lemma value_ind2_gen :
  forall (P : value -> Type)(Q : list value -> Type),
  Q nil ->
  (forall v l, P v -> Q l -> Q (v :: l)) ->
  (forall c l, Q l -> P (c_capply c l)) ->
  forall v, P v.
Proof.
fix H1 6; intros P Q H2 H3 H4 [c l]; apply H4; revert l; fix H5 1; intros [ | v l].

- apply H2.

- apply H3.

  + apply H1 with (Q:=Q).

    * apply H2.

    * apply H3.

    * apply H4.

  + apply H5.
Qed.

Lemma term_ind2_gen :
  forall (P : term -> Prop)(Q : list term -> Prop),
  Q nil ->
  (forall t l, P t -> Q l -> Q (t :: l)) ->
  (forall x, P (var x)) ->
  (forall c l, Q l -> P (capply c l)) ->
  (forall f l, Q l -> P (fapply f l)) ->
  forall t, P t.
Proof.
fix H1 8; intros P Q H2 H3 H4 H5 H6 [ x | c l | f l ].
- apply H4.

- apply H5; revert l; fix H7 1; intros [ | t l].

  + apply H2.

  + apply H3.

    * { apply H1 with (Q:=Q).

      - apply H2.

      - apply H3.

      - apply H4.

      - apply H5.

      - apply H6. }

    * apply H7.

- apply H6; revert l; fix H7 1; intros [ | t l].

  + apply H2.

  + apply H3.

    * { apply H1 with (Q:=Q).

      - apply H2.

      - apply H3.

      - apply H4.

      - apply H5.

      - apply H6. }

    * apply H7.
Qed.

Lemma term_ind2 :
  forall (P : term -> Prop),
  (forall x, P (var x)) ->
  (forall c l, (forall t, In t l -> P t) -> P (capply c l)) ->
  (forall f l, (forall t, In t l -> P t) -> P (fapply f l)) ->
  forall t, P t.
Proof.
intros P H1 H2 H3 t.
apply term_ind2_gen with (Q := fun l => forall t, In t l -> P t); simpl; try tauto.
clear H1 H2 H3 t; intros t1 l H1 H2 t2 [H3 | H3].

- subst; trivial.

- auto.
Qed.

Lemma pattern_ind2_gen :
  forall (P : pattern -> Prop)(Q : list pattern -> Prop),
  Q nil ->
  (forall p l, P p -> Q l -> Q (p :: l)) ->
  (forall x, P (p_var x)) ->
  (forall c l, Q l -> P (p_capply c l)) ->
  forall p, P p.
Proof.
fix H1 7; intros P Q H2 H3 H4 H5 [ x | c l ].

- apply H4.

- apply H5; revert l; fix H6 1; intros [ | p l].

  + apply H2.

  + apply H3.

    * { apply H1 with (Q:=Q).

      - apply H2.

      - apply H3.

      - apply H4.

      - apply H5. }

    * apply H6.
Qed.

Lemma pattern_ind2 :
  forall (P : pattern -> Prop),
  (forall x, P (p_var x)) ->
  (forall c l, (forall p, In p l -> P p) -> P (p_capply c l)) ->
  forall p, P p.
Proof.
intros P H1 H2 p.
apply pattern_ind2_gen with (Q := fun l => forall p, In p l -> P p); simpl; try tauto.
clear H1 H2 p; intros p1 l H1 H2 p2 [H3 | H3].

- subst; trivial.

- auto.
Qed.

(* Boolean equalities for syntax *)

Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.

Definition variable_beq (x1 x2 : variable) : bool :=
  if variable_eq_dec x1 x2 then true else false.

Lemma variable_beq_eq : forall x1 x2, variable_beq x1 x2 = true <-> x1 = x2.
Proof.
unfold variable_beq.
intros x1 x2.
split; intro H; destruct (variable_eq_dec x1 x2); [ trivial | discriminate | trivial | tauto ].
Qed.

Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.

Definition function_beq (x1 x2 : function) : bool :=
  if function_eq_dec x1 x2 then true else false.

Lemma function_beq_eq : forall x1 x2, function_beq x1 x2 = true <-> x1 = x2.
Proof.
unfold function_beq.
intros x1 x2.
split; intro H; destruct (function_eq_dec x1 x2); [ trivial | discriminate | trivial | tauto ].
Qed.

Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Definition constructor_beq (x1 x2 : constructor) : bool :=
  if constructor_eq_dec x1 x2 then true else false.

Lemma constructor_beq_eq : forall x1 x2, constructor_beq x1 x2 = true <-> x1 = x2.
Proof.
unfold constructor_beq.
intros x1 x2.
split; intro H; destruct (constructor_eq_dec x1 x2); [ trivial | discriminate | trivial | tauto ].
Qed.

Fixpoint value_beq (v1 v2 : value) : bool :=
  match v1, v2 with
  | c_capply c lv, c_capply c' lv' => constructor_beq c c' && list_beq _ value_beq lv lv'
  end.

Lemma value_ind2 :
  forall (P : value -> Prop),
  (forall c l, (forall v, In v l -> P v) -> P (c_capply c l)) ->
  forall v, P v.
Proof.
intros P H1 v.
apply value_ind2_gen with (Q := fun l => forall v, In v l -> P v); simpl; try tauto.
clear H1 v; intros v1 l H1 H2 v2 [H3 | H3].

- subst; trivial.

- auto.
Qed.

Lemma value_beq_eq v1 v2 : value_beq v1 v2 = true <-> v1 = v2.
Proof.
revert v2.
induction v1 as [ c1 lv1 IH ] using value_ind2; simpl; intros [ c2 lv2 ].
rewrite andb_true_iff, constructor_beq_eq, list_beq_eq.

- split.

 + intros [ H1 H2 ].
    congruence.

  + intro H.
    injection H.
    tauto.

- firstorder.
Qed.

Fixpoint term_beq (t1 t2 : term) : bool :=
  match t1, t2 with
  | var x, var x' => variable_beq x x'
  | capply c lt, capply c' lt' => constructor_beq c c' && list_beq _ term_beq lt lt'
  | fapply f lt, fapply f' lt' => function_beq f f' && list_beq _ term_beq lt lt'
  | _, _ => false
  end.

Lemma term_beq_eq t1 t2 : term_beq t1 t2 = true <-> t1 = t2.
Proof.
revert t2.
induction t1 as [ x1 | c1 lt1 IH | f1 lt1 IH ] using term_ind2; simpl; intros [ x2 | c2 lt2 | f2 lt2 ];
try (split; congruence).

- rewrite variable_beq_eq.
  split; congruence.

- rewrite andb_true_iff, constructor_beq_eq, list_beq_eq.

  + split.

    * intros [ H1 H2 ].
      congruence.

    * intro H.
      split; congruence.

  + firstorder.

- rewrite andb_true_iff, function_beq_eq, list_beq_eq.

  + split.

    * intros [ H1 H2 ].
      congruence.

    * intro H.
      split; congruence.

  + firstorder.
Qed.

(* Automatic conversion of a [value] or [pattern] into a [term] *)

Fixpoint pattern_from_value (v : value) : pattern  :=
  match v with
    | c_capply c lv => p_capply c (map pattern_from_value lv)
  end.

Fixpoint term_from_value (v : value) : term :=
  match v with
  | c_capply c lc => capply c (map term_from_value lc)
  end.

Coercion term_from_value : value >-> term.

Lemma term_from_value_not_var : forall v x, ~ term_from_value v = var x.
Proof.
intros v x; destruct v; simpl; congruence.
Qed.

Lemma term_from_value_not_fapply : forall v f lt, ~ term_from_value v = fapply f lt.
Proof.
intros v x; destruct v; simpl; congruence.
Qed.

Lemma term_from_value_injective (v v': value) :
  term_from_value v = term_from_value v' -> v = v'.
Proof.
  revert v';
  induction v as [ c lv IH ] using value_ind2;
  intros v' Heq.
  destruct v' as [ c' lv' ].
  simpl in Heq.
  injection Heq;
    intros Heqlv Heqc.
  subst c'.
  f_equal.
  clear c Heq.
  assert (Hlen : length lv = length lv').
  {
    do 2 rewrite <- map_length with (f := term_from_value).
    rewrite Heqlv.
    trivial.
  }
  revert lv' Heqlv Hlen IH;
    induction lv as [ | v lv IH' ];
    intros lv' Heqlv Hlen IH;
    destruct lv' as [ | v' lv'];
    [ trivial
    | inversion Hlen
    | inversion Hlen
    | ].

  f_equal.

  - apply IH; [ now left | ].
    injection Heqlv; intros; assumption.
  - apply IH'.
    + injection Heqlv; intros; assumption.
    + injection Hlen; intros; assumption.
    + intros v'' Hin.
      apply IH.
      now right.
Qed.

Fixpoint term_from_pattern (p : pattern) : term :=
  match p with
  | p_var v => var v
  | p_capply c lp => capply c (map term_from_pattern lp)
  end.

Coercion term_from_pattern : pattern >-> term.

Lemma term_from_pattern_not_fapply : forall v f lt, ~ term_from_pattern v = fapply f lt.
Proof.
intros v x; destruct v; simpl; congruence.
Qed.

(* Doit-on définir explicitement term_value ? *)
Fixpoint term_value (t: term) : Prop :=
  match t with
    | capply _ lt => andl (map term_value lt)
    | _ => False
  end.

Lemma term_value_eqv (t: term) :
  term_value t <-> exists (v: value), t = term_from_value v.
Proof.
induction t as [ | c lt IH | ] using term_ind2.

- split.
  + intros Himp; inversion Himp.
  + intros Himp; destruct Himp as [ v Himp ]; destruct v; discriminate.

- split.
  + intros Hval.
    assert (exists lv, Forall2 (fun t v => t = term_from_value v) lt lv) as [ lv Hfor2 ].
    { apply forall_exists_list with (P := term_value).
      - intros t Hin Hvalt.
        apply IH; assumption.
      - simpl in Hval.
        apply forall_andl; assumption.
    }

    exists (c_capply c lv).
    simpl.
    f_equal.
    clear c Hval IH.
    revert lv Hfor2.
    induction lt as [ | t lt IH ]; intros lv Hfor2.
    * inversion Hfor2; tauto.
    * inversion Hfor2 as [ | Ba v Bc lv' Be Hfor2' Bg Bh ]; subst.
      simpl; f_equal.
      apply IH; assumption.

  + intros [ v Heq ].
    destruct v as [ c' lv ].
    inversion Heq; simpl; clear.
    rewrite map_map.
    induction lv as [ | v lv IH ].
    * simpl; trivial.
    * simpl.
      split; [ idtac | assumption ].
      clear IH lv.
      induction v as [ c lv ] using value_ind2.
      simpl.
      rewrite map_map.
      rewrite <- forall_andl; apply Forall_forall; assumption.

- split.
  + intros Himp; inversion Himp.
  + intros Himp; destruct Himp as [ v Himp ]; destruct v; discriminate.
Qed.

(* Well-formedness of a program *)

Fixpoint vars_of_term (t : term) : list variable :=
  match t with
  | var x => [x]
  | capply _ lt => flat_map vars_of_term lt
  | fapply _ lt => flat_map vars_of_term lt
  end.

Fixpoint vars_of_pattern (p : pattern) : list variable :=
  match p with
  | p_var x => [x]
  | p_capply _ lp => flat_map vars_of_pattern lp
  end.

Lemma vars_of_pattern_term p : vars_of_pattern p = vars_of_term (term_from_pattern p).
Proof.
induction p as [x | c lp IH] using pattern_ind2; simpl; trivial.
apply flat_map_comp; exact IH.
Qed.

Fixpoint functions_of_term (t:term) : list function :=
  match t with
    | var _       => []
    | capply _ lt => flat_map functions_of_term lt
    | fapply f lt => f :: flat_map functions_of_term lt
  end.

Fixpoint fapplies_in_term (t: term) : list term :=
  match t with
  | var _       => []
  | capply _ lt =>      flat_map fapplies_in_term lt
  | fapply _ lt => t :: flat_map fapplies_in_term lt
  end.

Lemma fapplies_in_term_are_fapplies t1 t2 :
  In t1 (fapplies_in_term t2) ->
  exists f lt, t1 = fapply f lt.
Proof.
  revert t1.
  induction t2 as [ x | c lt IH | f lt IH ] using term_ind2; intros t1 Hin;
  simpl in Hin; try tauto.
  - simpl in Hin.
    apply in_flat_map in Hin.
    destruct Hin as (t & Hinlt & Hinfapp).
    destruct (IH t Hinlt t1 Hinfapp) as (f' & lt' & Heq).
    exists f'; exists lt'; assumption.
  - simpl in Hin.
    destruct Hin as [ Heq | Hin ].
    + exists f; exists lt; symmetry; assumption.
    + apply in_flat_map in Hin.
      destruct Hin as (t & Hinlt & Hinfapp).
      destruct (IH t Hinlt t1 Hinfapp) as (f' & lt' & Heq).
      exists f'; exists lt'; assumption.
Qed.

Lemma fapplies_in_value_nil (v: value) :
  fapplies_in_term (@term_from_value v) = [].
Proof.
induction v as [ c lv IH ] using value_ind2.
simpl.
rewrite <- flat_map_comp with (h := fun x => fapplies_in_term (@term_from_value x)); trivial.

induction lv as [ | v' lv' IH' ]; trivial.
simpl.
rewrite IH, IH'; firstorder.
Qed.

Fixpoint max_arity_pattern (p : pattern) : nat :=
  match p with
  | p_var _ => 0
  | p_capply _ lp => max (length lp) (maxl (map max_arity_pattern lp))
  end.

Fixpoint max_arity_term (t : term) : nat :=
  match t with
    | var _ => 0
    | capply _ lt => max (length lt) (maxl (map max_arity_term lt))
    | fapply _ lt => max (length lt) (maxl (map max_arity_term lt))
  end.

Definition max_arity_rule (r : rule) : nat :=
  match r with
  | rule_intro _ lp t => max (max_arity_term t) (max (length lp) (maxl (map max_arity_pattern lp)))
  end.

Definition max_arity_prog (prog : list rule) : nat :=
  maxl (map max_arity_rule prog).

Definition rule_vars_defined (r : rule) : Prop :=
  match r with
  | rule_intro _ lp t => incl (vars_of_term t) (flat_map vars_of_pattern lp)
  end.

Definition wf_prog (prog : list rule) : Prop :=
  andl (map rule_vars_defined prog) /\ max_arity_prog prog <= max_arity.

Fixpoint subst (s : variable -> value)(t : term) : term :=
  match t with
  | var x => s x
  | capply c lt => capply c (map (subst s) lt)
  | fapply f lt => fapply f (map (subst s) lt)
  end.

Fixpoint psubst (s : variable -> value)(p : pattern) : value :=
  match p with
  | p_var x => s x
  | p_capply c lp => c_capply c (map (psubst s) lp)
  end.

Lemma subst_not_var : forall s t x, ~ subst s t = var x.
Proof.
intros s t x; destruct t; simpl; try congruence; apply term_from_value_not_var.
Qed.

Lemma subst_psubst s p : subst s (term_from_pattern p) = term_from_value (psubst s p).
Proof.
induction p as [ x | c lp IH1 ] using pattern_ind2; simpl; trivial.
f_equal; do 2 rewrite map_map; revert IH1; clear; intro IH1; induction lp as [ | p lp IH2]; simpl; trivial.
f_equal.

- apply IH1; simpl; tauto.

- apply IH2.
  intros; apply IH1; simpl; tauto.
Qed.

(* Sizes *)

Fixpoint value_size (v : value) : nat :=
  match v with
  | c_capply _ lv => 1 + suml (map value_size lv)
  end.

Fixpoint term_size (t : term) :=
  match t with
  | var _ => 1
  | capply _ lt => 1 + suml (map term_size lt)
  | fapply _ lt => 1 + suml (map term_size lt)
  end.

Lemma gt_term_size_O t : term_size t > 0.
Proof.
case t; intros ; simpl; apply gt_Sn_O.
Qed.

Lemma in_capply_term_size_lt c (t : term) lt :
  In t lt ->
  term_size t < term_size (capply c lt).
Proof.
simpl.
induction lt as [ | t' lt IH ]; simpl; try tauto.
intros [ H | H ].

- subst t'.
  omega.

- apply IH in H.
  omega.
Qed.

Lemma in_fapply_term_size_lt f (t : term) lt :
  In t lt ->
  term_size t < term_size (fapply f lt).
Proof.
simpl.
induction lt as [ | t' lt IH ]; simpl; try tauto.
intros [ H | H ].

- subst t'.
  omega.

- apply IH in H.
  omega.
Qed.

(* Right-hand side of a rule *)

Definition rhs_of_rule (r : rule) : term :=
  match r with rule_intro _ _ t => t end.

(* Injecte les membres gauches des règles dans les term *)
Definition lhs_of_rule (r : rule) : term :=
  match r with rule_intro f lp _ => fapply f (map term_from_pattern lp) end.

Definition max_rhs (prog : list rule) : nat :=
  maxl (map term_size (map rhs_of_rule prog)).

(* This lemma corresponds to the first four lines of the proof of Proposition 4. *)
(* Une règle bien formée contient uniquement des variables qui sont dans les motifs.

Soit un arbre de preuve bien formé et un programme.
Pour chaque activation, montrons que |rs| ≤ activation_bound p
Pour ça, calculons la taille de rs.
|rs| ≤ |r| (1+ plus grand substitut d’une variable) car |rs| contient au plus |r| variables.
(Lemme pour prouver ça)
par ailleurs « plus grand substitut d’une variable » ≤ |t| pour toutes les variables de r car :
le programme est bien formé, donc les variables de r apparaissent dans les motifs, donc la substitution
les fait correspondre à des sous-termes de t (lemme : un sous-terme a une taille inférieure ?)
*)

Lemma compatible_sizes: forall v, term_size (term_from_value v) = value_size v.
Proof.
induction v as [c lv IH] using value_ind2;
simpl; do 2 f_equal; rewrite map_map; apply map_in_ext; trivial.
Qed.

Definition max_size_image_subst (t : term) (s : variable -> value) : nat :=
  maxl (map value_size (map s (vars_of_term t))).

Lemma incl_le_max_size_image_subst :
  forall s t u,
  incl (vars_of_term t) (vars_of_term u) -> max_size_image_subst t s <= max_size_image_subst u s.
Proof.
intros s t u H_incl.
unfold max_size_image_subst.
apply incl_le_maxl.
do 2 rewrite map_map.
unfold incl.
intro size.
rewrite in_map_iff.
intro H_size_in_var_t.
destruct H_size_in_var_t as [ var [ H_var_size H_var_in_t ] ].
set (var_size := fun x : variable => value_size (s x)).
replace size with (var_size var).
apply in_map.
apply (H_incl var H_var_in_t).
Qed.

Lemma step_one: forall s t, term_size (subst s t) <= term_size t * (1 + max_size_image_subst t s).
Proof.
intros s t; induction t as [ x | c lt IH | f lt IH ] using term_ind2.

- unfold max_size_image_subst; simpl; rewrite plus_0_r; rewrite compatible_sizes; apply le_S; apply le_max_l.

- simpl; eapply le_trans with (S _).

  + apply le_n_S; rewrite map_map; apply suml_map_le; apply IH.

  + clear IH; apply le_n_S; induction lt as [ | t lt IH ]; simpl; trivial; etransitivity.

    * apply plus_le_compat_l; apply IH.

    * { clear IH; unfold max_size_image_subst; simpl; do 2 rewrite map_app; rewrite maxl_app.
      set (w := term_size t);
      set (x:= maxl (map value_size (map s (vars_of_term t))));
      set (y:= maxl (map value_size (map s (flat_map vars_of_term lt))));
      set (z := suml (map term_size lt)).
      replace (max x y + (w + z) * S (max x y)) with (w * S (max x y) + (max x y + z * S (max x y))).

      - apply plus_le_compat.

        + apply mult_le_compat_l; apply le_n_S.
          apply le_max_l.
        + apply plus_le_compat.

          * apply le_max_r.

          * apply mult_le_compat_l; apply le_n_S; apply le_max_r.

      - ring. }

- simpl; eapply le_trans with (S _).

  + apply le_n_S; rewrite map_map; apply suml_map_le; apply IH.

  + clear IH; apply le_n_S; induction lt as [ | t lt IH ]; simpl; trivial; etransitivity.

  * apply plus_le_compat_l; apply IH.

  * { clear IH; unfold max_size_image_subst; simpl; do 2 rewrite map_app; rewrite maxl_app.
    set (w := term_size t);
    set (x:= maxl (map value_size (map s (vars_of_term t))));
    set (y:= maxl (map value_size (map s (flat_map vars_of_term lt))));
    set (z := suml (map term_size lt)).
    replace (max x y + (w + z) * S (max x y)) with (w * S (max x y) + (max x y + z * S (max x y))).

    - apply plus_le_compat.

      + apply mult_le_compat_l; apply le_n_S.
        apply le_max_l.

      + apply plus_le_compat.

        * apply le_max_r.

        * apply mult_le_compat_l; apply le_n_S; apply le_max_r.

    - ring. }
Qed.

(* |r| ≤ |t|

   t match le motif, donc pour toute variable v du motif, |v sigma| ≤ |t|
   soit R la taille maximale d’une image de variable par la substitution
   donc |v sigma| ≤ R ≤ |t|

   toute variable de r est une variable du motif donc de taille ≤ |t|
   |rsig| ≤ |r|(R+1) d’après (1)
   |r| ≤ max_rhs par définition
   |rsig| ≤ max_rhs(R+1)

   |rsig| ≤ activ(|t|) pour activ = x → max_rhs(x+1)
*)

(* |xσ| ≤ |pσ| pour x ∈ p *)
Lemma size_subst_var_le_size_value:
  forall p s (x:variable) v, v = psubst s p -> In x (vars_of_pattern p) -> value_size (s x) <= value_size v.
Proof.
intros p s x.
induction p as [ x' | c lp IH ] using pattern_ind2 ; intros v H_match H_x_in_pattern.

- (* Cas de base p = x *)
  simpl in *.
  destruct H_x_in_pattern.

  + subst.
    trivial.

  + case H.

- (* Cas récursif *)
  simpl in * |-.
  subst v.
  simpl.
  (* On prouve d’abord que x dans le motif de départ implique qu’il est dans un des p de lp *)
  rewrite in_flat_map in H_x_in_pattern.
  destruct H_x_in_pattern as [ p [ H_p_in_lp H_x_in_p ] ].
  etransitivity.

  + apply IH with p; trivial.

  + rewrite map_map.
    etransitivity.

    * apply in_le_suml.
      instantiate (1 := map (fun x0 : pattern => value_size (psubst s x0)) lp).
      rewrite in_map_iff; exists p.
      split; trivial.

    * apply le_n_Sn.
Qed.

Lemma max_size_image_subst_bounded :
  forall t s, max_size_image_subst t s <= term_size (subst s t).
Proof.
intros t s; unfold max_size_image_subst; rewrite map_map;
induction t as [ x | c lt IH | f lt IH ] using term_ind2; simpl;
try (rewrite max_0_r; rewrite compatible_sizes; trivial);
(transitivity (suml (map term_size (map (subst s) lt))); [idtac | apply le_n_Sn]);
rewrite map_map; apply maxl_le_suml_map; exact IH.
Qed.

(* This definition corresponds to the r in the proof of Proposition 4. *)
Definition activation_bound (prog : list rule) : nat -> nat :=
  fun x => max_rhs prog * (1 + x).

Lemma activation_bound_monotone (prog : list rule) :
  forall x y, x <= y -> activation_bound prog x <= activation_bound prog y.
Proof.
intros x y H_le.
unfold activation_bound.
apply mult_le_compat_l.
apply le_n_S.
assumption.
Qed.

Definition nb_rhs_functions (r: rule) :=
  match r with
    | rule_intro _ _ t => length (functions_of_term t)
  end.

Definition max_nb_rhs_functions (prog : list rule) : nat :=
  maxl (map nb_rhs_functions prog).

Lemma no_func_in_pattern p:
  functions_of_term (term_from_pattern p) = [].
Proof.
induction p using pattern_ind2; simpl; auto.
apply flat_map_nil. intros.
induction l; simpl in *; try (now exfalso).
destruct H0.
- subst. apply H. auto.
- apply IHl; auto.
Qed.

Lemma no_funcs_in_patterns l:
  flat_map functions_of_term (map term_from_pattern l) = [].
Proof.
induction l; simpl; auto.
rewrite IHl. rewrite no_func_in_pattern. simpl. auto.
Qed.

End Syntax.

Arguments var [variable function constructor].

Arguments p_var [variable constructor].


From iris.bi.lib Require Import fractional.
From iris.algebra Require Import gmap cmra dfrac_agree.
From iris.base_logic Require Import mono_nat.
From iris.proofmode Require Import proofmode.

Section definitions.
Class mapG Σ K V `{Countable K} :=
  { map_inG:> inG Σ (gmapR K (dfrac_agreeR (leibnizO V)))} .

Definition mapΣ K V `{Countable K} := #[GFunctor (gmapR K (dfrac_agreeR (leibnizO V)))].
Global Instance subG_mapΣ K V `{Countable K} {Σ} : subG (mapΣ K V) Σ → (mapG Σ K V).
Proof. solve_inG. Qed.

Context `{mapG Σ K V}.

Definition ghost_map_points_to_def (γ : gname) (k : K) (dq : dfrac) (v : V) : iProp Σ :=
    own γ {[ k := (to_dfrac_agree dq (v : leibnizO V)) ]}.
Definition ghost_map_points_to_aux : seal (@ghost_map_points_to_def). Proof. by eexists. Qed.
Definition ghost_map_points_to := ghost_map_points_to_aux.(unseal).
Definition ghost_map_points_to_eq : @ghost_map_points_to = @ghost_map_points_to_def := ghost_map_points_to_aux.(seal_eq).

End definitions.

Notation "k ⤳[ γ ]{ dq } v" := (ghost_map_points_to γ k dq v)
  (at level 20, γ at level 50, dq at level 50, format "k ⤳[ γ ]{ dq }  v") : bi_scope.
Notation "k ⤳[ γ ]{# q } v" := (k ⤳[γ]{DfracOwn q} v)%I
  (at level 20, γ at level 50, q at level 50, format "k ⤳[ γ ]{# q }  v") : bi_scope.
Notation "k ⤳[ γ ] v" := (k ⤳[γ]{#1} v)%I
  (at level 20, γ at level 50, format "k  ⤳[ γ ]  v") : bi_scope.
Notation "k ⤳[ γ ]□ v" := (k ⤳[γ]{DfracDiscarded} v)%I
  (at level 20, γ at level 50) : bi_scope.

Local Ltac unseal := rewrite
  ?ghost_map_points_to_eq /ghost_map_points_to_def.

Section lemmas.
  Context `{mapG Σ K V}.
  Implicit Types (k : K) (v : V) (dq : dfrac) (q : Qp) (m : gmap K V).

  (** * Lemmas about the map points_toents *)
  Global Instance ghost_map_points_to_timeless k γ dq v : Timeless (k ⤳[γ]{dq} v).
  Proof. unseal. apply _. Qed.
  Global Instance ghost_map_points_to_persistent k γ v : Persistent (k ⤳[γ]□ v).
  Proof. unseal. apply _. Qed.
  Global Instance ghost_map_points_to_fractional k γ v : Fractional (λ q, k ⤳[γ]{#q} v)%I.
  Proof. unseal. intros p q. rewrite -own_op singleton_op -dfrac_agree_op. done. Qed.

  Global Instance ghost_map_points_to_as_fractional k γ q v :
    AsFractional (k ⤳[γ]{#q} v) (λ q, k ⤳[γ]{#q} v)%I q.
  Proof. split; first done. apply _. Qed.

  Lemma ghost_map_points_to_valid k γ dq v : k ⤳[γ]{dq} v -∗ ⌜✓ dq⌝.
  Proof.
    unseal. iIntros "Hpoints_to".
    iDestruct (own_valid with "Hpoints_to") as %Hvalid%singleton_valid.
    rewrite /to_dfrac_agree in Hvalid. by destruct Hvalid.
  Qed.
  Lemma ghost_map_points_to_valid_2 k γ dq1 dq2 v1 v2 :
    k ⤳[γ]{dq1} v1 -∗ k ⤳[γ]{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %Hvalid.
    rewrite singleton_op singleton_valid dfrac_agree_op_valid in Hvalid.
    done.
  Qed.
  Lemma ghost_map_points_to_agree k γ dq1 dq2 v1 v2 :
    k ⤳[γ]{dq1} v1 -∗ k ⤳[γ]{dq2} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hpoints_to1 Hpoints_to2".
    iDestruct (ghost_map_points_to_valid_2 with "Hpoints_to1 Hpoints_to2") as %[_ ?].
    done.
  Qed.

  Lemma ghost_map_points_to_combine k γ dq1 dq2 v1 v2 :
    k ⤳[γ]{dq1} v1 -∗ k ⤳[γ]{dq2} v2 -∗ k ⤳[γ]{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (ghost_map_points_to_agree with "Hl1 Hl2") as %->.
    unseal. iCombine "Hl1 Hl2" as "Hl".
    rewrite -dfrac_agree_op.
    iFrame.
    done.
  Qed.

  Lemma ghost_map_points_to_frac_ne γ k1 k2 dq1 dq2 v1 v2 :
    ¬ ✓ (dq1 ⋅ dq2) → k1 ⤳[γ]{dq1} v1 -∗ k2 ⤳[γ]{dq2} v2 -∗ ⌜k1 ≠ k2⌝.
  Proof.
    iIntros (?) "H1 H2"; iIntros (->).
    by iDestruct (ghost_map_points_to_valid_2 with "H1 H2") as %[??].
  Qed.
  Lemma ghost_map_points_to_ne γ k1 k2 dq2 v1 v2 :
    k1 ⤳[γ] v1 -∗ k2 ⤳[γ]{dq2} v2 -∗ ⌜k1 ≠ k2⌝.
  Proof. apply ghost_map_points_to_frac_ne. apply: exclusive_l. Qed.

  (** Make an points_toent read-only. *)
  Lemma ghost_map_points_to_persist k γ dq v :
    k ⤳[γ]{dq} v ==∗ k ⤳[γ]□ v.
  Proof. unseal. iApply own_update. apply singleton_update.
         apply dfrac_agree_persist. Qed.

  (** * Lemmas about [ghost_map_auth] *)
  Lemma ghost_map_alloc_strong P (m:gmap K V) :
    pred_infinite P →
    ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ [∗ map] k ↦ v ∈ m, k ⤳[γ] v.
  Proof.
    unseal. intros.
    iMod (own_alloc_strong (A:= (gmapR K (dfrac_agreeR (leibnizO V))))
                              (fmap (λ v, to_dfrac_agree (DfracOwn 1) (v:leibnizO V)) m) P)
      as (γ) "Hauth".
    { done. }
    { intros k.
      rewrite lookup_fmap.
      by destruct (m !! k).
    }
    iExists γ.
    iDestruct "Hauth" as "[$ Hauth]".
    rewrite -(big_opM_singletons (_ <$> m)).
    rewrite big_opM_own_1.
    rewrite big_sepM_fmap.
    iApply (big_sepM_impl with "Hauth").
    do 2 iModIntro.
    iIntros.
    iFrame.
  Qed.

  Lemma ghost_map_alloc_fin (v:V) `{!finite.Finite K} :
    ⊢ |==> ∃ γ, [∗ set] k ∈ (fin_to_set K), k ⤳[γ] v.
  Proof.
    set (m:=gset_to_gmap (K:=K) (A:=V) v (fin_to_set K)).
    iStartProof.
    iMod (ghost_map_alloc_strong (λ _, True) m) as (?) "[_ H]".
    { apply pred_infinite_True. }
    iModIntro.
    iExists γ.
    replace (fin_to_set K) with (dom m); last first.
    { apply dom_gset_to_gmap. }
    iDestruct (big_sepM_dom) as "Hm".
    iDestruct "Hm" as "[Hm1 _]".
    iApply ("Hm1" with "[H]").
    iApply (big_sepM_impl with "H").
    iModIntro.
    iIntros.
    apply lookup_gset_to_gmap_Some in H2.
    naive_solver.
  Qed.

  Lemma ghost_map_points_to_update {γ k v} w :
    k ⤳[γ] v ==∗ k ⤳[γ] w.
  Proof.
    unseal. apply own_update.
    apply singleton_update.
    apply cmra_update_exclusive.
    by constructor.
  Qed.

End lemmas.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export parallelisme_concours.
Require Export coplanarite.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma paralleles_coplanaires :
 forall A B C D : PO,
 A <> B ->
 C <> D -> paralleles (droite A B) (droite C D) -> coplanaires A B C D.
unfold coplanaires in |- *; intros A B C D H H10 H0.
elim def_paralleles2 with (3 := H0); auto.
intros k H1.
elim (classic (k = 0)); intros.
rewrite H2 in H1.
absurd (A = B); auto.
apply conversion_PP with (a := 1) (b := 1); auto with *.
RingPP1 H1.
RingPP.
right; try assumption.
exists (- / k).
exists (/ k).
apply mult_PP_regulier with k; auto.
replace
 (mult_PP k
    (add_PP (cons (- / k) A)
       (add_PP (cons (/ k) B) (cons (1 + - (- / k + / k)) C)))) with
 (add_PP (cons (-1) A) (add_PP (cons 1 B) (cons k C))).
RingPP1 H1.
RingPP.
FieldPP k.
Qed.

Lemma concours_coplanaires :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO -> concours (droite A B) (droite C D) -> coplanaires A B D C.
unfold coplanaires in |- *; intros A B C D H20 H21 H11.
elim def_concours2 with (A := A) (B := B) (C := C) (D := D);
 [ intros I H0; elim H0; intros H1 H2; try clear H0; try exact H2
 | auto
 | auto
 | auto ].
hPPalignes H2 k.
hPPalignes H1 k0.
cut
 (add_PP (cons k C) (cons (1 + - k) D) =
  add_PP (cons k0 A) (cons (1 + - k0) B)); intros.
elim (classic (k = 0)); intros.
left; try assumption.
unfold alignes, alignes1 in |- *.
right; try assumption.
rewrite H0 in H.
exists k0.
VReplace (cons 1 D) (cons (1 + -0) D).
RingPP2 H; RingPP.
right; try assumption.
exists (/ k * k0).
exists (/ k * (1 + - k0)).
apply mult_PP_regulier with k; auto.
VReplace (mult_PP k (cons 1 C)) (cons k C).
RingPP1 H.
FieldPP k.
rewrite <- H2; trivial.
Qed.

Lemma droites_non_paralleles :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 ~ paralleles (droite C D) (droite A B) ->
 concours (droite C D) (droite A B) \/ ~ coplanaires A B C D.
intros A B C D H20 H21 H; try assumption.
elim (classic (coplanaires A B C D)); intros.
left; try assumption.
hPPcoplanaires H0 a b.
apply def_concours with C; auto with geo.
cut (a + b <> 0); intros.
apply def_concours with (barycentre (cons a A) (cons b B)); auto.
replace (barycentre (cons a A) (cons b B)) with
 (barycentre (cons (- (1 + - (a + b))) C) (cons 1 D)).
apply barycentre_alignes.
replace (- (1 + - (a + b)) + 1) with (a + b); auto.
ring.
apply conversion_PP with (a := - (1 + - (a + b)) + 1) (b := a + b).
rewrite <- add_PP_barycentre; auto.
rewrite <- add_PP_barycentre; auto.
rewrite H0.
RingPP.
replace (- (1 + - (a + b)) + 1) with (a + b); auto.
ring.
replace (- (1 + - (a + b)) + 1) with (a + b); auto.
ring.
ring.
apply barycentre_alignes; auto.
unfold not in |- *; intros; apply H.
apply def_paralleles with (- a); auto.
rewrite H0.
rewrite H1.
replace b with (- a + (a + b)); auto.
rewrite H1.
RingPP.
ring.
right; try assumption.
Qed.

Lemma concours_sym :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 concours (droite A B) (droite C D) -> concours (droite C D) (droite A B).
intros A B C D H10 H11 H; try assumption.
elim def_concours2 with (3 := H); auto; intros.
apply def_concours with x; auto.
elim H0; intros H1 H2; try clear H0; try exact H2.
elim H0; intros H1 H2; try clear H0; try exact H1.
Qed.
#[export] Hint Resolve concours_sym paralleles_sym paralleles_trans: geo.

Theorem position_relative_droites_espace :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 ~ coplanaires A B C D \/
 concours (droite A B) (droite C D) \/ paralleles (droite A B) (droite C D).
intros A B C D H10 H; try assumption.
elim (classic (paralleles (droite A B) (droite C D))); intros.
right; right; try assumption.
elim droites_non_paralleles with (A := A) (B := B) (C := C) (D := D);
 auto with geo; intros.
Qed.

Theorem position_relative_droites_coplanaires :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 coplanaires A B C D ->
 concours (droite A B) (droite C D) \/ paralleles (droite A B) (droite C D).
intros A B C D H10 H H0; try assumption.
elim
 position_relative_droites_espace with (A := A) (B := B) (C := C) (D := D);
 [ intros H1; try clear position_relative_droites_espace
 | intros H1; try clear position_relative_droites_espace; auto
 | auto
 | auto ].
absurd (coplanaires A B C D); auto.
Qed.


From Coq Require Import
     String List Arith ZArith
     extraction.ExtrOcamlIntConv.
Import ListNotations.

From ExtLib.Structures Require Import
     Monad MonadFix.

From SimpleIO Require SimpleIO.

From advent Require Import lib sol.day16_common.

Module Import DB.
Import SimpleIO.
(* TODO send to simple-io. *)
Definition debug_switch := false. (* Switch this to [true] for debug
                                     output. *)
Parameter debug' : forall {A}, ocaml_string -> ocaml_string -> A -> A.
Extract Constant debug' => "fun s n x -> Printf.printf ""%s: %s\n"" s n; x".
Definition debug : forall {A}, string -> string -> A -> A :=
  fun _ s n =>
    if debug_switch then debug' (to_ostring s) (to_ostring s)
    else fun x => x.
End DB.

Section main.

Import MonadNotation.
Local Open Scope monad_scope.

Definition sample_ (regs : Type) : Type :=
  regs * Z * Z * Z * regs.

Definition sample : Type := sample_ regs.

Context {m : Type -> Type} `{Monad m} `{MonadFix m}
        `{FoldRead sample m} `{MonadO N m}.

Definition plausibles : sample -> list op :=
  fun '(rs, a, b, c, rs') =>
    filter
      (fun o =>
         let is := (o, a, b, c) in
         let b := (wf is && eqb_reg (interp is rs) rs')%bool in
         debug (if b then "Y" else "N") (show_op o) b
      )
      all_ops.

Definition count_3plausibles : m N :=
  fold_read
    (fun n s =>
      if 3 <=? length (plausibles s) then (1 + n)%N else n%N
    ) 0%N.

Definition main : m unit := (count_3plausibles >>= print).

End main.

Import SimpleIO.

Parameter parse_sample : forall {regs},
    (int -> int -> int -> int -> regs) ->
    (int -> Z) ->
    IO (option (sample_ regs)).
Extract Constant parse_sample => "
  fun regs z k ->
    k (try
      Scanf.scanf
        ""Before: [%d, %d, %d, %d] %_d %d %d %d After: [%d, %d, %d, %d] ""
        (fun r0 r1 r2 r3 a b c s0 s1 s2 s3 ->
          Some ((((regs r0 r1 r2 r3, z a), z b), z c), regs s0 s1 s2 s3))     with Scanf.Scan_failure _ | End_of_file -> None
    )".

Definition read_sample : IO (option sample) :=
  let z := z_of_int in
  let Regs' r0 r1 r2 r3 := Regs (z r0) (z r1) (z r2) (z r3) in
  parse_sample Regs' z.

Local Instance MonadI_sample_IO : MonadI sample IO :=
  read_sample.

Definition exe : io_unit := IO.unsafe_run main.
Extraction "day16_1.ml" exe.