From iris Require Export base.
From stdpp Require Export base list sets mapset.
From stdpp Require Export base.
(* fhin_sets fin_maps. *)
From Autosubst Require Export Autosubst.
Require Export Utf8_core.
From fae_gtlc_mu.cast_calculus Require Import types.

Lemma map_union {A B} (l k : listset A) (f : A → B) : f <$> (l ∪ k) ≡ (f <$> l) ∪ (f <$> k).
Proof. set_solver. Qed.

Lemma map_singleton {A B} (a : A) (f : A → B) : (f <$> ({[ a ]} : listset A)) ≡ {[ (f a) ]}.
Proof. set_solver. Qed.

Lemma set_Forall_fmap_ext_1 (f g : type → type) (X : listset type) :
  set_Forall (λ x : type, f x = g x) X → f <$> X ≡ g <$> X.
Proof.
  intro.
  apply set_subseteq_antisymm.
  + intros τ Hτ.
    destruct (elem_of_fmap_1 _ _ _ Hτ) as [τ' [-> pin]].
    assert (Heq : f τ' = g τ'). apply H. apply  pin. rewrite Heq.
      by apply elem_of_fmap_2.
  + intros τ Hτ.
    destruct (elem_of_fmap_1 _ _ _ Hτ) as [τ' [-> pin]].
    assert (Heq : f τ' = g τ'). apply H. apply  pin. rewrite -Heq.
      by apply elem_of_fmap_2.
Qed.

Lemma set_Forall_subseteq (X Y : listset type) (P : type → Prop) :
  X ⊆ Y → set_Forall P Y → set_Forall P X.
Proof. intros. intros τ Hτ. apply H0. set_solver. Qed.

Lemma fmap_listset_id (X : listset type) :
  id <$> X ≡ X.
Proof. set_solver. Qed.

Lemma set_Forall_fmap_impl (f : type → type) (X : listset type) (P Q : type → Prop)
      (Himpl : forall τ : type, P τ → Q (f τ)) (HP : set_Forall P X) : set_Forall Q (f <$> X).
Proof.
  intros τ Hτ.
  destruct (elem_of_fmap_1 _ _ _ Hτ) as [τ' [-> pin]].
  apply Himpl. by apply HP.
Qed.

Definition listset_prod {A B : Type} (k : listset A) (l : listset B) : listset (A * B) :=
  Listset $ list_prod (listset_car k) (listset_car l).

Lemma in_listset_prod_iff {A B : Type} (l : listset A) (l' : listset B) (x : A) (y : B) :
  (x, y) ∈ (listset_prod l l') ↔ x ∈ l ∧ y ∈ l'.
Proof.
  rewrite /elem_of /listset_elem_of. do 3 rewrite elem_of_list_In.
  simpl. apply in_prod_iff.
Qed.

Lemma listset_prod_subseteq {A : Type} (k k' l l' : listset A) :
  k ⊆ k' → l ⊆ l' → listset_prod k l ⊆ listset_prod k' l'.
Proof.
  intros. intros (x , y) Hxy. apply in_listset_prod_iff.
  cut (x ∈ k ∧ y ∈ l). set_solver.
  by apply in_listset_prod_iff.
Qed.


Require Import Explicit_sub.
Require Import FOTheory.
Require Import basic Omega.

Import BuildModel.
Import T J R.
Import CCM.
Import ZFind_basic.
Import ZFnats.

Fixpoint int_fotrm t:=
  match t with
  | Var i => Ref i
  | Cst_0 => Zero
  | Cst_1 => Succ Zero
  | Df_Add u v => Add (int_fotrm u) (int_fotrm v)
  end.

Fixpoint int_fofml f:=
  match f with
  | eq_fotrm x y => EQ_trm (int_fotrm x) (int_fotrm y)
  | TF => True_symb
  | BF => False_symb
  | neg f => Neg (int_fofml f)
  | conj f1 f2 => Conj (int_fofml f1) (int_fofml f2)
  | disj f1 f2 => Disj (int_fofml f1) (int_fofml f2)
  | implf f1 f2 => Impl (int_fofml f1) (int_fofml f2)
  | fall f => Fall (int_fofml f)
  | exst f => Exst (int_fofml f)
  end.

Fixpoint int_hyp_rec hyp:=
  match hyp with
  | nil => nil
  | h::hyp' =>
    match h with
    | Some f => (int_fofml f)::(int_hyp_rec hyp')
    | None => T :: (int_hyp_rec hyp')
    end
  end.

Definition int_hyp hyp:= (int_hyp_rec hyp).

Lemma fotrm_Some : forall t, int_fotrm t <> None.
destruct t; simpl; red; intros; discriminate.
Qed.

Lemma fofml_Some : forall f, int_fofml f <> None.
destruct f; simpl; red; intros; discriminate.
Qed.

Lemma int_hyp_nth_fml : forall hyp f n, nth_error hyp n = Some (Some f) ->
  nth_error (int_hyp hyp) n = Some (int_fofml f).
induction hyp; destruct n; simpl; intros; [discriminate | discriminate |
 injection H; intro Hinj; rewrite Hinj |]; trivial.

 destruct a; simpl; apply IHhyp; trivial.
Qed.

Lemma int_hyp_nth_trm : forall hyp n,
  nth_error hyp n = value None ->
  nth_error (int_hyp hyp) n = value T.
induction hyp; destruct n; simpl; intros; try discriminate.
 destruct a; [discriminate | trivial].
 destruct a; apply IHhyp; trivial.
Qed.

Lemma int_trm_N : forall hyp t i, hyp_ok hyp t ->
  val_ok (int_hyp hyp) i ->
  int (int_fotrm t) i ∈ N.
unfold hyp_ok; unfold val_ok; induction t; simpl in *; intros.
 assert (n=n\/False). left; trivial.
 specialize H with (n0:=n) (1:=H1).
 generalize (int_hyp_nth_trm _ _ H); intros.
 specialize H0 with (1:=H2). simpl in H0; trivial.

 apply zero_typ.

 apply succ_typ. apply zero_typ.

 replace (fun k : nat => i k) with i; trivial.
 assert (int (int_fotrm t2) i ∈ N).
  apply IHt2; trivial; intros.
   apply H. apply in_or_app. right; trivial.
 elim H1 using N_ind; intros.
  revert H4; apply in_set_morph; try reflexivity.
   apply natrec_morph; try reflexivity.
    do 2 red; intros. rewrite H5; reflexivity.

    symmetry; trivial.

  rewrite add0. apply IHt1; trivial; intros.
   apply H. apply in_or_app; left; trivial.

  rewrite addS;trivial.
   apply succ_typ; trivial.
Qed.

Lemma lift_int_lift_trm_rec : forall t n k,
  eq_term (lift_rec n k (int_fotrm t))
          (int_fotrm (lift_trm_rec t n k)).
induction t; simpl; intros.
 unfold V.lams. unfold V.shift.
 destruct (Compare_dec.le_gt_dec k n); simpl; intros.
  replace (k+(n0+(n-k))) with (n+n0) by omega.
  red; auto.

  red; auto.

 red; reflexivity.

 red; intros. apply succ_morph. reflexivity.

 red; intros. apply natrec_morph; try rewrite H.
  rewrite <- IHt1. rewrite int_lift_rec_eq. reflexivity.

  do 2 red. intros x0 y0 H' x1 y1 HE; rewrite HE; reflexivity.

  rewrite <- IHt2. rewrite int_lift_rec_eq. reflexivity.
Qed.

Lemma lift_int_lift_trm : forall t n,
  eq_term (lift n (int_fotrm t)) (int_fotrm (lift_trm t n)).
unfold lift, lift_trm. intros. apply lift_int_lift_trm_rec.
Qed.

Lemma lift_int_lift_fml_rec : forall f n k,
  eq_term (lift_rec n k (int_fofml f))
          (int_fofml (lift_fml_rec f n k)).
induction f; red; simpl; red; intros; try reflexivity.
 apply subset_morph; try reflexivity.
  red; intros. do 2 rewrite <- lift_int_lift_trm_rec.
  do 2 rewrite <- int_lift_rec_eq. rewrite H; reflexivity.

 apply prod_ext.
  rewrite <- IHf. symmetry. rewrite H. apply int_lift_rec_eq.

  red. reflexivity.

 apply subset_morph; try red; intros;
   rewrite <- IHf1; rewrite <- IHf2; rewrite H.
  apply union_morph.
  apply pair_morph; symmetry; apply int_lift_rec_eq.

  do 2 rewrite int_lift_rec_eq. reflexivity.

 apply union2_morph; rewrite H;
   [rewrite <- IHf1 | rewrite <- IHf2]; symmetry;
     apply int_lift_rec_eq.

 apply prod_ext; try red; intros;
   [rewrite <- IHf1 | rewrite <- IHf2]; rewrite H;
     symmetry; apply int_lift_rec_eq.

 apply prod_ext; try reflexivity.
  red; intros. rewrite <- IHf. rewrite V.cons_lams.
   rewrite int_lift_rec_eq. rewrite H1. rewrite H. reflexivity.

   do 2 red. intros. rewrite H2. reflexivity.

 apply union_morph. apply replf_morph; try reflexivity.
  red. intros. rewrite <- IHf. rewrite int_lift_rec_eq.
  rewrite V.cons_lams.
   rewrite H; rewrite H1; reflexivity.

   do 2 red; intros. rewrite H2. reflexivity.
Qed.

Lemma lift_int_lift_fml : forall f n,
  eq_term (lift n (int_fofml f)) (int_fofml (lift_fml f n)).
unfold lift, lift_fml; intros. apply lift_int_lift_fml_rec.
Qed.

Lemma subst_int_subst_trm_rec : forall t N k,
  eq_term (subst_rec (int_fotrm N) k (int_fotrm t))
  (int_fotrm (subst_trm_rec t N k)).
induction t; intros.

 do 2 red; simpl.
 destruct (Compare_dec.lt_eq_lt_dec k n) as [[fv|eqv]|bv]; simpl.
  unfold V.lams, V.shift; destruct (Compare_dec.le_gt_dec k n);
  try (apply False_ind; omega; fail).
  replace (n-k) with (S(Peano.pred n-k)) by omega; simpl.
  replace (k+(Peano.pred n-k)) with (Peano.pred n) by omega;
    red; auto.

  case_eq (int_fotrm (lift_trm N k)); intros.
   red; intros. subst k. unfold V.lams; simpl.
   destruct (Compare_dec.le_gt_dec n n).
    replace (n-n) with 0 by omega; simpl. rewrite H0.
    setoid_replace (V.shift n y) with (V.lams 0 (V.shift n) y).
     rewrite <- int_lift_rec_eq. fold (lift n (int_fotrm N)).
     rewrite lift_int_lift_trm. rewrite H. simpl. reflexivity.

     rewrite V.lams0; reflexivity.

    apply False_ind; omega.

   elim fotrm_Some with (1:=H).

  do 2 red; intros. rewrite V.lams_bv; trivial. apply H.

 do 2 red. simpl. do 2 red. reflexivity.

 do 2 red; simpl; intros. do 2 red. intros.
 apply succ_morph. reflexivity.

 do 2 red; simpl; intros. do 2 red; intros. apply natrec_morph.
  rewrite <- IHt1. rewrite H.
  rewrite int_subst_rec_eq; reflexivity.

  do 2 red; intros. rewrite H1; reflexivity.

  rewrite <- IHt2. rewrite H.
  rewrite int_subst_rec_eq; reflexivity.
Qed.

Lemma subst_int_subst_trm : forall t N,
  eq_term (subst (int_fotrm N) (int_fotrm t))
          (int_fotrm (subst_trm t N)).
unfold subst. intros. apply subst_int_subst_trm_rec with (k:=0).
Qed.

Lemma subst_int_subst_fml_rec : forall f N k,
  eq_term (subst_rec (int_fotrm N) k (int_fofml f))
          (int_fofml (subst_fml f N k)).
induction f; do 2 red; simpl; intros.
 do 2 red; intros. apply subset_morph; try reflexivity.
  red; intros. do 2 rewrite <- subst_int_subst_trm_rec.
  do 2 rewrite int_subst_rec_eq. rewrite H; reflexivity.

 do 2 red; reflexivity.

 do 2 red; reflexivity.

 do 2 red; intros. apply prod_ext.
  rewrite <- IHf. rewrite int_subst_rec_eq. rewrite H; reflexivity.

  red; reflexivity.

 do 2 red; intros. apply subset_morph.
  apply union2_morph; [rewrite <- IHf1 | rewrite <- IHf2];
  rewrite int_subst_rec_eq; rewrite H; reflexivity.

  red; intros. rewrite <- IHf1; rewrite <- IHf2.
  do 2 rewrite <- int_subst_rec_eq. rewrite H. reflexivity.

 do 2 red; intros.
 apply union2_morph; [rewrite <- IHf1 | rewrite <- IHf2];
   rewrite int_subst_rec_eq; rewrite H; reflexivity.

 red; intros. apply prod_ext.
  rewrite H. rewrite <- IHf1.
  rewrite int_subst_rec_eq; reflexivity.

  red; intros. rewrite <- IHf2.
  rewrite <- int_subst_rec_eq. rewrite H; reflexivity.

 red; intros. rewrite prod_ext; try reflexivity.
  red; intros. rewrite <- IHf. rewrite V.cons_lams.
   rewrite int_subst_rec_eq. rewrite H. rewrite V.shiftS_split.
   rewrite V.shift_cons. rewrite H1. reflexivity.

   do 4 red; intros. rewrite H2; reflexivity.

 do 2 red; intros. apply union_morph.
 apply replf_morph; try reflexivity.
  red; intros. rewrite <- IHf. rewrite int_subst_rec_eq.
   rewrite V.cons_lams. rewrite V.shiftS_split.
   rewrite V.shift_cons. rewrite H1; rewrite H. reflexivity.

   do 4 red; intros. rewrite H2; reflexivity.
Qed.

Lemma subst_int_subst_fml : forall f N,
  eq_term (subst (int_fotrm N) (int_fofml f))
          (int_fofml (subst_fml0 f N)).
unfold subst; intros; apply subst_int_subst_fml_rec.
Qed.

Lemma fofml_in_props : forall f e,
  typ e (int_fofml f) prop.
induction f; do 2 red; simpl; intros; unfold props;
unfold ZFcoc.props; rewrite power_ax; intros; trivial.
 unfold EQ in H0. unfold cond_set in H0.
 rewrite subset_ax in H0. destruct H0; trivial.

 apply empty_ax in H0; contradiction.

 revert y H0. rewrite <- power_ax. apply impredicative_prod.
  do 2 red; reflexivity.

  unfold props; unfold ZFcoc.props; intros.
  rewrite power_ax; intros.
  apply empty_ax in H1; contradiction.

 do 2 red in IHf1; simpl in IHf1.
 rewrite subset_ax in H0. destruct H0. destruct H1. destruct H2.
 rewrite H1. clear H1 H3. revert x H2. rewrite <- power_ax.
 fold ZFcoc.props. fold props. apply IHf1 with (e:=e); trivial.

 apply union2_elim in H0. destruct H0; revert y H0;
 rewrite <- power_ax; fold ZFcoc.props; fold props;
     [do 2 red in IHf1; simpl in IHf1; apply IHf1 with (e:=e)
       | do 2 red in IHf1; simpl in IHf1; apply IHf2 with (e:=e)];
     trivial.

 revert y H0. rewrite <- power_ax. apply impredicative_prod.
  do 2 red; reflexivity.

  intros. do 2 red in IHf2; simpl in IHf2;
  apply IHf2 with (e:=e); trivial.

 revert y H0. rewrite <- power_ax. apply impredicative_prod.
  do 2 red. intros y1 y2 Hy1N H0; rewrite H0; reflexivity.

  intros. do 2 red in IHf; simpl in IHf;
  apply IHf with (e:=(T::e)).
  apply vcons_add_var; simpl; trivial.

 apply union_elim in H0. destruct H0.
 apply replf_elim in H1.
  destruct H1. revert y H0. rewrite <- power_ax. rewrite H2.
  do 2 red in IHf; simpl in IHf; apply IHf with (e:=(T::e)).
   apply vcons_add_var; simpl; trivial.

  do 2 red. intros. rewrite H3; reflexivity.
Qed.

Lemma P_ax_intro5_ex : forall P, eq_term
  (Impl (int_fofml (subst_fml0 P Cst_0)) (Impl (Fall (Impl (int_fofml P)
    (int_fofml (subst_fml0 (lift_fml_rec P 1 1) (Df_Add (Var 0) Cst_1)))))
  (Fall (int_fofml P))))
  (Impl (subst Zero (int_fofml P))
    (Impl (Fall (Impl (int_fofml P)
      (subst (Add (Ref 0) (Succ Zero)) (lift_rec 1 1 (int_fofml P)))))
    (Fall (int_fofml P)))).
red; simpl; red; intros.
apply prod_ext.
 rewrite <- subst_int_subst_fml; simpl. rewrite H; reflexivity.

 red; intros. apply prod_ext.
  apply prod_ext; try reflexivity.
   red; intros. apply prod_ext.
    apply int_morph; try reflexivity.
     replace (fun k : nat => V.cons y0 (fun k0 : nat => x k0) k)
       with (V.cons y0 x); trivial.
     rewrite H3, H. reflexivity.

     red; intros. rewrite <- subst_int_subst_fml. simpl.
     do 2 rewrite int_subst_eq. rewrite <- lift_int_lift_fml_rec.
     replace (fun k : nat => V.cons y0 (fun k0 : nat => x k0) k) with
       (V.cons y0 x); trivial.
     replace (fun k : nat => V.cons y3 (fun k0 : nat => y k0) k) with
       (V.cons y3 y); trivial.
     rewrite H. rewrite H3. reflexivity.

   red; intros. apply prod_ext; try reflexivity.
    red; intros. rewrite H5.
    replace (fun k : nat => x k) with x; trivial.
    replace (fun k : nat => y k) with y; trivial.
    rewrite H; reflexivity.
Qed.

Lemma int_correct : forall hyp P, deriv hyp P ->
  exists p, typ ((int_hyp hyp)) p (int_fofml P).
induction 1; simpl.
(*hyp*)
 exists (Ref n); red; simpl; intros. unfold val_ok in H0.
 rewrite <- lift_int_lift_fml. apply H0. apply int_hyp_nth_fml; trivial.

(*ax_intro*)
destruct H.
 rewrite H; simpl. apply P_ax_intro1.

 destruct H.
  rewrite H; simpl. apply P_ax_intro2.

  destruct H.
   rewrite H; simpl. apply P_ax_intro3.

   destruct H.
    rewrite H; simpl. apply P_ax_intro4.

    destruct H; rewrite H. generalize P_ax_intro5; intros.
     specialize H0 with (e:=(int_hyp hyp)) (1:=(fofml_Some x)).
     destruct H0. exists x0. simpl. rewrite P_ax_intro5_ex; trivial.

(*true_intro*)
 apply True_symb_intro.

(*false_elim*)
 apply False_symb_elim. simpl in IHderiv. trivial.

(*neg_intro*)
 destruct IHderiv as (p, IH). exists p.
 apply Neg_intro. trivial.

(*neg_elim*)
 destruct IHderiv. exists x. apply Neg_elim. trivial.

(*conj_intro*)
 destruct IHderiv1 as (x, IH1).
 destruct IHderiv2 as (x', IH2).
 exists x.
 apply Conj_intro; try apply fofml_Some. split; trivial.
  do 2 red; intros. case_eq (int_fofml f2); intros; trivial.
   assert (int x i == int x' i).
    generalize (proof_irr _ _ _  (fofml_Some f1) IH1
    (fofml_in_props f1 (int_hyp hyp))); intros. specialize H3 with (1:=H1).
    generalize (proof_irr _ _ _  (fofml_Some f2) IH2
    (fofml_in_props f2 (int_hyp hyp))); intros. specialize H4 with (1:=H1).
    rewrite H3, H4; reflexivity.
   rewrite H3. do 2 red in IH2. rewrite H2 in IH2.
   apply IH2; trivial.

(*conj_elim1*)
destruct IHderiv. exists x. simpl in H0. apply Conj_elim in H0.
 destruct H0; trivial.

 apply fofml_Some.

 apply fofml_Some.

(*conj_elim2*)
destruct IHderiv. exists x. simpl in H0. apply Conj_elim in H0.
 destruct H0; trivial.

 apply fofml_Some.

 apply fofml_Some.

(*disj_intro1*)
 destruct IHderiv. exists x.
 apply Disj_intro; try apply fofml_Some.
 left; trivial.

(*disj_intro2*)
 destruct IHderiv. exists x.
 apply Disj_intro; try apply fofml_Some.
 right; trivial.

(*disj_elim*)
 destruct IHderiv1, IHderiv2, IHderiv3.
 exists prf_term. simpl in H2, H3, H4.
 apply Disj_elim with (t:=x) (t1:=x0) (t2:=x1)
   (A:=int_fofml f1) (B:=int_fofml f2); try rewrite lift_int_lift_fml; trivial.
  apply fofml_Some.

  apply fofml_in_props.

(*impl_intro*)
 destruct IHderiv. simpl in H0.
 exists (Abs (int_fofml f1) x).
 apply Impl_intro; try apply fofml_Some.
 rewrite lift_int_lift_fml; trivial.

(*impl_elim*)
 destruct IHderiv1, IHderiv2. exists (App x x0).
 apply Impl_elim with (A:=int_fofml f1); try apply fofml_Some; trivial.

(*fall_intro*)
 destruct IHderiv. simpl in H0.
 exists ((Abs T x)). apply Fall_intro; try apply fofml_Some; trivial.

(*fall_elim*)
 destruct IHderiv. exists (App x (int_fotrm u)).
 rewrite <- subst_int_subst_fml.
 apply Fall_elim; try apply fofml_Some; trivial.
  do 2 red; simpl; intros. apply int_trm_N with (hyp:=hyp); trivial.

(*exst_intro*)
 destruct IHderiv; simpl in H0.
 exists x. apply Exst_intro with (a:=(int_fotrm N)); try apply fofml_Some.
  do 2 red; simpl; intros. apply int_trm_N with (hyp:=hyp); trivial.

  do 2 red; intros. do 2 red in H1; specialize H1 with (1:=H2).
  case_eq (subst (int_fotrm N) (int_fofml f)); intros.
   rewrite <- H3. case_eq (int_fofml (subst_fml0 f N)); intros.
    rewrite H4 in H1; rewrite <- H4 in H1.
    rewrite subst_int_subst_fml; trivial.

    elim fofml_Some with (f:=(subst_fml0 f N)); trivial.

  elim subst_Some with (t:=(int_fofml f)) (a:=(int_fotrm N));
  [apply fofml_Some |  trivial ].

(*exst_elim*)
destruct IHderiv1, IHderiv2. simpl in H1, H2.
exists prf_term. apply Exst_elim with (t1:=x) (t2:=x0) (A:=int_fofml f); trivial.
 apply fofml_Some.

 apply fofml_in_props.

 rewrite lift_int_lift_fml; trivial.
Qed.

Fixpoint const_env n :=
  match n with
    | 0 => T :: nil
    | S m => T :: (const_env m)
  end.

Lemma const_env_spec : forall m n t,
  nth_error (const_env n) m = value t ->
  (m <= n)%nat /\ t = T.
induction m; destruct n; simpl; intros.
 injection H; intros; split; [|subst t]; trivial.

 injection H; intros; split; [omega |subst t]; trivial.

 destruct m; simpl in H; discriminate.

 specialize IHm with (1:=H). destruct IHm.
 split; [omega | trivial].
Qed.

Lemma eq_ext : forall e t1 t2 s s',
  eq_typ (const_env (Peano.max (max_var t1) (max_var t2)))
  (int_fotrm t1) (int_fotrm t2) ->
  eq_fosub (S (Peano.max (max_var t1) (max_var t2))) e s s' ->
  eq_typ e (app_esub s (int_fotrm t1)) (app_esub s' (int_fotrm t2)).
do 2 red; simpl; intros.
do 2 red in H; simpl.
unfold eq_fosub in H0.
assert (val_ok (const_env (Peano.max (max_var t1) (max_var t2))) (esub_conv s i)).
 unfold val_ok. do 2 red; intros. apply const_env_spec in H2.
 destruct H2; subst T; simpl.
 assert (n < S (Peano.max (max_var t1) (max_var t2)))%nat by omega.
 specialize H0 with (1:=H3); destruct H0 as (Heqtyp, (Htyps, Htyps')).
 do 2 red in Htyps; simpl in Htyps; specialize Htyps with (1:=H1). apply Htyps.

specialize H with (1:=H2). rewrite H.
replace (fun k : nat => i k) with i; trivial. clear H H2.

induction t2; simpl; try reflexivity.
 specialize H0 with (n0:=n). destruct H0.
  rewrite succ_max_distr. apply max_split2. unfold max_var; simpl; omega.
  do 2 red in H; simpl in H; apply H; trivial.

 apply natrec_morph.
  apply IHt2_1. intros. apply H0.
  rewrite succ_max_distr. rewrite succ_max_distr in H.
  apply max_comb in H. destruct H.
   apply max_split1; trivial.

   apply max_split2. unfold max_var; simpl.
   rewrite succ_max_distr. apply max_split1. trivial.

  do 2 red; intros. rewrite H2; reflexivity.

  apply IHt2_2. intros. apply H0.
  rewrite succ_max_distr. rewrite succ_max_distr in H.
  apply max_comb in H. destruct H.
   apply max_split1; trivial.

   apply max_split2. unfold max_var; simpl.
   rewrite succ_max_distr. apply max_split2. trivial.
Qed.


(* ******************************************************************************* *)
(** * Bicategories
    Benedikt Ahrens, Marco Maggesi
    February 2018
 ********************************************************************************* *)

(* ========================================================================= *)
(* Every (pre)bicategory of UniMath.Bicategories.WkCatEnrichment is a      *)
(* (pre)bicategory of UniMath.Bicategories.Core.Bicat.             *)
(* ========================================================================= *)

(* Note: an equivalence is established in WkCatEnrichment/hcomp_bicat.v *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.HorizontalComposition.

Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory.
Require Import UniMath.Bicategories.WkCatEnrichment.whiskering.

Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.WkCatEnrichment.Notations.

Local Open Scope cat.

(* ------------------------------------------------------------------------- *)
(* Missing lemmas.                                                           *)
(* ------------------------------------------------------------------------- *)

Lemma whisker_left_left {C : prebicategory} {a b c d : C}
      (f : a -1-> b) (g : b -1-> c) {h i : c -1-> d} (x : h -2-> i) :
  whisker_left f (whisker_left g x) ;v; associator_2mor f g i =
  associator_2mor f g h ;v; whisker_left (f ;1; g) x.
Proof.
  unfold whisker_left.
  etrans; [ apply associator_naturality | idtac].
  apply maponpaths.
  apply maponpaths_2.
  exact horizontal_comp_id.
Defined.

Lemma whisker_left_right {C : prebicategory} {a b c d : C}
      (f : a -1-> b) (g h : b -1-> c) (i : c -1-> d) (x : g -2-> h) :
  whisker_left f (whisker_right x i) ;v; associator_2mor f h i =
  associator_2mor f g i ;v; whisker_right (whisker_left f x) i.
Proof.
  exact (associator_naturality (identity f) x (identity i)).
Defined.

Lemma whisker_right_right {C : prebicategory} {a b c d : C}
      (f g : a -1-> b) (h : b -1-> c) (i : c -1-> d) (x : f -2-> g) :
  associator_2mor f h i ;v; whisker_right (whisker_right x h) i =
  whisker_right x (h ;1; i) ;v; associator_2mor g h i.
Proof.
  unfold whisker_right.
  etrans; [ apply pathsinv0, associator_naturality | idtac].
  apply maponpaths_2, maponpaths.
  exact horizontal_comp_id.
Defined.

(* ------------------------------------------------------------------------- *)
(* From bicategory structure to bicat structure.                             *)
(* ------------------------------------------------------------------------- *)

Section unfold_data.

Variable C : prebicategory.

Definition bcat_precategory_ob_mor : precategory_ob_mor.
Proof.
  exists C. exact (λ a b, homcat a b).
Defined.

Definition bcat_cell_struct : prebicat_2cell_struct bcat_precategory_ob_mor
  := λ (a b : C) (f g : homcat a b), (homcat a b) ⟦ f, g ⟧.

Definition bcat_ob_mor_cells : ∑ (C : precategory_ob_mor), prebicat_2cell_struct C.
Proof.
  exists bcat_precategory_ob_mor. exact bcat_cell_struct.
Defined.

Definition bcat_1_id_comp_cells : prebicat_1_id_comp_cells.
Proof.
  use tpair.
  - exists bcat_precategory_ob_mor.
    use tpair.
    + simpl. intros. exact (identity1 _).
    + simpl. intros a b c f g. exact (compose1 f g).
  - exact bcat_cell_struct.
Defined.

(*
Definition bcat_cells_1_id_comp : ∑ C : prebicat_ob_mor_cells, precategory_id_comp C.
Proof.
  exists bcat_ob_mor_cells. split.
  - simpl. intros. exact (identity1 _).
  - simpl. intros a b c f g. exact (compose1 f g).
Defined.
 *)

Definition bcat_2_id_comp_struct : prebicat_2_id_comp_struct bcat_1_id_comp_cells.
Proof.
  repeat split; simpl; unfold bcat_cell_struct.
  - (* 2-unit *)
    intros. exact (identity _).
  - (* left unitor *)
    intros. exact (left_unitor f).
  - (* right unitor *)
    intros. exact (right_unitor f).
  - (* left inverse unitor *)
    intros. exact (inv_from_z_iso (left_unitor f)).
  - (* right inverse unitor *)
    intros. exact (inv_from_z_iso (right_unitor f)).
  - (* right associator *)
    intros. exact (inv_from_z_iso (associator f g h)).
  - (* left associator *)
    intros. exact (associator_2mor f g h).
  - (* vertical composition *)
    intros a b f g h x y. exact (x · y).
  - (* left whiskering *)
    intros a b c f g1 g2 x. exact (whisker_left f x).
  - (* right whiskering *)
    intros a b c f1 f2 g x. exact (whisker_right x g).
Defined.

Definition bcat_data : ∑ C, prebicat_2_id_comp_struct C.
Proof.
  exists bcat_1_id_comp_cells. exact bcat_2_id_comp_struct.
Defined.

Theorem bcat_laws : prebicat_laws bcat_data.
Proof.
  repeat split;
  unfold id2, vcomp2, runitor, lunitor, rinvunitor, linvunitor,
         rassociator, lassociator, lwhisker, rwhisker;
  simpl;
  unfold bcat_precategory_ob_mor, bcat_cell_struct, bcat_ob_mor_cells,
         bcat_1_id_comp_cells, bcat_2_id_comp_struct, bcat_data;
  simpl;
  first [ intros until 1 | intros ].
  - (* 1a id2_left *)
    apply id_left.
  - (* 1b id2_right *)
    apply id_right.
  - (* 2 vassocr *)
    apply assoc.
  - (* 3a lwhisker_id2 *)
    apply whisker_left_id_2mor.
  - (* 3b id2_rwhisker *)
    apply whisker_right_id_2mor.
  - (* 4 lwhisker_vcomp *)
    apply pathsinv0, whisker_left_on_comp.
  - (* 5 rwhisker_vcomp *)
    apply pathsinv0, whisker_right_on_comp.
  - (* 6  vcomp_lunitor *)
    apply left_unitor_naturality.
  - (* 7 vcomp_runitor *)
    apply right_unitor_naturality.
  - (* 8 lwhisker_lwhisker *)
    apply whisker_left_left.
  - (* 9 rwhisker_lwhisker *)
    apply whisker_left_right.
  - (* 10 rwhisker_rwhisker *)
    apply whisker_right_right.
  - (* 11 vcomp_whisker *)
    apply twomor_naturality.
  - (* 12a lunitor_linvunitor *)
    apply (z_iso_inv_after_z_iso (left_unitor f)).
  - (* 12b linvunitor_lunitor *)
    apply (z_iso_after_z_iso_inv (left_unitor f)).
  - (* 13a runitor_rinvunitor *)
    apply (z_iso_inv_after_z_iso (right_unitor f)).
  - (* 13b rinvunitor_runitor *)
    apply (z_iso_after_z_iso_inv (right_unitor f)).
  - (* 14a lassociator_rassociator *)
    apply (z_iso_inv_after_z_iso (associator f g h)).
  - (* 14b rassociator_lassociator *)
    apply (z_iso_after_z_iso_inv (associator f g h)).
  - (* 15 runitor_rwhisker *)
    apply pathsinv0, (triangle_axiom f g).
  - (* 16  lassociator_lassociator *)
    apply pathsinv0, (pentagon_axiom f g h).
Defined.

Definition bcat : prebicat := (bcat_data,, bcat_laws).

End unfold_data.


(** * Hoare: Hoare Logic, Part I *)
(*** Zhaoguo Wang ***)

Require Export Imp.

(** In the past couple of chapters, we've begun applying the
    mathematical tools developed in the first part of the course to
    studying the theory of a small programming language, Imp.

    - We defined a type of _abstract syntax trees_ for Imp, together
      with an _evaluation relation_ (a partial function on states)
      that specifies the _operational semantics_ of programs.

      The language we defined, though small, captures some of the key
      features of full-blown languages like C, C++, and Java,
      including the fundamental notion of mutable state and some
      common control structures.

    - We proved a number of _metatheoretic properties_ -- "meta" in
      the sense that they are properties of the language as a whole,
      rather than properties of particular programs in the language.
      These included:

        - determinism of evaluation

        - equivalence of some different ways of writing down the
          definitions (e.g. functional and relational definitions of
          arithmetic expression evaluation)

        - guaranteed termination of certain classes of programs

        - correctness (in the sense of preserving meaning) of a number
          of useful program transformations

        - behavioral equivalence of programs (in the [Equiv] chapter).

    If we stopped here, we would already have something useful: a set
    of tools for defining and discussing programming languages and
    language features that are mathematically precise, flexible, and
    easy to work with, applied to a set of key properties.  All of
    these properties are things that language designers, compiler
    writers, and users might care about knowing.  Indeed, many of them
    are so fundamental to our understanding of the programming
    languages we deal with that we might not consciously recognize
    them as "theorems."  But properties that seem intuitively obvious
    can sometimes be quite subtle (in some cases, even subtly wrong!).

    We'll return to the theme of metatheoretic properties of whole
    languages later in the course when we discuss _types_ and _type
    soundness_.  In this chapter, though, we'll turn to a different
    set of issues.

    Our goal is to see how to carry out some simple examples of
    _program verification_ -- i.e., using the precise definition of
    Imp to prove formally that particular programs satisfy particular
    specifications of their behavior. We'll develop a reasoning system
    called _Floyd-Hoare Logic_ -- often shortened to just _Hoare
    Logic_ -- in which each of the syntactic constructs of Imp is
    equipped with a single, generic "proof rule" that can be used to
    reason compositionally about the correctness of programs involving
    this construct.

    Hoare Logic originates in the 1960s, and it continues to be the
    subject of intensive research right up to the present day.  It
    lies at the core of a multitude of tools that are being used in
    academia and industry to specify and verify real software
    systems. *)

(* ####################################################### *)
(** * Hoare Logic *)

(** Hoare Logic combines two beautiful ideas: a natural way of
    writing down _specifications_ of programs, and a _compositional
    proof technique_ for proving that programs are correct with
    respect to such specifications -- where by "compositional" we mean
    that the structure of proofs directly mirrors the structure of the
    programs that they are about. *)

(* ####################################################### *)
(** ** Assertions *)

(** To talk about specifications of programs, the first thing we
    need is a way of making _assertions_ about properties that hold at
    particular points during a program's execution -- i.e., claims
    about the current state of the memory when program execution
    reaches that point.  Formally, an assertion is just a family of
    propositions indexed by a [state]. *)

Definition Assertion := state -> Prop.

(** **** Exercise: 1 star, optional (assertions) *)
Module ExAssertions.

(** Paraphrase the following assertions in English. *)

Definition as1 : Assertion := fun st => st X = 3.
Definition as2 : Assertion := fun st => st X <= st Y.
Definition as3 : Assertion :=
  fun st => st X = 3 \/ st X <= st Y.
Definition as4 : Assertion :=
  fun st => st Z * st Z <= st X /\
            ~ (((S (st Z)) * (S (st Z))) <= st X).
Definition as5 : Assertion := fun st => True.
Definition as6 : Assertion := fun st => False.

(* 1. Define a assertion that a function is one state implies state x =3
   2. Define a assertion that a function is one state implies another state
of x <= state y
   3. Define a assertion that a function is one state implies anther two state
which are x =3 and x <=y
   4. Define a assertion that a function is one state implies
st Z * st Z <= st X /\~ (((S (st Z)) * (S (st Z))) <= st X).
   5. Define a assertion that a function is one state implies true
   6. Define a assertion that a function is one state implies false *)

End ExAssertions.
(** [] *)

(** This way of writing assertions can be a little bit heavy,
    for two reasons: (1) every single assertion that we ever write is
    going to begin with [fun st => ]; and (2) this state [st] is the
    only one that we ever use to look up variables (we will never need
    to talk about two different memory states at the same time).  For
    discussing examples informally, we'll adopt some simplifying
    conventions: we'll drop the initial [fun st =>], and we'll write
    just [X] to mean [st X].  Thus, instead of writing *)
(**
      fun st => (st Z) * (st Z) <= m /\
                ~ ((S (st Z)) * (S (st Z)) <= m)
    we'll write just
         Z * Z <= m /\ ~((S Z) * (S Z) <= m).
*)

(** Given two assertions [P] and [Q], we say that [P] _implies_ [Q],
    written [P ->> Q] (in ASCII, [P -][>][> Q]), if, whenever [P]
    holds in some state [st], [Q] also holds. *)

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

(** We'll also have occasion to use the "iff" variant of implication
    between assertions: *)

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* ####################################################### *)
(** ** Hoare Triples *)

(** Next, we need a way of making formal claims about the
    behavior of commands. *)

(** Since the behavior of a command is to transform one state to
    another, it is natural to express claims about commands in terms
    of assertions that are true before and after the command executes:

      - "If command [c] is started in a state satisfying assertion
        [P], and if [c] eventually terminates in some final state,
        then this final state will satisfy the assertion [Q]."

    Such a claim is called a _Hoare Triple_.  The property [P] is
    called the _precondition_ of [c], while [Q] is the
    _postcondition_.  Formally: *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

(** Since we'll be working a lot with Hoare triples, it's useful to
    have a compact notation:
       {{P}} c {{Q}}.
*)
(** (The traditional notation is [{P} c {Q}], but single braces
    are already used for other things in Coq.)  *)

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(** (The [hoare_spec_scope] annotation here tells Coq that this
    notation is not global but is intended to be used in particular
    contexts.  The [Open Scope] tells Coq that this file is one such
    context.) *)

(** **** Exercise: 1 star, optional (triples) *)
(** Paraphrase the following Hoare triples in English.
   1) {{True}} c {{X = 5}}

   2) {{X = m}} c {{X = m + 5)}}

   3) {{X <= Y}} c {{Y <= X}}

   4) {{True}} c {{False}}

   5) {{X = m}}
      c
      {{Y = real_fact m}}.

   6) {{True}}
      c
      {{(Z * Z) <= m /\ ~ (((S Z) * (S Z)) <= m)}}

 *)

(**1. if command c is started at precondition Ture,then it will satisfy the postcondition
x = 5.
   2. if command c is started at precondition X = m,then it will satisfy the postcondition
X = m + 5.
   3. if command c is started at precondition X <= Y,then it will satisfy the postcondition
Y <= X.
   4. if command c is started at precondition Ture,then it will satisfy the postcondition false.
   5. if command c is started at precondition X = m ,then it will satisfy the postcondition
Y = real_fact m.
   6. if command c is started at precondition True,then it will satisfy the postcondition
(Z * Z) <= m /\ ~ (((S Z) * (S Z)) <= m).
  *)

(** **** Exercise: 1 star, optional (valid_triples) *)
(** Which of the following Hoare triples are _valid_ -- i.e., the
    claimed relation between [P], [c], and [Q] is true?
   1) {{True}} X ::= 5 {{X = 5}}

   2) {{X = 2}} X ::= X + 1 {{X = 3}}

   3) {{True}} X ::= 5; Y ::= 0 {{X = 5}}

   4) {{X = 2 /\ X = 3}} X ::= 5 {{X = 0}}

   5) {{True}} SKIP {{False}}

   6) {{False}} SKIP {{True}}

   7) {{True}} WHILE True DO SKIP END {{False}}

   8) {{X = 0}}
      WHILE X == 0 DO X ::= X + 1 END
      {{X = 1}}

   9) {{X = 1}}
      WHILE X <> 0 DO X ::= X + 1 END
      {{X = 100}}

*)
(*  1, 2, 3, 8 *)
(** [] *)

(** (Note that we're using informal mathematical notations for
   expressions inside of commands, for readability, rather than their
   formal [aexp] and [bexp] encodings.  We'll continue doing so
   throughout the chapter.) *)

(** To get us warmed up for what's coming, here are two simple
    facts about Hoare triples. *)

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  apply H.  Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~(P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  unfold not in H. apply H in HP.
  inversion HP.  Qed.

(* ####################################################### *)
(** ** Proof Rules *)

(** The goal of Hoare logic is to provide a _compositional_
    method for proving the validity of Hoare triples.  That is, the
    structure of a program's correctness proof should mirror the
    structure of the program itself.  To this end, in the sections
    below, we'll introduce one rule for reasoning about each of the
    different syntactic forms of commands in Imp -- one for
    assignment, one for sequencing, one for conditionals, etc. -- plus
    a couple of "structural" rules that are useful for gluing things
    together. We will prove programs correct using these proof rules,
    without ever unfolding the definition of [hoare_triple]. *)

(* ####################################################### *)
(** *** Assignment *)

(** The rule for assignment is the most fundamental of the Hoare logic
    proof rules.  Here's how it works.

    Consider this (valid) Hoare triple:
       {{ Y = 1 }}  X ::= Y  {{ X = 1 }}
    In English: if we start out in a state where the value of [Y]
    is [1] and we assign [Y] to [X], then we'll finish in a
    state where [X] is [1].  That is, the property of being equal
    to [1] gets transferred from [Y] to [X].

    Similarly, in
       {{ Y + Z = 1 }}  X ::= Y + Z  {{ X = 1 }}
    the same property (being equal to one) gets transferred to
    [X] from the expression [Y + Z] on the right-hand side of
    the assignment.

    More generally, if [a] is _any_ arithmetic expression, then
       {{ a = 1 }}  X ::= a {{ X = 1 }}
    is a valid Hoare triple.

    This can be made even more general. To conclude that an
    _arbitrary_ property [Q] holds after [X ::= a], we need to assume
    that [Q] holds before [X ::= a], but _with all occurrences of_ [X]
    replaced by [a] in [Q]. This leads to the Hoare rule for
    assignment
      {{ Q [X |-> a] }} X ::= a {{ Q }}
    where "[Q [X |-> a]]" is pronounced "[Q] where [a] is substituted
    for [X]".

    For example, these are valid applications of the assignment
    rule:
      {{ (X <= 5) [X |-> X + 1]
         i.e., X + 1 <= 5 }}
      X ::= X + 1
      {{ X <= 5 }}

      {{ (X = 3) [X |-> 3]
         i.e., 3 = 3}}
      X ::= 3
      {{ X = 3 }}

      {{ (0 <= X /\ X <= 5) [X |-> 3]
         i.e., (0 <= 3 /\ 3 <= 5)}}
      X ::= 3
      {{ 0 <= X /\ X <= 5 }}
*)

(** To formalize the rule, we must first formalize the idea of
    "substituting an expression for an Imp variable in an assertion."
    That is, given a proposition [P], a variable [X], and an
    arithmetic expression [a], we want to derive another proposition
    [P'] that is just the same as [P] except that, wherever [P]
    mentions [X], [P'] should instead mention [a].

    Since [P] is an arbitrary Coq proposition, we can't directly
    "edit" its text.  Instead, we can achieve the effect we want by
    evaluating [P] in an updated state: *)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

(** That is, [P [X |-> a]] is an assertion [P'] that is just like [P]
    except that, wherever [P] looks up the variable [X] in the current
    state, [P'] instead uses the value of the expression [a].

    To see how this works, let's calculate what happens with a couple
    of examples.  First, suppose [P'] is [(X <= 5) [X |-> 3]] -- that
    is, more formally, [P'] is the Coq expression
    fun st =>
      (fun st' => st' X <= 5)
      (update st X (aeval st (ANum 3))),
    which simplifies to
    fun st =>
      (fun st' => st' X <= 5)
      (update st X 3)
    and further simplifies to
    fun st =>
      ((update st X 3) X) <= 5)
    and by further simplification to
    fun st =>
      (3 <= 5).
    That is, [P'] is the assertion that [3] is less than or equal to
    [5] (as expected).

    For a more interesting example, suppose [P'] is [(X <= 5) [X |->
    X+1]].  Formally, [P'] is the Coq expression
    fun st =>
      (fun st' => st' X <= 5)
      (update st X (aeval st (APlus (AId X) (ANum 1)))),
    which simplifies to
    fun st =>
      (((update st X (aeval st (APlus (AId X) (ANum 1))))) X) <= 5
    and further simplifies to
    fun st =>
      (aeval st (APlus (AId X) (ANum 1))) <= 5.
    That is, [P'] is the assertion that [X+1] is at most [5].

*)

(** Now we can give the precise proof rule for assignment:
      ------------------------------ (hoare_asgn)
      {{Q [X |-> a]}} X ::= a {{Q}}
*)

(** We can prove formally that this rule is indeed valid. *)

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(** Here's a first formal proof using this rule. *)

Example assn_sub_example :
  {{(fun st => st X = 3) [X |-> ANum 3]}}
  (X ::= (ANum 3))
  {{fun st => st X = 3}}.
Proof.
  apply hoare_asgn.  Qed.

(** **** Exercise: 2 stars (hoare_asgn_examples) *)
(** Translate these informal Hoare triples...
    1) {{ (X <= 5) [X |-> X + 1] }}
       X ::= X + 1
       {{ X <= 5 }}

    2) {{ (0 <= X /\ X <= 5) [X |-> 3] }}
       X ::= 3
       {{ 0 <= X /\ X <= 5 }}
   ...into formal statements and use [hoare_asgn] to prove them. *)

Theorem hoare_asgn_examples :
  {{ assn_sub X (APlus (AId X) (ANum 1)) (fun st => st X <= 5) }} X ::= APlus (AId X) (ANum 1) {{ fun st => st X <= 5 }}.
Proof. apply hoare_asgn. Qed.
Theorem hoare_asgn_examples_2 :
    {{ assn_sub X (ANum 3) (fun st => 0 <= st X /\ st X <= 5) }}  X ::= ANum 3  {{ fun st => 0 <= st X /\ st X <= 5 }}.
Proof. apply hoare_asgn. Qed.

(** **** Exercise: 2 stars (hoare_asgn_wrong) *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems backward to you, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:
      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}
    Give a counterexample showing that this rule is incorrect
    (informally). Hint: The rule universally quantifies over the
    arithmetic expression [a], and your counterexample needs to
    exhibit an [a] for which the rule doesn't work. *)

(* The rule doesn't work with a substituted by (X + 1) *)

(** **** Exercise: 3 stars, advanced (hoare_asgn_fwd) *)
(** However, using an auxiliary variable [m] to remember the original
    value of [X] we can define a Hoare rule for assignment that does,
    intuitively, "work forwards" rather than backwards.
  ------------------------------------------ (hoare_asgn_fwd)
  {{fun st => Q st /\ st X = m}}
    X ::= a
  {{fun st => Q st' /\ st X = aeval st' a }}
  (where st' = update st X m)
    Note that we use the original value of [X] to reconstruct the
    state [st'] before the assignment took place. Prove that this rule
    is correct (the first hypothesis is the functional extensionality
    axiom, which you will need at some point). Also note that this
    rule is more complicated than [hoare_asgn].
*)

Theorem hoare_asgn_fwd :
  (forall {X Y: Type} {f g : X -> Y}, (forall (x: X), f x = g x) ->  f = g) ->
  forall m a Q,
  {{fun st => Q st /\ st X = m}}
    X ::= a
  {{fun st => Q (update st X m) /\ st X = aeval (update st X m) a }}.
Proof.
  intros functional_extensionality v a Q.
  unfold hoare_triple. intros st st' E Pre.
  destruct Pre as [Pre1 Pre2].
  inversion E; subst.
  assert (st = update (update st X (aeval st a)) X (st X)) as Eq.
  apply functional_extensionality. intros x.
  rewrite update_shadow.
  rewrite update_same; reflexivity.
  rewrite <- Eq.
  split.
  assumption.
  reflexivity.
Qed.

(* ####################################################### *)
(** *** Consequence *)

(** Sometimes the preconditions and postconditions we get from the
    Hoare rules won't quite be the ones we want in the particular
    situation at hand -- they may be logically equivalent but have a
    different syntactic form that fails to unify with the goal we are
    trying to prove, or they actually may be logically weaker (for
    preconditions) or stronger (for postconditions) than what we need.

    For instance, while
      {{(X = 3) [X |-> 3]}} X ::= 3 {{X = 3}},
    follows directly from the assignment rule,
      {{True}} X ::= 3 {{X = 3}}.
    does not.  This triple is valid, but it is not an instance of
    [hoare_asgn] because [True] and [(X = 3) [X |-> 3]] are not
    syntactically equal assertions.  However, they are logically
    equivalent, so if one triple is valid, then the other must
    certainly be as well.  We might capture this observation with the
    following rule:
                {{P'}} c {{Q}}
                  P <<->> P'
         -----------------------------   (hoare_consequence_pre_equiv)
                {{P}} c {{Q}}
    Taking this line of thought a bit further, we can see that
    strengthening the precondition or weakening the postcondition of a
    valid triple always produces another valid triple. This
    observation is captured by two _Rules of Consequence_.
                {{P'}} c {{Q}}
                   P ->> P'
         -----------------------------   (hoare_consequence_pre)
                {{P}} c {{Q}}

                {{P}} c {{Q'}}
                  Q' ->> Q
         -----------------------------    (hoare_consequence_post)
                {{P}} c {{Q}}
*)

(** Here are the formal versions: *)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

(** For example, we might use the first consequence rule like this:
                {{ True }} ->>
                {{ 1 = 1 }}
    X ::= 1
                {{ X = 1 }}
    Or, formally...
*)

Example hoare_asgn_example1 :
  {{fun st => True}} (X ::= (ANum 1)) {{fun st => st X = 1}}.
Proof.
  apply hoare_consequence_pre
    with (P' := (fun st => st X = 1) [X |-> ANum 1]).
  apply hoare_asgn.
  intros st H. unfold assn_sub, update. simpl. reflexivity.
Qed.

(** Finally, for convenience in some proofs, we can state a "combined"
    rule of consequence that allows us to vary both the precondition
    and the postcondition.
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* ####################################################### *)
(** *** Digression: The [eapply] Tactic *)

(** This is a good moment to introduce another convenient feature of
    Coq.  We had to write "[with (P' := ...)]" explicitly in the proof
    of [hoare_asgn_example1] and [hoare_consequence] above, to make
    sure that all of the metavariables in the premises to the
    [hoare_consequence_pre] rule would be set to specific
    values.  (Since [P'] doesn't appear in the conclusion of
    [hoare_consequence_pre], the process of unifying the conclusion
    with the current goal doesn't constrain [P'] to a specific
    assertion.)

    This is a little annoying, both because the assertion is a bit
    long and also because for [hoare_asgn_example1] the very next
    thing we are going to do -- applying the [hoare_asgn] rule -- will
    tell us exactly what it should be!  We can use [eapply] instead of
    [apply] to tell Coq, essentially, "Be patient: The missing part is
    going to be filled in soon." *)

Example hoare_asgn_example1' :
  {{fun st => True}}
  (X ::= (ANum 1))
  {{fun st => st X = 1}}.
Proof.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  intros st H. reflexivity.  Qed.

(** In general, [eapply H] tactic works just like [apply H]
    except that, instead of failing if unifying the goal with the
    conclusion of [H] does not determine how to instantiate all
    of the variables appearing in the premises of [H], [eapply H]
    will replace these variables with _existential variables_
    (written [?nnn]) as placeholders for expressions that will be
    determined (by further unification) later in the proof. *)

(** In order for [Qed] to succeed, all existential variables need to
    be determined by the end of the proof. Otherwise Coq
    will (rightly) refuse to accept the proof. Remember that the Coq
    tactics build proof objects, and proof objects containing
    existential variables are not complete. *)

Lemma silly1 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. apply HP.

(** Coq gives a warning after [apply HP]:
     No more subgoals but non-instantiated existential variables:
     Existential 1 =
     ?171 : [P : nat -> nat -> Prop
             Q : nat -> Prop
             HP : forall x y : nat, P x y
             HQ : forall x y : nat, P x y -> Q x |- nat]
   Trying to finish the proof with [Qed] gives an error:
<<
    Error: Attempt to save a proof with existential variables still
    non-instantiated
>> *)

Abort.

(** An additional constraint is that existential variables cannot be
    instantiated with terms containing (ordinary) variables that did
    not exist at the time the existential variable was created. *)

Lemma silly2 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. destruct HP as [y HP'].

(** Doing [apply HP'] above fails with the following error:
     Error: Impossible to unify "?175" with "y".
    In this case there is an easy fix:
    doing [destruct HP] _before_ doing [eapply HQ].
*)

Abort.

Lemma silly2_fixed :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP'].
  eapply HQ. apply HP'.
Qed.

(** In the last step we did [apply HP'] which unifies the existential
    variable in the goal with the variable [y]. The [assumption]
    tactic doesn't work in this case, since it cannot handle
    existential variables. However, Coq also provides an [eassumption]
    tactic that solves the goal if one of the premises matches the
    goal up to instantiations of existential variables. We can use
    it instead of [apply HP']. *)

Lemma silly2_eassumption : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP']. eapply HQ. eassumption.
Qed.

(** **** Exercise: 2 stars (hoare_asgn_examples_2) *)
(** Translate these informal Hoare triples...
       {{ X + 1 <= 5 }}  X ::= X + 1  {{ X <= 5 }}
       {{ 0 <= 3 /\ 3 <= 5 }}  X ::= 3  {{ 0 <= X /\ X <= 5 }}
   ...into formal statements and use [hoare_asgn] and
   [hoare_consequence_pre] to prove them. *)

Lemma hoare_assgn_examples_3 : {{ fun st => st X + 1 <= 5 }} X ::= APlus (AId X) (ANum 1) {{ fun st => st X <= 5 }}.
Proof. eapply hoare_consequence_pre. apply hoare_asgn.
  intros st H. unfold assn_sub. simpl. rewrite update_eq. apply H.
Qed.
Lemma hoare_assgn_examples_4 : {{ fun st => 0 <= 3 /\ 3 <= 5 }} X ::= (ANum 3) {{ fun st => 0 <= st X /\ st X <= 5 }}.
 eapply hoare_consequence_pre. apply hoare_asgn.
  intros st H. unfold assn_sub. simpl. rewrite update_eq. apply H.
Qed.

(* ####################################################### *)
(** *** Skip *)

(** Since [SKIP] doesn't change the state, it preserves any
    property P:
      --------------------  (hoare_skip)
      {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* ####################################################### *)
(** *** Sequencing *)

(** More interestingly, if the command [c1] takes any state where
    [P] holds to a state where [Q] holds, and if [c2] takes any
    state where [Q] holds to one where [R] holds, then doing [c1]
    followed by [c2] will take any state where [P] holds to one
    where [R] holds:
        {{ P }} c1 {{ Q }}
        {{ Q }} c2 {{ R }}
       ---------------------  (hoare_seq)
       {{ P }} c1;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(** Note that, in the formal rule [hoare_seq], the premises are
    given in "backwards" order ([c2] before [c1]).  This matches the
    natural flow of information in many of the situations where we'll
    use the rule: the natural way to construct a Hoare-logic proof is
    to begin at the end of the program (with the final postcondition)
    and push postconditions backwards through commands until we reach
    the beginning. *)

(** Informally, a nice way of recording a proof using the sequencing
    rule is as a "decorated program" where the intermediate assertion
    [Q] is written between [c1] and [c2]:
      {{ a = n }}
    X ::= a;
      {{ X = n }}      <---- decoration for Q
    SKIP
      {{ X = n }}
*)

Example hoare_asgn_example3 : forall a n,
  {{fun st => aeval st a = n}}
  (X ::= a; SKIP)
  {{fun st => st X = n}}.
Proof.
  intros a n. eapply hoare_seq.
  Case "right part of seq".
    apply hoare_skip.
  Case "left part of seq".
    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. subst. reflexivity. Qed.

(** You will most often use [hoare_seq] and
    [hoare_consequence_pre] in conjunction with the [eapply] tactic,
    as done above. *)

(** **** Exercise: 2 stars (hoare_asgn_example4) *)
(** Translate this "decorated program" into a formal proof:
                   {{ True }} ->>
                   {{ 1 = 1 }}
    X ::= 1;
                   {{ X = 1 }} ->>
                   {{ X = 1 /\ 2 = 2 }}
    Y ::= 2
                   {{ X = 1 /\ Y = 2 }}
*)

Example hoare_asgn_example4 :
  {{fun st => True}} (X ::= (ANum 1); Y ::= (ANum 2))
  {{fun st => st X = 1 /\ st Y = 2}}.
Proof.
eapply hoare_seq.
  Case "Y ::= 2". eapply hoare_consequence_pre. apply hoare_asgn.
  intros st H. unfold assn_sub. simpl. split. compute. apply H.
  apply update_eq.
  Case "X ::= 1". eapply hoare_consequence_pre. apply hoare_asgn.
  intros st H.  unfold assn_sub. simpl. apply update_eq.
Qed.

(** **** Exercise: 3 stars (swap_exercise) *)
(** Write an Imp program [c] that swaps the values of [X] and [Y]
    and show (in Coq) that it satisfies the following
    specification:
      {{X <= Y}} c {{Y <= X}}
*)

Definition swap_program : com :=
  (* FILL IN HERE *) admit.

Theorem swap_exercise :
  {{fun st => st X <= st Y}}
  swap_program
  {{fun st => st Y <= st X}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (hoarestate1) *)
(** Explain why the following proposition can't be proven:
      forall (a : aexp) (n : nat),
         {{fun st => aeval st a = n}}
         (X ::= (ANum 3); Y ::= a)
         {{fun st => st Y = n}}.
*)

(* the expression a could contain X, and X could have a
different value before and after the computation *)
(** [] *)

(* ####################################################### *)
(** *** Conditionals *)

(** What sort of rule do we want for reasoning about conditional
    commands?  Certainly, if the same assertion [Q] holds after
    executing either branch, then it holds after the whole
    conditional.  So we might be tempted to write:
              {{P}} c1 {{Q}}
              {{P}} c2 {{Q}}
      --------------------------------
      {{P}} IFB b THEN c1 ELSE c2 {{Q}}
   However, this is rather weak. For example, using this rule,
   we cannot show that:
     {{ True }}
     IFB X == 0
     THEN Y ::= 2
     ELSE Y ::= X + 1
     FI
     {{ X <= Y }}
   since the rule tells us nothing about the state in which the
   assignments take place in the "then" and "else" branches. *)

(** But we can actually say something more precise.  In the
   "then" branch, we know that the boolean expression [b] evaluates to
   [true], and in the "else" branch, we know it evaluates to [false].
   Making this information available in the premises of the rule gives
   us more information to work with when reasoning about the behavior
   of [c1] and [c2] (i.e., the reasons why they establish the
   postcondition [Q]). *)
(**
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

(** To interpret this rule formally, we need to do a little work.
    Strictly speaking, the assertion we've written, [P /\ b], is the
    conjunction of an assertion and a boolean expression -- i.e., it
    doesn't typecheck.  To fix this, we need a way of formally
    "lifting" any bexp [b] to an assertion.  We'll write [bassn b] for
    the assertion "the boolean expression [b] evaluates to [true] (in
    the given state)." *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

(** A couple of useful facts about [bassn]: *)

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(** Now we can formalize the Hoare proof rule for conditionals
    and prove it correct. *)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(** Here is a formal proof that the program we used to motivate the
    rule satisfies the specification we gave. *)

Example if_example :
    {{fun st => True}}
  IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= APlus (AId X) (ANum 1))
  FI
    {{fun st => st X <= st Y}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_if.
  Case "Then".
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold bassn, assn_sub, update, assert_implies.
    simpl. intros st [_ H].
    symmetry in H; apply beq_nat_eq in H.
    rewrite H. omega.
  Case "Else".
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold assn_sub, update, assert_implies.
    simpl; intros st _. omega.
Qed.

(** **** Exercise: 2 stars (if_minus_plus) *)
(** Prove the following hoare triple using [hoare_if]: *)

Theorem if_minus_plus :
  {{fun st => True}}
  IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI
  {{fun st => st Y = st X + st Z}}.
Proof.
  apply hoare_if.
  Case "X<Y".
  eapply hoare_consequence_pre. apply hoare_asgn. unfold bassn.
  unfold assn_sub. unfold assert_implies. simpl. intros. inversion H.
  unfold update. simpl. apply ble_nat_true in H1. omega.
  Case "X>=Y".
  eapply hoare_consequence_pre. apply hoare_asgn.
  unfold bassn. unfold assn_sub. unfold assert_implies.
  simpl. intros. inversion H. unfold update;simpl.
  reflexivity.
Qed.

(* ####################################################### *)
(** *** Exercise: One-sided conditionals *)

(** **** Exercise: 4 stars (if1_hoare) *)

(** In this exercise we consider extending Imp with "one-sided
    conditionals" of the form [IF1 b THEN c FI]. Here [b] is a
    boolean expression, and [c] is a command. If [b] evaluates to
    [true], then command [c] is evaluated. If [b] evaluates to
    [false], then [IF1 b THEN c FI] does nothing.

    We recommend that you do this exercise before the ones that
    follow, as it should help solidify your understanding of the
    material. *)

(** The first step is to extend the syntax of commands and introduce
    the usual notations.  (We've done this for you.  We use a separate
    module to prevent polluting the global name space.) *)

Module If1.

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

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE" | Case_aux c "CIF1" ].

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

(** Next we need to extend the evaluation relation to accommodate
    [IF1] branches.  This is for you to do... What rule(s) need to be
    added to [ceval] to evaluate one-sided conditionals? *)

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

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st || st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st || update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st || st' -> c2 / st' || st'' -> (c1 ; c2) / st || st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st || st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st || st' ->
                  (WHILE b1 DO c1 END) / st' || st'' ->
                  (WHILE b1 DO c1 END) / st || st''
  |E_If1True : forall (st st' : state) (b1 : bexp) (c : com),
                beval st b1 = true ->
                c / st || st' -> (IF1 b1 THEN c FI) / st || st'
  | E_If1False : forall (st : state) (b1 : bexp) (c : com),
                beval st b1 = false ->
                (IF1 b1 THEN c FI) / st || st
  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_If1True" | Case_aux c "E_If1False"
  ].

(** Now we repeat (verbatim) the definition and notation of Hoare triples. *)

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

(** Finally, we (i.e., you) need to state and prove a theorem,
    [hoare_if1], that expresses an appropriate Hoare logic proof rule
    for one-sided conditionals. Try to come up with a rule that is
    both sound and as precise as possible. *)

Theorem hoare_if1 : forall P Q b c1,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} SKIP {{Q}} ->
  {{P}} (IF1 b THEN c1 FI) {{Q}}.
Proof.
  intros P Q b c1 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st' st').
      apply E_Skip.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(** For full credit, prove formally that your rule is precise enough
    to show the following valid Hoare triple:
  {{ X + Y = Z }}
  IF1 Y <> 0 THEN
    X ::= X + Y
  FI
  {{ X = Z }}
*)

(** Hint: Your proof of this triple may need to use the other proof
    rules also. Because we're working in a separate module, you'll
    need to copy here the rules you find necessary. *)

Lemma hoare_if1_good :
  {{ fun st => st X + st Y = st Z }}
  IF1 BNot (BEq (AId Y) (ANum 0)) THEN
    X ::= APlus (AId X) (AId Y)
  FI
  {{ fun st => st X = st Z }}.
Proof.

 (* FILL IN HERE *) Admitted.
End If1.
(** [] *)

(* ####################################################### *)
(** *** Loops *)

(** Finally, we need a rule for reasoning about while loops. *)

(** Suppose we have a loop
      WHILE b DO c END
    and we want to find a pre-condition [P] and a post-condition
    [Q] such that
      {{P}} WHILE b DO c END {{Q}}
    is a valid triple. *)

(** First of all, let's think about the case where [b] is false at the
    beginning -- i.e., let's assume that the loop body never executes
    at all.  In this case, the loop behaves like [SKIP], so we might
    be tempted to write
      {{P}} WHILE b DO c END {{P}}.
    But, as we remarked above for the conditional, we know a
    little more at the end -- not just [P], but also the fact
    that [b] is false in the current state.  So we can enrich the
    postcondition a little:
      {{P}} WHILE b DO c END {{P /\ ~b}}
    What about the case where the loop body _does_ get executed?
    In order to ensure that [P] holds when the loop finally
    exits, we certainly need to make sure that the command [c]
    guarantees that [P] holds whenever [c] is finished.
    Moreover, since [P] holds at the beginning of the first
    execution of [c], and since each execution of [c]
    re-establishes [P] when it finishes, we can always assume
    that [P] holds at the beginning of [c].  This leads us to the
    following rule:
                   {{P}} c {{P}}
        -----------------------------------
        {{P}} WHILE b DO c END {{P /\ ~b}}

    This is almost the rule we want, but again it can be improved a
    little: at the beginning of the loop body, we know not only that
    [P] holds, but also that the guard [b] is true in the current
    state.  This gives us a little more information to use in
    reasoning about [c] (showing that it establishes the invariant by
    the time it finishes).  This gives us the final version of the rule:
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.

    One subtlety in the terminology is that calling some assertion [P]
    a "loop invariant" doesn't just mean that it is preserved by the
    body of the loop in question (i.e., [{{P}} c {{P}}], where [c] is
    the loop body), but rather that [P] _together with the fact that
    the loop's guard is true_ is a sufficient precondition for [c] to
    ensure [P] as a postcondition.

    This is a slightly (but significantly) weaker requirement.  For
    example, if [P] is the assertion [X = 0], then [P] _is_ an
    invariant of the loop
    WHILE X = 2 DO X := 1 END
    although it is clearly _not_ preserved by the body of the
    loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on He, because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just c *)
  remember (WHILE b DO c END) as wcom.
  ceval_cases (induction He) Case;
    try (inversion Heqwcom); subst.

  Case "E_WhileEnd".
    split. assumption. apply bexp_eval_false. assumption.

  Case "E_WhileLoop".
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Example while_example :
    {{fun st => st X <= 3}}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => st X = 3}}.
Proof.
  eapply hoare_consequence_post.
  apply hoare_while.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  unfold bassn, assn_sub, assert_implies, update. simpl.
    intros st [H1 H2]. apply ble_nat_true in H2. omega.
  unfold bassn, assert_implies. intros st [Hle Hb].
    simpl in Hb. remember (ble_nat (st X) 2) as le. destruct le.
    apply ex_falso_quodlibet. apply Hb; reflexivity.
    symmetry in Heqle. apply ble_nat_false in Heqle. omega.
Qed.

(** We can use the while rule to prove the following Hoare triple,
    which may seem surprising at first... *)

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  (* WORKED IN CLASS *)
  intros P Q.
  apply hoare_consequence_pre with (P' := fun st : state => True).
  eapply hoare_consequence_post.
  apply hoare_while.
  Case "Loop body preserves invariant".
    apply hoare_post_true. intros st. apply I.
  Case "Loop invariant and negated guard imply postcondition".
    simpl. intros st [Hinv Hguard].
    apply ex_falso_quodlibet. apply Hguard. reflexivity.
  Case "Precondition implies invariant".
    intros st H. constructor.  Qed.

(** Of course, this result is not surprising if we remember that
    the definition of [hoare_triple] asserts that the postcondition
    must hold _only_ when the command terminates.  If the command
    doesn't terminate, we can prove anything we like about the
    post-condition. *)

(** Hoare rules that only talk about terminating commands are
    often said to describe a logic of "partial" correctness.  It is
    also possible to give Hoare rules for "total" correctness, which
    build in the fact that the commands terminate. However, in this
    course we will only talk about partial correctness. *)

(* ####################################################### *)
(** *** Exercise: [REPEAT] *)

Module RepeatExercise.

(** **** Exercise: 4 stars, advanced (hoare_repeat) *)
(** In this exercise, we'll add a new command to our language of
    commands: [REPEAT] c [UNTIL] a [END]. You will write the
    evaluation rule for [repeat] and add a new Hoare rule to
    the language for programs involving it. *)

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

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE"
  | Case_aux c "CRepeat" ].

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

(** Add new rules for [REPEAT] to [ceval] below.  You can use the rules
    for [WHILE] as a guide, but remember that the body of a [REPEAT]
    should always execute at least once, and that the loop ends when
    the guard becomes true.  Then update the [ceval_cases] tactic to
    handle these added cases.  *)

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_UntilEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (REPEAT c1 UNTIL b1 END) st'
  | E_UntilLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (REPEAT c1 UNTIL b1 END) st'' ->
      ceval st (REPEAT c1 UNTIL b1 END) st''
.

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass"
  | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_UntilEnd" | Case_aux c "E_UntilLoop"
].

(** A couple of definitions from above, copied here so they use the
    new [ceval]. *)

Notation "c1 '/' st '||' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion)
                        : Prop :=
  forall st st', (c / st || st') -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level).

(** To make sure you've got the evaluation rules for [REPEAT] right,
    prove that [ex1_repeat evaluates correctly. *)

Definition ex1_repeat :=
  REPEAT
    X ::= ANum 1;
    Y ::= APlus (AId Y) (ANum 1)
  UNTIL (BEq (AId X) (ANum 1)) END.

Theorem ex1_repeat_works :
  ex1_repeat / empty_state ||
               update (update empty_state X 1) Y 1.
Proof.
unfold ex1_repeat.
  apply E_UntilEnd. eapply E_Seq. apply E_Ass.
  simpl. reflexivity.
  apply E_Ass. reflexivity.
  reflexivity.
Qed.

(** Now state and prove a theorem, [hoare_repeat], that expresses an
    appropriate proof rule for [repeat] commands.  Use [hoare_while]
    as a model, and try to make your rule as precise as possible. *)

Lemma hoare_repeat : forall P b c,
    {{fun st => P st}} c {{P}} ->
    {{P}} REPEAT c UNTIL b END {{fun st => P st /\ (bassn b st)}}.
Proof.
  unfold hoare_triple; intros.
  remember (REPEAT c UNTIL b END).
  ceval_cases (induction H0) Case; inversion Heqc0; subst; clear Heqc0; split; auto;
  try (apply IHceval2; auto; apply (H st); auto);
  try (apply (H st); auto).
Qed.

(** For full credit, make sure (informally) that your rule can be used
    to prove the following valid Hoare triple:
  {{ X > 0 }}
  REPEAT
    Y ::= X;
    X ::= X - 1
  UNTIL X = 0 END
  {{ X = 0 /\ Y > 0 }}
*)

End RepeatExercise.
(** [] *)

(* ####################################################### *)
(** ** Exercise: [HAVOC] *)

(** **** Exercise: 3 stars (himp_hoare) *)

(** In this exercise, we will derive proof rules for the [HAVOC] command
    which we studied in the last chapter. First, we enclose this work
    in a separate module, and recall the syntax and big-step semantics
    of Himp commands. *)

Module Himp.

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

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE" | Case_aux c "HAVOC" ].

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

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

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st || st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st || update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st || st' -> c2 / st' || st'' -> (c1 ; c2) / st || st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st || st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st || st' ->
                  (WHILE b1 DO c1 END) / st' || st'' ->
                  (WHILE b1 DO c1 END) / st || st''
  | E_Havoc : forall (st : state) (X : id) (n : nat),
              (HAVOC X) / st || update st X n

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_Havoc" ].

(** The definition of Hoare triples is exactly as before. Unlike our
    notion of program equivalence, which had subtle consequences with
    occassionally nonterminating commands (exercise [havoc_diverge]),
    this definition is still fully satisfactory. Convince yourself of
    this before proceeding. *)

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st', c / st || st' -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

(** Complete the Hoare rule for [HAVOC] commands below by defining
    [havoc_pre] and prove that the resulting rule is correct. *)

Definition havoc_pre (X : id) (Q : Assertion) : Assertion :=
fun st => forall n, Q (update st X n).

Theorem hoare_havoc : forall (Q : Assertion) (X : id),
  {{ havoc_pre X Q }} HAVOC X {{ Q }}.
Proof.
  unfold hoare_triple, havoc_pre. intros.
  inversion H; clear H; subst.
  apply H0.
Qed.

End Himp.
(** [] *)

(* ####################################################### *)
(** ** Review *)

(** Above, we've introduced Hoare Logic as a tool to reasoning
    about Imp programs. In the reminder of this chapter we will
    explore a systematic way to use Hoare Logic to prove properties
    about programs. The rules of Hoare Logic are the following: *)

(**
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}

             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}

               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;c2 {{ R }}

              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}

               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}

                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
    In the next chapter, we'll see how these rules are used to prove
    that programs satisfy specifications of their behavior.
*)

(* $Date: 2013-04-01 09:15:45 -0400 (Mon, 01 Apr 2013) $ *)


(* Not heaps *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Maps.
Require Import Imp.
Require Import Coq.Lists.List.
Import List Notations.
Require Import Smallstep.

Module DistIMP.

Inductive aexp : Type :=
  | AId : id -> aexp
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  (* Distributed Commands*)
  | CSend : aexp -> id -> id -> com
  | CRecieve: com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (CIf b c1 c2) (at level 80, right associativity).
Notation "'SEND' a 'TO' id1 'CALLED' id2" :=
  (CSend a id1 id2) (at level  80, right associativity).
Notation "'RECEIVE'"  :=
  (CRecieve) (at level 80, right associativity).

(*Definition state := total_map nat.

Definition empty_state : state :=
  t_empty 0.*)

Inductive triple (A B C : Type) : Type :=
  | trip : A -> B -> C -> triple A B C.

Notation "x '*' y '*' z" := (triple x y z)
  (at level 70, right associativity).

Definition sb := list (aexp * id * id).

Definition rb := list (aexp * id).

Definition st := total_map nat.

Inductive State : Type :=
| state : sb  -> rb -> st -> State.

Definition empty_state : State := state nil nil (t_empty 0).

Check state.

Inductive aval : aexp -> Prop :=
  av_num : forall n, aval (ANum n).

Reserved Notation " t '/' st '==>a' t' " (at level 40, st at level 39).

Inductive astep : State -> aexp -> aexp -> Prop :=
  | AS_Id : forall sb rb st i,
      AId i / state sb rb st ==>a ANum (st i)
  | AS_Plus : forall st n1 n2,
      APlus (ANum n1) (ANum n2) / st ==>a ANum (n1 + n2)
  | AS_Plus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (APlus a1 a2) / st ==>a (APlus a1' a2)
  | AS_Plus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (APlus v1 a2) / st ==>a (APlus v1 a2')
  | AS_Minus : forall st n1 n2,
      (AMinus (ANum n1) (ANum n2)) / st ==>a (ANum (minus n1 n2))
  | AS_Minus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMinus a1 a2) / st ==>a (AMinus a1' a2)
  | AS_Minus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMinus v1 a2) / st ==>a (AMinus v1 a2')
  | AS_Mult : forall st n1 n2,
      (AMult (ANum n1) (ANum n2)) / st ==>a (ANum (mult n1 n2))
  | AS_Mult1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMult (a1) (a2)) / st ==>a (AMult (a1') (a2))
  | AS_Mult2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMult v1 a2) / st ==>a (AMult v1 a2')

    where " t '/' st '==>a' t' " := (astep st t t').

  Reserved Notation " t '/' st '==>b' t' " (at level 40, st at level 39).

  Inductive bstep : State -> bexp -> bexp -> Prop :=
  | BS_Eq : forall st n1 n2,
      (BEq (ANum n1) (ANum n2)) / st ==>b
      (if (beq_nat n1 n2) then BTrue else BFalse)
  | BS_Eq1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (BEq a1 a2) / st ==>b (BEq a1' a2)
  | BS_Eq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (BEq v1 a2) / st ==>b (BEq v1 a2')
  | BS_LtEq : forall st n1 n2,
      (BLe (ANum n1) (ANum n2)) / st ==>b
               (if (leb n1 n2) then BTrue else BFalse)
  | BS_LtEq1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (BLe a1 a2) / st ==>b (BLe a1' a2)
  | BS_LtEq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (BLe v1 a2) / st ==>b (BLe v1 (a2'))
  | BS_NotTrue : forall st,
      (BNot BTrue) / st ==>b BFalse
  | BS_NotFalse : forall st,
      (BNot BFalse) / st ==>b BTrue
  | BS_NotStep : forall st b1 b1',
      b1 / st ==>b b1' ->
      (BNot b1) / st ==>b (BNot b1')
  | BS_AndTrueTrue : forall st,
      (BAnd BTrue BTrue) / st ==>b BTrue
  | BS_AndTrueFalse : forall st,
      (BAnd BTrue BFalse) / st ==>b BFalse
  | BS_AndFalse : forall st b2,
      (BAnd BFalse b2) / st ==>b BFalse
  | BS_AndTrueStep : forall st b2 b2',
      b2 / st ==>b b2' ->
      (BAnd BTrue b2) / st ==>b (BAnd BTrue b2')
  | BS_AndStep : forall st b1 b1' b2,
      b1 / st ==>b b1' ->
      (BAnd b1 b2) / st ==>b (BAnd b1' b2)

  where " t '/' st '==>b' t' " := (bstep st t t').

Inductive cstep : (com * State) -> (com * State) -> Prop :=
  | CS_AssStep : forall (sb1 : sb) (rb1 : rb) (st1 : st) (i : id) (a a' : aexp),
      a / state sb1 rb1 st1 ==>a a' ->
      cstep (i ::= a, state sb1 rb1 st1) (i ::= a', state sb1 rb1 st1)
  | CS_Ass : forall (sb1 : sb) (rb1 : rb) (st1 : st) (i : id) (n : nat),
      cstep (i ::= (ANum n), state sb1 rb1 st1)
      (SKIP, state sb1 rb1 (t_update st1 i n))
  | CS_SeqStep : forall (st: State) (c1 c1': com) (st' : State) (c2 : com),
      cstep (c1, st) (c1', st') ->
      cstep (c1 ;; c2, st) (c1' ;; c2, st')
  | CS_SeqFinish : forall (sb1 : sb) (rb1 : rb) (st1 : st) (c2 : com),
      cstep (SKIP ;; c2, state sb1 rb1 st1) (c2, state sb1 rb1 st1)
  | CS_IfTrue : forall (sb1 : sb) (rb1 : rb) (st1 : st) (c1 c2 : com),
      cstep (IFB BTrue THEN c1 ELSE c2 FI, state sb1 rb1 st1)
      (c1, state sb1 rb1 st1)
  | CS_IfFalse : forall (sb1 : sb) (rb1 : rb) (st1 : st) (c1 c2 : com),
      cstep (IFB BFalse THEN c1 ELSE c2 FI, state sb1 rb1 st1)
      (c2, state sb1 rb1 st1)
  | CS_IfStep : forall (sb1 : sb) (rb1 : rb) (st1 : st)
                (b b' : bexp) (c1 c2: com),
      b / state sb1 rb1 st1 ==>b b' ->
      cstep (IFB b THEN c1 ELSE c2 FI, state sb1 rb1 st1)
      ((IFB b' THEN c1 ELSE c2 FI), state sb1 rb1 st1)
  | CS_While : forall (sb1 : sb) (rb1 : rb) (st1 : st) (b : bexp) (c1 : com),
      cstep (WHILE b DO c1 END, state sb1 rb1 st1)
      ((IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI), state sb1 rb1 st1)

  | CS_Send1 : forall (sb1 : sb) (rb1 : rb)
                      (st1 : st) (a a' : aexp) (x z : id),
      a / state sb1 rb1 st1 ==>a a' ->
      cstep (SEND a TO x CALLED z, state sb1 rb1 st1)
            (SEND a' TO x CALLED z, state sb1 rb1 st1)
  | CS_Send2 : forall (sb1 : sb) (rb1 : rb) (st1 : st)
                      (a : aexp) (x z : id) (n : nat),
      a = ANum n ->
      cstep (SEND a TO x CALLED z, state sb1 rb1 st1)
            (SKIP, state (app sb1 (cons (a, x, z) nil)) rb1 st1)
  | CS_Rec1 : forall (sb1 : sb) (st1 : st),
      cstep (RECEIVE, state sb1 nil st1)
            (SKIP ;; RECEIVE, state sb1 nil st1)
  | CS_Rec2 : forall (sb1 : sb) (rb1 : rb)
                     (st1 : st) (a : aexp) (z : id),
      cstep (RECEIVE, state sb1 (app (cons (a, z) nil) rb1) st1)
            (z ::= a, state sb1 rb1 st1).

Inductive imp : Type :=
  | machine : id -> com -> State -> imp.

Inductive dist_imp : (imp * imp) -> (imp * imp) -> Prop :=
  | imp_step_1 : forall (c1 c1' c2 : com) (st1 st1' st2 : State) (x y : id),
    cstep (c1, st1) (c1', st1') ->
    dist_imp ((machine x c1 st1), (machine y c2 st2))
               ((machine x c1' st1'), (machine y c2 st2))
  | imp_step_2 : forall (c1 c2' c2 : com) (st1 st2' st2 : State) (x y : id),
    cstep (c2, st2) (c2', st2') ->
    dist_imp ((machine x c1 st1), (machine y c2 st2))
               ((machine x c1 st1), (machine y c2' st2'))
  | send_y : forall (c1 c2 : com) (sb1 sb2 : sb) (rb1 rb2 : rb) (st1 st2 : st)
                    (a : aexp) (x y z : id),
    dist_imp ((machine x c1 (state (cons (a, y, z) sb1) rb1 st1)),
             (machine y c2 (state sb2 rb2 st2)))
            ((machine x c1 (state sb1 rb1 st1)),
            ((machine y c2 (state sb2 (app (cons (a, z) nil) rb2) st2))))
  | send_x : forall (c1 c2 : com) (sb1 sb2 : sb) (rb1 rb2 : rb) (st1 st2 : st)
                    (a : aexp) (x y z : id),
    dist_imp ((machine x c1 (state sb1 rb1 st1)),
             (machine y c2 (state (cons (a, x, z) sb2) rb2 st2)))
            ((machine x c1 (state sb1 (app (cons (a, z) nil) rb1) st1)),
            (machine y c2 (state sb2 rb2 st2))).

Definition cdist_imp := multi dist_imp.

Lemma proof_of_concept : forall x y n z,
  multi dist_imp ((machine x (SEND (ANum n) TO y CALLED z) empty_state),
                 (machine y (RECEIVE) empty_state))
                 ((machine x SKIP empty_state),
                 (machine y (z ::= (ANum n)) empty_state)).
Proof.
  intros. eapply multi_step. apply imp_step_1.
    eapply CS_Send2. reflexivity.
  eapply multi_step. apply send_y. fold empty_state.
  eapply multi_step. apply imp_step_2. apply CS_Rec2. fold empty_state.
  eapply multi_refl.
Qed.

Lemma proof_of_concept' : forall x y z,
  multi dist_imp ((machine x ((SEND (APlus (APlus (ANum 1) (ANum 1)) (ANum 1))
                      TO y CALLED z) ;; RECEIVE) empty_state),
                  (machine y (RECEIVE ;;
                    SEND (APlus (APlus (ANum 1) (ANum 1)) (ANum 1)) TO x CALLED z)
                    empty_state))
                 ((machine x SKIP (state nil nil (t_update (t_empty 0) z 3))),
                  (machine y SKIP (state nil nil (t_update (t_empty 0) z 3)))).
Proof.
  intros.
  eapply multi_step. apply imp_step_2. apply CS_SeqStep. apply CS_Rec1.
  eapply multi_step. apply imp_step_1. apply CS_SeqStep. apply CS_Send1.
    apply AS_Plus1. apply AS_Plus.
  eapply multi_step. apply imp_step_1. apply CS_SeqStep. apply CS_Send1.
    apply AS_Plus.
  eapply multi_step. apply imp_step_1. apply CS_SeqStep. eapply CS_Send2.
    reflexivity.
  eapply multi_step. apply imp_step_2. apply CS_SeqStep. apply CS_SeqFinish.
  eapply multi_step. apply send_y.
  eapply multi_step. apply imp_step_2. apply CS_SeqStep. apply CS_Rec2.
  eapply multi_step. apply imp_step_2. apply CS_SeqStep. apply CS_Ass.
  eapply multi_step. apply imp_step_2. apply CS_SeqFinish.
  eapply multi_step. apply imp_step_1. apply CS_SeqFinish.
  eapply multi_step. apply imp_step_2. apply CS_Send1. apply AS_Plus1.
    apply AS_Plus.
  eapply multi_step. apply imp_step_2. apply CS_Send1. apply AS_Plus.
  eapply multi_step. apply imp_step_2. eapply CS_Send2. reflexivity.
  eapply multi_step. apply send_x.
  eapply multi_step. apply imp_step_1. apply CS_Rec2.
  eapply multi_step. apply imp_step_1. apply CS_Ass.
  eapply multi_refl.
Qed.

End DistIMP.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Definition relation (X:Type) := X -> X -> Prop.

Section Star.

  Variable A : Type.
  Variable R : relation A.

  Inductive star: relation A:=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

  Lemma star_one:
    forall a b, R a b -> star a b.
  Proof.
    eauto using star.
  Qed.

  Lemma star_trans:
    forall a b, star a b -> forall c, star b c -> star a c.
  Proof.
    induction 1; eauto using star.
  Qed.

  Hypothesis R_functional:
    forall a b c, R a b -> R a c -> b = c.

  Lemma star_star_inv:
    forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
  Proof.
    induction 1; intros.
    - auto.
    - inversion H1; subst.
      + right. eauto using star.
      + assert (b = b0) by (eapply R_functional; eauto). subst b0.
        apply IHstar; auto.
  Qed.

  Definition irred a : Prop := forall b, ~(R a b).

  Lemma finseq_unique:
    forall a b b',
      star a b -> irred b ->
      star a b' -> irred b' ->
      b = b'.
  Proof.
    intros. destruct (star_star_inv _ _ H _ H1).
    - inversion H3; subst. auto. elim (H0 _ H4).
    - inversion H3; subst. auto. elim (H2 _ H4).
  Qed.

End Star.

Hint Constructors star : core.

Hint Resolve star_trans star_one : core.

Definition mul_dstep := star dexp DunfieldStep.
Notation "e ->>* e'" := ((star dexp DunfieldStep) e e') (at level 68).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).
Notation "e ^ x"        := (open_exp_wrt_exp e (e_var_f x)).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "R 'star'" := (star exp R) (at level 69).

Notation "t ->* t'" := (step star t t') (at level 68).

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` F).
(*
Definition typed e A : Prop := Dtyping nil e A.
Definition well_typed e : Prop := exists A, Dtyping nil e A.
*)
(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred exp step v.
Proof.
  introv.
  unfold irred.
  induction v; introv H;
    inverts* H;
    unfold not;
    intros;
    inverts* H.
Qed.

Lemma value_no_step : forall (v t: exp),
    value v -> v ->* t -> v = t.
Proof.
  introv Val Red.
  induction* Red.
  lets : step_not_value Val H.
  tryfalse.
Qed.

Lemma multi_red_app1 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* t1' -> (e_app t1 t2) ->* (e_app t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_app2 : forall v t t',
    value v -> lc_exp v -> t ->* t' -> (e_app v t) ->* (e_app v t').
Proof.
  introv Val ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge1 : forall t1 t2 t1',
    lc_exp t2 ->
    t1 ->* t1' ->
    (e_merge t1 t2) ->* (e_merge t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge2 : forall v1 t2 t2',
    value v1 -> lc_exp v1 ->
    t2 ->* t2' ->
    (e_merge v1 t2) ->* (e_merge v1 t2').
Proof.
  introv Val ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge3 : forall t1 t2 v1 v2,
    value v1 -> value v2 -> lc_exp v1 -> lc_exp t2 ->
    t1 ->* v1 -> t2 ->* v2 ->
    (e_merge t1 t2) ->* (e_merge v1 v2).
Proof.
  intros.
  apply star_trans with (b := e_merge v1 t2).
  sapply* multi_red_merge1.
  sapply* multi_red_merge2.
Qed.

(** Typing is preserved by substitution. *)

(* doesn't hold in two anno *) (*
Lemma typing_uniq: forall G e A B,
    G |= e ~: A -> G |= e ~: B -> A = B.
Proof.
  intros G e A B Typ1 Typ2.
  gen B.
  induction Typ1;
    introv Typ2;
    try solve [inverts* Typ2].
  - inverts* Typ2.
    gen B.
    induction H0;
      introv Typ2;
      inverts* Typ2.
    forwards*: IHVtyping1.
    forwards*: IHVtyping2.
    congruence.
  - (* f_var *)
    inverts* Typ2.
    forwards*: binds_unique H0 H4 H2.
  - (* e_app *)
    inverts* Typ2.
    forwards*: IHTyp1_1.
    forwards*: IHTyp1_2.
    subst.
    inverts* H0.
  - (* and *)
    inverts* Typ2.
    forwards*: IHTyp1_1.
    forwards*: IHTyp1_2.
    congruence.
Qed.
*)

(* typing canonical *)