Require Import HahnBase HahnRelationsBasic.
Require Import Setoid.
Set Implicit Arguments.

Section FunEq.

  Variable A B : Type.
  Variable f : A -> B.

  Definition funeq (r : relation A) := forall a b (H: r a b), f a = f b.

  Lemma funeq_union r t (H1: funeq r) (H2: funeq t) : funeq (r ∪ t).
  Proof. firstorder. Qed.

  Lemma funeq_inter_l r t (H1: funeq r) : funeq (r ∩ t).
  Proof. firstorder. Qed.

  Lemma funeq_inter_r r t (H1: funeq t) : funeq (r ∩ t).
  Proof. firstorder. Qed.

  Lemma funeq_seq r t (H1: funeq r) (H2: funeq t) : funeq (r ⨾ t).
  Proof. eby red; ins; destruct H; desc; etransitivity; [apply H1 | apply H2]. Qed.

  Lemma funeq_ct r (H: funeq r) : funeq r⁺.
  Proof. eby red; ins; induction H0; eauto; etransitivity. Qed.

  Lemma funeq_cr r (H: funeq r) : funeq r^?.
  Proof. red; ins; red in H0; desf; subst; auto. Qed.

  Lemma funeq_rt r (H: funeq r) : funeq r＊.
  Proof. eby red; ins; induction H0; eauto; etransitivity. Qed.

  Lemma funeq_restr r (H: funeq r) dom : funeq (restr_rel dom r).
  Proof. firstorder. Qed.

  Lemma funeq_restr_eq r (H: funeq r) C (dom : A -> C) : funeq (restr_eq_rel dom r).
  Proof. firstorder. Qed.

  Lemma funeq_restr_eq_rel r : funeq (restr_eq_rel f r).
  Proof. firstorder. Qed.

  Lemma funeq_eqv_rel dom : funeq ⦗dom⦘.
  Proof. by red; ins; red in H; desc; subst. Qed.

  Lemma funeq_transp r (H: funeq r) : funeq r⁻¹.
  Proof. firstorder. Qed.

  Lemma funeq_minus r t (H: funeq r) : funeq (r \ t).
  Proof. firstorder. Qed.

  Lemma funeq_irreflexive r t (H: funeq r)
    (IRR: irreflexive (restr_eq_rel f t ⨾ r)) : irreflexive (t ⨾ r).
  Proof.
    unfold funeq, irreflexive, seq, restr_eq_rel in *.
    ins; desf; eauto 8 using eq_sym.
  Qed.

End FunEq.

Global Hint Unfold funeq : unfolderDb.
Global Hint Resolve funeq_union funeq_inter_l funeq_inter_r : hahn.
Global Hint Resolve funeq_seq funeq_ct funeq_cr funeq_rt : hahn.
Global Hint Resolve funeq_restr funeq_restr_eq funeq_restr_eq_rel : hahn.
Global Hint Resolve funeq_eqv_rel funeq_transp funeq_minus : hahn.

Add Parametric Morphism A B f : (@funeq A B f) with signature
  inclusion --> Basics.impl as funeq_mori.
Proof.
  unfold inclusion, funeq, Basics.impl; eauto.
Qed.

Add Parametric Morphism A B f : (@funeq A B f) with signature
  same_relation ==> iff as funeq_more.
Proof.
   unfold same_relation; split; desc; [rewrite H0|rewrite H]; eauto.
Qed.


Require Import generic_soundness.

Require Import reduction.

Require Import proofsystem.
Set Implicit Arguments.

Require Import Setoid.
Require Import Relation_Definitions.

(* For all-path reachability,
   the approximation is indexed by a number of steps, and says that
   every path which terminates within the bound encountered a state
   matching the target state.
 *)

Parameter cfg : Set.
Parameter SF : cfg -> cfg -> Prop.

(* Lemmas *)
Definition nat_pred n n' := n = 1+n'.
Lemma le_iff_clos_nat_pred : forall n m,
                               clos nat_pred false n m <-> m <= n.
Proof.
split.
induction 1.
auto.
unfold nat_pred in H;subst. auto.
eauto with arith.

induction 1.
constructor.
apply clos_trans with m0.
apply clos_step. reflexivity.
assumption.
Qed.

Lemma nat_le_ind : forall (P : nat -> Prop), forall n,
  (forall n0, n0 <= n ->
              (forall n', n0 = 1+n' -> P n') ->
              P n0)
  -> P n.
induction n.
intro H; apply H. constructor. intros. discriminate.
intro H.
apply H.
constructor.
intros.
injection H0;clear H0;intro H0.
subst n'.
auto.
Qed.

Inductive ix_al_reach (P : cfg -> Prop) (c : cfg) : bool -> nat -> Prop :=
  | al_exhausted : forall s, ix_al_reach P c s 0
  | al_here : P c -> forall n, ix_al_reach P c false n
  | al_later : forall n, (exists c', SF c c') ->
                         (forall c', SF c c' -> ix_al_reach P c' false n) ->
                         forall s, ix_al_reach P c s (Datatypes.S n)
  .

Lemma al_reach_unstrict P c n : ix_al_reach P c true n -> ix_al_reach P c false n.
  Proof. destruct 1;constructor;assumption. Qed.

Lemma al_reach_pred P c s n : ix_al_reach P c s (S n) -> ix_al_reach P c s n.
remember (S n) as Sn eqn:HeqSn; intro H; revert n HeqSn; induction H.
(* exhausted *)
discriminate.
(* here *)
constructor;assumption.
(* later *)
intros.
injection HeqSn;clear HeqSn;intro HeqSn.
destruct n0;constructor;auto.
Qed.

Lemma al_reach_impl (P Q : cfg -> Prop) : (forall c, P c -> Q c) -> forall c s n,
                            ix_al_reach P c s n -> ix_al_reach Q c s n.
induction 2;constructor;auto.
Qed.

Require Import Arith.

Lemma min_half_suc (P : nat -> Prop) n m :
  P (S (min n m)) -> P (min n m) -> P (min (S n) m).
Proof.
  destruct (le_lt_dec m n);
  rewrite ?Nat.min_r, ?Nat.min_l by (auto using le_S, le_Sn_le);
  trivial.
Qed.

Lemma al_reach_join P c s1 n1 s2 n2 :
  ix_al_reach (fun c' => ix_al_reach P c' s2 n2) c s1 n1
  -> ix_al_reach P c s1 (min n1 (if s1 then S n2 else n2)).
induction 1.
+ (* Exhausted *)
  rewrite Nat.min_0_l.
  constructor.
+ (* Here *)
  assert (min n n2 <= n2) by apply Nat.le_min_r.
  revert H0; generalize (min n n2); intros n0 Hle.
  induction Hle.
  destruct s2;auto using al_reach_unstrict.
  auto using al_reach_pred.
+ (* Later *)
  assert (ix_al_reach P c s (S (min n n2))) as IH by (constructor;assumption).
  clear -IH.
  destruct s.
  assumption.
  pose proof (al_reach_pred IH).
  apply min_half_suc; assumption.
Qed.

Module AllPathSemantics <: ReachabilitySemantics.

(* Definitions *)
Definition index : Set := nat.
Definition ix_rel (i1 i2 : index) : Prop := (i1 = S i2).

Definition holds strict env (phi1 phi2 : formula cfg env) i :=
  forall rho gamma, phi1 rho gamma -> ix_al_reach (phi2 rho) gamma strict i.

(* Nontrivial proofs *)
(** Circularity **)
Lemma ix_rel_ind : forall env (phi phi' : formula cfg env),
      forall i0,
      (forall i, clos ix_rel false i0 i ->
                   (forall i', ix_rel i i' -> holds true phi phi' i') ->
                   holds true phi phi' i)
       -> holds true phi phi' i0.
intros.
apply nat_le_ind.
intros.
rewrite <- le_iff_clos_nat_pred in H0.
auto.
Qed.

Create HintDb holds_solve discriminated.
Hint Transparent holds : holds_solve.
Hint Unfold holds : holds_solve.

Hint Resolve al_here al_exhausted : holds_solve.
(* Hint Resolve al_reach_pred al_reach_unstrict : holds_solve. *)

Ltac holds_start := unfold index;intros;
  repeat match goal with
  | [|- holds _ _ _ _] => unfold holds;intros
  | [H : ix_rel ?l _ |- _] => unfold ix_rel in H;rewrite H in * |- *;clear H;clear l
  (* Use holds hypotheses *)
  | [H : holds _ ?phi _ _, Hphi : ?phi _ ?gamma |- _]=> specialize (H _ _ Hphi)
  | [H : forall _ _, ?phi _ _ -> _, Hphi : ?phi _ _ |- _] =>
    specialize (H _ _ Hphi)
  end.
(*
Ltac holds_start := intros;
  repeat match goal with
  (* open unnecessary uses of holds/indices *)
  | [i : index |- _] => destruct i
  | [H : holds _ _ _ (exist _ _ _) |- _] => unfold holds in H;simpl proj1_sig in H
  | [|- holds _ _ _ (exist _ _ _)] => unfold holds;simpl proj1_sig;unfold holds';intros
  | [H : ix_rel (exist _ _ _) _ |- _] => unfold ix_rel in H; simpl proj1_sig in H
  | [H : ix_rel _ (exist _ _ _) |- _] => unfold ix_rel in H; simpl proj1_sig in H
  (* Instantate a hypothesis quantified over ix_rel, as appears in strict trans *)
  | [H : forall i', ix_rel (exist _ ?x ?t) i' -> holds _ ?phi _ i',
       Hphi : ?phi _ ?x0 |- _ ] =>
    let Hprog := fresh "Hprog" in
    assert (clos S true x x0) as Hprog by clos_solve;
    let x1 := fresh "x1" with Hstep := fresh "Hstep" with Hreach := fresh "Hreach" in
    apply clos_true_step in Hprog; destruct Hprog as [x1 [Hstep Hreach]];
    specialize (H (exist _ x1 (terminates_next t _ Hstep)) Hstep)
  (* Use holds' hypotheses *)
  | [H : holds' _ ?phi _ ?x, Hphi : ?phi _ ?gamma |- _]=>
    let Hreach := fresh "Hreach" in
    assert (clos S false x gamma) as Hreach by clos_solve;
    specialize (H _ _ Hreach Hphi)
  | [H : exists _, clos S _ _ _ /\ _ |- _] => destruct H as [? []]
  end.
*)
Ltac holds_finish :=
  solve[auto with holds_solve
       |intuition
          (repeat match goal with
             | [H : forall _ _, ?phi _ _ -> _, Hphi : ?phi _ _ |- _] =>
               specialize (H _ _ Hphi)
           end;firstorder with holds_solve)
       ].
Ltac holds_finish' lem :=
  solve[eauto using lem with holds_solve
       |intuition
          (repeat match goal with
             | [H : forall _ _, ?phi _ _ -> _, Hphi : ?phi _ _ |- _] =>
               specialize (H _ _ Hphi)
           end;firstorder using lem with holds_solve)
       ].

Ltac holds_tac := holds_start;holds_finish.

(* Simple properties *)
Lemma holds_strict_later : forall env phi1 phi2 i,
                             @holds true env phi1 phi2 i ->
                             forall i', ix_rel i i' ->
                                        holds true phi1 phi2 i'.
holds_start. holds_finish' al_reach_pred.
Qed.

Lemma holds_unstrict : forall env phi1 phi2 i,
                         @holds true env phi1 phi2 i -> holds false phi1 phi2 i.
holds_start. holds_finish' al_reach_unstrict.
Qed.

Lemma holds_step : forall env (phi phi' : formula cfg env),
    (forall (e : env) (c : cfg),
      phi e c ->
      (exists c2 : cfg, SF c c2) /\ (forall c2 : cfg, SF c c2 -> phi' e c2)) ->
    forall i, holds true phi phi' i.
holds_start.
destruct H.
apply al_reach_pred;apply al_later;eauto with holds_solve.
Qed.

Lemma holds_refl : forall env phi i, @holds false env phi phi i.
holds_tac.
Qed.

Lemma holds_case :
    forall strict env (phi phi1 phi' : formula cfg env) i,
      holds strict phi phi' i -> holds strict phi1 phi' i ->
      holds strict (fun (e : env) (g : cfg) => phi e g \/ phi1 e g) phi' i.
holds_tac.
Qed.

Lemma holds_mut_conseq :
    forall strict env1 (phi1 phi2 : formula cfg env1)
                  env2 (phi1' phi2' : formula cfg env2),
     (forall gamma rho,
        phi1 rho gamma ->
        exists rho', phi1' rho' gamma /\
                     forall gamma', phi2' rho' gamma' -> phi2 rho gamma') ->
    forall i, holds strict phi1' phi2' i ->
              holds strict phi1 phi2 i.
holds_start;holds_finish' al_reach_impl.
Qed.

(** Transitivity **)
Lemma holds_trans : forall env phi phi' phi'' i,
    @holds false env phi phi' i ->
    holds false phi' phi'' i ->
    holds false phi phi'' i.
holds_start.
unfold holds in H0.
apply (al_reach_impl _ (H0 rho)) in H.
clear -H.
apply al_reach_join in H.
rewrite Nat.min_idempotent in H;assumption.
Qed.

Lemma holds_trans_strict : forall env phi phi' phi'' i,
    @holds true env phi phi' i ->
    (forall i' : index, ix_rel i i' -> holds false phi' phi'' i') ->
   holds true phi phi'' i.
holds_start.
destruct i.
constructor.
apply (al_reach_impl _ (H0 _ (eq_refl _) rho)) in H.
clear -H.
apply al_reach_join in H.
rewrite Nat.min_idempotent in H;assumption.
Qed.

Definition cfg := cfg.
Definition S := SF.

End AllPathSemantics.

Module AllPathSoundness := Soundness AllPathSemantics.

(* Now, define two versions of full soundness and show equivalences *)
(* We'll end up using some assumptions about decidability of
   stuckness and matching to show equivalence of tree- and path-based
   properties *)

Inductive closed_path (start : cfg) : Set :=
  | path_end : ~(exists c', SF start c') -> closed_path start
  | path_step : forall c', SF start c' -> closed_path c' -> closed_path start.
Fixpoint path_length c (path : closed_path c) : nat :=
  match path with
    | path_end _ => 0
    | path_step _ rest => 1 + path_length rest
  end.
Definition drop1 c (path : closed_path c) : {c' : cfg & closed_path c'} :=
  match path with
    | path_end final => existT _ c (path_end final)
    | @path_step _ c' _ rest => existT _ c' rest
  end.
Lemma drop_rebuild c (path : closed_path c) : path_length path <> 0 ->
   exists step : SF c (projT1 (drop1 path)), path = path_step step (projT2 (drop1 path)).
intro Hlen;destruct path;[exfalso|];eauto.
Qed.

Lemma drop_len c (path : closed_path c) :
  path_length (projT2 (drop1 path)) = pred (path_length path).
Proof.
destruct path;reflexivity.
Qed.

Inductive InPath c : forall c', closed_path c' -> Set :=
  | in_here : forall p, @InPath c c p
  | in_later : forall c' c'' (s : SF c' c'') (p' : closed_path c''),
                 InPath c p' -> InPath c (path_step s p').

Fixpoint tail_at c c' (path : closed_path c') (pf : InPath c path) : closed_path c :=
  match pf with
    | in_here p => p
    | in_later _ pf' => tail_at pf'
  end.

Lemma tail_len c c' (path : closed_path c') (pf : InPath c path) :
  path_length (tail_at pf) <= path_length path.
Proof.
induction pf;simpl;auto with arith.
Qed.

Inductive squash (A : Type) : Prop :=
  | inhabited : A -> squash A.

Definition StuckDecidable := forall c, (exists c', SF c c') \/ ~(exists c', SF c c').

Definition path_reach (P : cfg -> Prop) (c : cfg) : Prop :=
  forall (path : closed_path c), exists c', P c' /\ squash (InPath c' path).

Lemma path_reach_next P c c' : SF c c' -> ~ P c -> path_reach P c -> path_reach P c'.
intros Hstep Hnot_here Hpath.
unfold path_reach.
intro path.
specialize (Hpath (path_step Hstep path)).
destruct Hpath as [c0 [HPc0 Hpath']].
exists c0;split;[exact HPc0|].
destruct Hpath'.
remember (path_step Hstep path) as path' in H.
destruct H.
exfalso;auto.
inversion Heqpath'.
rewrite EqdepFacts.eq_sigT_sig_eq in H2.
destruct H2.
destruct x.
simpl in e.
subst p'.
constructor;assumption.
Qed.

Lemma path_reach_approx P (P_dec : forall c, P c \/ ~P c) (stuck_dec : StuckDecidable) :
  forall c, path_reach P c -> (forall n, ix_al_reach P c false n).
intros c H n. revert n c H. induction n; intros c H.
apply al_exhausted.
(* Need information about complete paths to proceed,
   if c is stuck we can't use later
 *)
destruct (stuck_dec c).
(* When the configuration isn't stuck, it could still be the case
   that some successors don't reach P, and path_reach P c holds
   only because P c is true now. *)
destruct (P_dec c);eauto using ix_al_reach, path_reach_next.
(* When the configuraton is stuck we can prove P holds here *)
+ specialize (H (path_end H0)).
  destruct H as [c' [Pc' Hhere]].
  replace c' with c in Pc'.
  apply al_here;assumption.
  destruct Hhere. inversion H. reflexivity.
Qed.

Lemma approx_path_reach P : forall c, (forall n, ix_al_reach P c false n) -> path_reach P c.
intros.
unfold path_reach.
intros.
specialize (H (S (path_length path))).
induction path.
simpl in H;inversion H;subst.
eauto using squash, InPath.
exfalso; firstorder.
inversion H;subst.
eauto using squash, InPath.
specialize (IHpath (H3 _ s));clear -IHpath;
firstorder using squash, InPath.
Qed.

(* Define unconditional versions of all-path reachability *)
CoInductive reach (P : cfg -> Prop) (c : cfg) : bool -> Prop :=
  | here : P c -> reach P c false
  | later : (exists c', SF c c') ->
               (forall c', SF c c' -> reach P c' false) ->
               forall s, reach P c s
.

Lemma reach_approx P c s : reach P c s -> forall n, ix_al_reach P c s n.
intros H n; revert s c H;induction n;intros s c H.
constructor.
inversion H;[apply al_here|apply al_later];auto.
Qed.

Lemma approx_defer P c : ~ P c ->
  (forall n, ix_al_reach P c false n) ->
  forall c', SF c c' -> (forall n, ix_al_reach P c' false n).
intros.
specialize (H0 (S n)).
inversion H0.
destruct (H H2).
auto.
Qed.

Lemma approx_reach P (P_dec : forall c, P c \/ ~ P c)
  (stuck_dec : StuckDecidable):
  forall c, (forall n, ix_al_reach P c false n) -> reach P c false.
cofix.
intros c Happrox.
destruct (stuck_dec c).
(* Later *)
destruct (P_dec c).
apply here; assumption.
apply later.
assumption.
intros.
apply approx_reach.
clear approx_reach.
apply approx_defer with c;assumption.
(* Here *)
clear approx_reach.
apply here.
specialize (Happrox 1).
inversion Happrox.
assumption.
destruct (H H1).
Qed.

Definition holds' env (phi1 phi2 : formula cfg env) strict :=
  forall rho gamma, phi1 rho gamma -> reach (phi2 rho) gamma strict.
Definition system_holds (A : system cfg) :=
  forall env (phi1 phi2 : formula cfg env),
    A env phi1 phi2 -> holds' phi1 phi2 true.

Theorem soundness : forall (A : system cfg) env (phi1 phi2 : formula cfg env),
                      (forall rho gamma, phi2 rho gamma \/ ~phi2 rho gamma) ->
                      StuckDecidable ->
                      IS cfg SF None A env phi1 phi2 ->
                      system_holds A ->
                      holds' phi1 phi2 false.
intros A env phi1 phi2 phi2_dec stuck_dec pf A_holds.
unfold holds'.
intros rho gamma Hphi1.
apply (approx_reach (phi2_dec rho) stuck_dec).
intro n.
revert rho gamma Hphi1.
fold (AllPathSemantics.holds false phi1 phi2 n).
apply (AllPathSoundness.soundness pf);trivial.
clear -A_holds.
unfold AllPathSoundness.system_holds.
intros.
specialize (A_holds _ _ _ H).
unfold AllPathSemantics.holds.
intros.
apply reach_approx.
auto.
Qed.


From Rela Require Import Aexp.
From Rela Require Import Bexp.
From Rela Require Import Com.
From Rela Require Import Proc.
From Rela Require Import Sigma.
From Rela Require Import Loc.
From Rela Require Vcg.
From Rela Require Import Hoare_Triple.
Import Bool.Bool.
Import Arith.

From Coq Require Import Lists.List.
Import ListNotations.

Import Vcg.Why3_Set.
Import Vcg.Assn_b.

(** Definition of logical banching **)

Inductive branch (A B C : Prop) : Prop :=
  | Then : A -> B -> branch A B C
  | Else : ~ A -> C -> branch A B C.

Lemma branch_simpl : forall A B C,
branch A B C -> (A -> B) /\ (~A -> C).
Proof.
intros.
destruct H.
+ split.
  * auto.
  * intros. contradiction H1.
+ split.
  * intros. contradiction H1.
  * auto.
Qed.

(** Partial translation of boolean expression into Prop **)

Fixpoint simpl_bassn b st :=
match b with
| BTrue => True
| BFalse => False
| BEq a1 a2 => aeval st a1 = aeval st a2
| BLe a1 a2 => aeval st a1 <= aeval st a2
| BAnd b1 b2 => (simpl_bassn b1 st) /\ (simpl_bassn b2 st)
| BOr b1 b2 => (simpl_bassn b1 st) \/ (simpl_bassn b2 st)
| BNot (BEq a1 a2) => aeval st a1 <> aeval st a2
| BNot (BLe a1 a2) => aeval st a2 < aeval st a1
| BNot BTrue => False
| BNot BFalse => True
| _ => bassn b st
end.

Lemma bassn_simpl_bassn : forall b st , bassn b st -> simpl_bassn b st.
Proof.
unfold bassn.
intros.
induction b.
* auto.
* auto.
* simpl.
  apply Is_true_eq_true in H.
  simpl in H.
  apply Nat.eqb_eq in H.
  assumption.
* simpl.
  apply Is_true_eq_true in H.
  simpl in H.
  apply Compare_dec.leb_complete in H.
  assumption.
* destruct b;simpl.
  + auto.
  + auto.
  + apply Nat.eqb_neq.
    apply negb_true_iff.
    apply Is_true_eq_true.
    apply H.
  + apply Nat.leb_gt.
    apply negb_true_iff.
    apply Is_true_eq_true.
    apply H.
  + auto.
  + auto.
  + auto.
* simpl. apply Is_true_eq_true in H.
  simpl in H.
  apply andb_true_iff in H.
  split.
  + apply IHb1.
    apply Is_true_eq_left.
    apply H.
  + apply IHb2.
    apply Is_true_eq_left.
    apply H.
* simpl. apply Is_true_eq_true in H.
  simpl in H.
  apply orb_true_iff in H.
  destruct H.
  + apply or_introl.
    apply IHb1.
    apply Is_true_eq_left.
    assumption.
  + apply or_intror.
    apply IHb2.
    apply Is_true_eq_left.
    assumption.
Qed.

Lemma bassn_not_simpl_bassn_not : forall b st , ~ bassn b st -> ~ simpl_bassn b st.
Proof.
unfold bassn.
intros.
induction b.
* auto.
* auto.
* simpl.
  apply Nat.eqb_neq.
  apply negb_true_iff.
  apply negb_prop_intro in H.
  apply Is_true_eq_true in H.
  apply H.
* simpl.
  apply Nat.nle_gt.
  apply Nat.leb_gt.
  apply negb_true_iff.
  apply negb_prop_intro in H.
  apply Is_true_eq_true in H.
  apply H.
* destruct b;simpl.
  + auto.
  + auto.
  + apply Nat.eq_dne.
    apply negb_prop_intro in H.
    apply Is_true_eq_true in H.
    simpl in H.
    rewrite negb_involutive in H.
    apply Nat.eqb_eq.
    apply H.
  + apply Nat.nlt_ge.
    apply negb_prop_intro in H.
    apply Is_true_eq_true in H.
    simpl in H.
    rewrite negb_involutive in H.
    apply Nat.leb_le.
    apply H.
  + auto.
  + auto.
  + auto.
* simpl.
  intros H1.
  destruct H1.
  apply negb_prop_intro in H.
  apply Is_true_eq_true in H.
  apply negb_true_iff in H.
  simpl in H.
  apply andb_false_iff in H.
  destruct H.
  + apply negb_true_iff in H.
    apply Is_true_eq_left in H.
    apply negb_prop_elim in H.
    apply IHb1 in H.
    contradiction H.
  + apply negb_true_iff in H.
    apply Is_true_eq_left in H.
    apply negb_prop_elim in H.
    apply IHb2 in H.
    contradiction H.
* apply negb_prop_intro in H.
  apply Is_true_eq_true in H.
  apply negb_true_iff in H.
  simpl in H.
  apply orb_false_iff in H.
  destruct  H.
  simpl.
  intros H1.
  destruct H1.
  + apply negb_true_iff in H.
    apply Is_true_eq_left in H.
    apply negb_prop_elim in H.
    apply IHb1 in H.
    contradiction H.
  + apply negb_true_iff in H0.
    apply Is_true_eq_left in H0.
    apply negb_prop_elim in H0.
    apply IHb2 in H0.
    contradiction H0.
Qed.

(** Defintion of optimized verification condition generator:
    - We do not have an exponential growth of the size of the formulas due
      to condition branching.
    - Boolean expression are translated to Prop for convenience during proof
      of verification conditions.
**)

Definition suite : Type := Prop -> Vcg.history -> Prop.

Fixpoint tc (c: com) (m m': Sigma.sigma) (h: Vcg.history)
            (cl: Phi.phi) (fin: suite): Prop :=
    match c with
    | CSkip => fin (m' = m) (m :: h)
    | CAss x a => fin (m' = set m x (aeval m a)) (m :: h)
    | CAssr x a => fin (m' = set m (m x) (aeval m a)) (m :: h)
    | CAssert b =>  fin (b (m :: h) /\ m = m') (m :: h)
    | CSeq p1 p2 => forall m'',
        tc p1 m m'' h cl (fun f1 h => tc p2 m'' m' h cl
                                   (fun f2 h => fin (f1 /\ f2) h ))
    | CIf b p1 p2 =>
        tc p1 m m' h cl (fun p1 _ =>
        tc p2 m m' h cl (fun p2 _ =>
            fin (branch (simpl_bassn b m) p1 p2) (m :: h)))
    | CWhile b p inv => fin (inv (m :: h) /\ inv (m' :: h) /\ ~(simpl_bassn b m')) (m :: h)
    | CCall f => fin ((get_pre (cl f)) m /\ (get_post (cl f)) m' m) (m :: h)
    end.

(** Facts about verification condition generator **)

Ltac ltc1 := simpl; intros m m' l suite1 suite2 H H0;
             apply H; apply H0.

Lemma consequence_tc_suite :
forall p cl m m' l (suite1 suite2 : suite),
(forall p l, suite1 p l -> suite2 p l) ->
tc p m m' l cl suite1 -> tc p m m' l cl suite2.
Proof.
intros p cl.
induction p.
  * ltc1.
  * ltc1.
  * ltc1.
  * ltc1.
  * simpl. intros.
    eapply IHp1 with (fun p h => tc p2 m'' m' h cl (fun f2 h => suite1 (p /\ f2) h)).
    - intros.
      eapply IHp2 with (fun f h => suite1(p /\ f) h).
       + intros. apply H. assumption.
       + apply H1.
    - apply H0.
  * simpl. intros.
    eapply IHp1 with
    (fun p _ => tc p2 m m' l cl (fun f2 _ => suite1 (branch (simpl_bassn b m) p f2) (m ::l))).
    - intros.
      eapply IHp2 with (fun f _ => suite1 (branch (simpl_bassn b m) p f) (m :: l)).
       + intros. apply H. assumption.
       + apply H1.
    - apply H0.
  * ltc1.
  * ltc1.
Qed.

Lemma intros_tc :
forall p m m' l cl (debut : Prop) (suite : suite),
tc p m m' l cl (fun f h => debut -> suite f h) ->
(debut -> tc p m m' l cl suite).
Proof.
induction p;simpl.
* intros. apply H. assumption.
* intros. apply H. assumption.
* intros. apply H. assumption.
* intros. apply H. assumption.
* intros.
  eapply consequence_tc_suite.
  + intros.
    generalize H0.
    apply IHp2.
    apply H1.
  + apply H.
* intros.
  eapply consequence_tc_suite.
  + intros.
    generalize H0.
    apply IHp2.
    apply H1.
  + apply H.
* intros. apply H. assumption.
* intros. apply H. assumption.
Qed.

Lemma prenexe_tc:
forall (A:Type) p m m' l cl (suite : A -> suite),
(forall s, tc p m m' l cl (suite s)) ->
tc p m m' l cl (fun f h => forall s,suite s f h).
Proof.
induction p;simpl.
* intros. apply H.
* intros. apply H.
* intros. apply H.
* intros. apply H.
* intros.
  eapply consequence_tc_suite.
  + intros p l0 He.
    apply IHp2.
    apply He.
  + apply IHp1.
    intros.
    apply H.
* intros.
  eapply consequence_tc_suite.
  + intros p l0 He.
    apply IHp2.
    apply He.
  + apply IHp1.
    intros.
   apply H.
* intros. apply H.
* intros. apply H.
Qed.

Lemma opt_1_true:
forall p1 p2 b m m' l cl (s : Prop),
simpl_bassn b m ->
tc p1 m m' l cl (fun f1 _ =>
tc p2 m m' l cl (fun f2 _ =>  branch (simpl_bassn b m) f1 f2 -> s)) ->
tc p1 m m' l cl (fun f1 _ =>
tc p2 m m' l cl (fun f2 _ => f1 -> s)).
Proof.
intros.
apply consequence_tc_suite with
             (fun f1 _ => tc p2 m m' l cl (fun f2 _ =>
              branch (simpl_bassn b m) f1 f2 -> s)).
* intros.
  apply consequence_tc_suite with
        (fun f2 _ => branch (simpl_bassn b m) p f2 -> s).
  - intros. apply H2.
    apply Then.
    all: try assumption.
  - assumption.
* assumption.
Qed.

Lemma opt_1_false:
forall p1 p2 b m m' l cl (s : Prop),
~simpl_bassn b m ->
tc p1 m m' l cl (fun f1 _ =>
tc p2 m m' l cl (fun f2 _ =>  branch (simpl_bassn b m) f1 f2 -> s)) ->
tc p1 m m' l cl (fun f1 _ =>
tc p2 m m' l cl (fun f2 _ => f2 -> s)).
Proof.
intros.
apply consequence_tc_suite with
             (fun f1 _ => tc p2 m m' l cl (fun f2 _ =>
              branch (simpl_bassn b m) f1 f2 -> s)).
* intros.
  apply consequence_tc_suite with
        (fun f2 _ => branch (simpl_bassn b m) p f2 -> s).
  - intros. apply H2.
    apply Else.
    all: try assumption.
  - assumption.
* assumption.
Qed.

Lemma simpl_tc :
forall p m m' l cl (s : Prop),
tc p m m' l cl (fun _ _ => s) -> s .
Proof.
induction p;simpl.
* intros. apply H.
* intros. apply H.
* intros. apply H.
* intros. apply H.
* intros.
  assert (H1: tc p1 m m l cl (fun _ _ => s)).
  { intros.
    eapply consequence_tc_suite with
    ((fun _ h => tc p2 m m' h cl (fun _ _ => s))).
    + intros.
      eapply IHp2.
      apply H0.
    + apply H.
  }
  eapply IHp1.
  apply H1.
* intros.
  eapply IHp2.
  eapply IHp1.
  apply H.
* intros. apply H.
* intros. apply H.
Qed.

Lemma true_tc :
forall p m m' l cl,
True -> tc p m m' l cl (fun _ _ => True).
Proof.
induction p;simpl;intros.
all: try auto.
* eapply consequence_tc_suite.
  + intros.
    apply IHp2.
    apply H0.
  + apply IHp1. auto.
* eapply consequence_tc_suite.
  + intros.
    apply IHp2.
    apply H0.
  + apply IHp1. auto.
Qed.

Lemma rev_simpl_tc :
forall p m m' l cl (s : Prop),
s -> tc p m m' l cl (fun _ _ => s) .
Proof.
induction p;simpl.
* intros. apply H.
* intros. apply H.
* intros. apply H.
* intros. apply H.
* intros.
  apply consequence_tc_suite with (fun _ _ => s).
  + intros.
    apply IHp2.
    apply H.
  + apply IHp1.
    apply H.
* intros.
  apply consequence_tc_suite with (fun _ _ => s).
  + intros.
    apply IHp2.
    apply H.
  + apply IHp1.
    apply H.
* intros. apply H.
* intros. apply H.
Qed.

(* The optimized version implies the naive version *)

Lemma tc_same :
forall p cl m l (suite1 : Vcg.suite),
  (forall m', tc p m m' l cl (fun p h => p -> suite1 m' h)) ->
    Vcg.tc p m l cl suite1.
Proof.
intros.
generalize dependent suite1.
generalize dependent l.
generalize dependent m.
induction p;simpl.
* intros. apply H. symmetry. assumption.
* intros. apply H. assumption.
* intros. apply H. assumption.
* intros. apply H. auto.
* intros.
  eapply Vcg.consequence_tc_suite.
  + intros.
    apply IHp2.
    apply H0.
  + apply IHp1.
    intros.
    eapply consequence_tc_suite.
    - intros p l0 He Hp m'0.
      generalize dependent Hp.
      generalize dependent m'0.
      apply He.
    - apply prenexe_tc.
      intros.
      eapply consequence_tc_suite.
      ** intros p l0 He.
         apply intros_tc.
         eapply consequence_tc_suite with
         (fun f h  => p /\ f -> suite1 s h).
         ++ auto.
         ++ apply He.
      ** apply H.
* intros.
  split;intros.
  + apply IHp1.
    intros.
    specialize (H m').
    apply bassn_simpl_bassn in H0.
    specialize (opt_1_true p1 p2 b m m' l cl (suite1 m' (m :: l)) H0 H).
    intros.
    eapply consequence_tc_suite.
    - intros p l0 He.
      apply (simpl_tc p2 m m' l cl (p -> suite1 m' (m :: l))).
      apply He.
    - apply H1.
  + apply IHp2.
    intros.
    specialize (H m').
    apply bassn_not_simpl_bassn_not in H0.
    specialize (opt_1_false p1 p2 b m m' l cl (suite1 m' (m :: l)) H0 H).
    intros.
    apply
      (simpl_tc p1 m m' l cl (tc p2 m m' l cl (fun p _ => p -> suite1 m' (m :: l)))).
    apply H1.
* intros.
  apply H.
  apply bexp_eval_false in H2.
  apply bassn_not_simpl_bassn_not in H2.
  auto.
* intros.
  apply H.
  auto.
Qed.

(** Definition of a verification condition generator for the auxiliary goals **)

Fixpoint tc' (c : com) (m: Sigma.sigma) (h: Vcg.history) (cl: Phi.phi) : Prop :=
match c with
 | CSkip => True
 | CAss x a => True
 | CAssr x a => True
 | CAssert b => b (m :: h)
 | CSeq p1 p2 => tc' p1 m h cl /\
                 forall m'',
                 tc p1 m m'' h cl (fun f h => f -> tc' p2 m'' h cl)
 | CIf b p1 p2 =>
      (simpl_bassn b m -> tc' p1 m h cl) /\ (~simpl_bassn b m -> tc' p2 m h cl)
 | CWhile b p inv => inv (m :: h) /\
                     (forall m', simpl_bassn b m' ->
                                 inv (m' :: h) ->
                                 tc' p m' h cl) /\
                     (forall m' m'', simpl_bassn b m' ->
                                     inv (m' :: h) ->
                   tc p m' m'' h cl (fun f _ => f -> inv (m'' :: h)))
 | CCall f => (get_pre (cl f)) m
end.

(* The optimized version implies the naive version *)

Lemma tc'_same : forall p cl m l, tc' p m l cl -> Vcg.tc' p m l cl.
Proof.
induction p; simpl.
* intros. auto.
* intros. auto.
* intros. auto.
* intros. apply H.
* intros.
  split.
  - apply IHp1.
    apply H.
  - apply tc_same.
    intros.
    eapply consequence_tc_suite with (fun f h  => f -> tc' p2 m' h cl).
    + intros.
      apply IHp2.
      auto.
    + apply H.
* intros.
  split;intros.
  - apply IHp1.
    apply H.
    apply bassn_simpl_bassn in H0.
    assumption.
  - apply IHp2.
    apply H.
    apply bassn_not_simpl_bassn_not in H0.
    assumption.
* intros.
  split.
  - apply H.
  - split;intros.
    + apply IHp.
      apply H.
      apply bassn_simpl_bassn in H0.
      assumption.
      assumption.
    + apply tc_same.
      intros.
      apply H.
      ** apply bassn_simpl_bassn.
         assumption.
      ** assumption.
* intros. apply H.
Qed.

(** Definition of a verification condition generator for procedures **)

Definition tc_p (ps: Psi.psi) (cl : Phi.phi) : Prop :=
   forall f m m', (get_pre (cl f)) m ->
   tc' (ps f) m Vcg.empty_history cl /\
   tc (ps f) m m' Vcg.empty_history cl (fun p _ => p -> (get_post (cl f)) m' m).

(* The optimized version implies the naive version *)

Theorem tc_p_same :
forall ps cl,
tc_p ps cl -> Vcg.tc_p ps cl.
Proof.
intros.
unfold Vcg.tc_p.
split;intros.
* apply tc'_same.
  apply H.
  all: try assumption.
* apply tc_same.
  intros.
  apply H.
  apply H0.
Qed.

(** Definition of a verification condition generator for the auxiliary goals
    returning a list of goals **)

Module Tc'_list.

Definition continuation (p1: com) (cl: Phi.phi)
                       (a : Vcg.suite) (m : sigma) (h: Vcg.history) :=
           forall m'' : sigma, tc p1 m m'' h cl (fun f h => f -> a m'' h).

Fixpoint tc'_list (c : com) (cl: Phi.phi) : list Vcg.suite :=
match c with
 | CSkip => []
 | CAss x a => []
 | CAssr x a => []
 | CAssert b => [fun m h => b (m :: h)]
 | CSeq p1 p2 => tc'_list p1 cl ++
                 map (continuation p1 cl) (tc'_list p2 cl)
 | CIf b p1 p2 => (map (fun a: Vcg.suite =>
                  fun m h => simpl_bassn b m -> a m h) (tc'_list p1 cl))
                  ++
                  (map (fun a: Vcg.suite =>
                  fun m h => ~simpl_bassn b m -> a m h ) (tc'_list p2 cl))
| CWhile b p i => [fun m h => i (m :: h)]
                   ++
                   (map (fun a: Vcg.suite =>
                   fun _ h => forall m',
                   simpl_bassn b m' -> i (m' :: h) ->a m' h) (tc'_list p cl))
                   ++
                   [fun _ h => forall m' m'',
                   simpl_bassn b m' -> i (m' :: h) -> tc p m' m'' h cl (fun f _ => f -> i (m''::h))]
 | CCall f => [fun m _ => (get_pre (cl f)) m]
end.

(* The optimized version implies the naive version *)

Lemma tc'_list_same :
forall p cl m l,
(forall n, (nth n (tc'_list p cl) (fun _ _ => True)) m l) -> tc' p m l cl.
Proof.
induction p;intros.
+ simpl. auto.
+ simpl. auto.
+ simpl. auto.
+ simpl.
  apply (H 0).
+ simpl.
  split.
  * apply IHp1.
    simpl in H.
    intro n.
    specialize (H n).
    destruct (Nat.lt_ge_cases n (length ((tc'_list p1 cl)))).
    - rewrite app_nth1 in H; [assumption|assumption].
    - rewrite nth_overflow; [ auto | assumption].
  * intros.
    eapply consequence_tc_suite.
    - intros.
      apply IHp2.
      intros n.
      generalize dependent H1.
      generalize dependent n.
      apply H0.
    - simpl in H.
      apply prenexe_tc.
      intro n.
      specialize (H ((length(tc'_list p1 cl))+n)).
      rewrite app_nth2_plus in H.
      destruct (Nat.lt_ge_cases n (length ((tc'_list p2 cl)))).
      ++ erewrite nth_indep in H;[|rewrite map_length;assumption].
         rewrite map_nth in H.
         apply H.
      ++ rewrite nth_overflow;[ | assumption].
         eapply consequence_tc_suite.
         ** intros. apply H1.
         ** apply true_tc. auto.
+ simpl.
  split.
  * intros.
    apply IHp1.
    simpl in H.
    intro n.
    specialize (H n).
    destruct (Nat.lt_ge_cases n (length ((tc'_list p1 cl)))).
    - rewrite app_nth1 in H;[ | rewrite map_length;assumption].
      erewrite nth_indep in H;[ | rewrite map_length;assumption].
      rewrite
      (map_nth (fun (a : Vcg.suite) m h => simpl_bassn b m -> a m h)) in H.
      apply H.
      assumption.
    - rewrite nth_overflow;[auto | assumption].
  * intros.
    apply IHp2.
    simpl in H.
    intro n.
    specialize (H ((length(tc'_list p1 cl))+n)).
    erewrite <- map_length in H.
    rewrite app_nth2_plus in H.
    destruct (Nat.lt_ge_cases n (length ((tc'_list p2 cl)))).
    - erewrite nth_indep in H;[ | rewrite map_length;assumption].
      rewrite
      (map_nth (fun (a : Vcg.suite) m h => ~simpl_bassn b m -> a m h)) in H.
      apply H.
      assumption.
    - rewrite nth_overflow;[auto | assumption].
+ simpl.
  split;[ apply (H 0)| ].
  split.
  * intros.
    apply IHp.
    intro n.
    specialize (H (1 + n)).
    simpl in H.
    destruct (Proc.lt_ge_cases n (length ((tc'_list p cl)))).
    - rewrite app_nth1 in H ;[ | rewrite map_length;assumption].
      erewrite nth_indep in H;[ | rewrite map_length;assumption].
      rewrite
      (map_nth (fun (a : Vcg.suite) _ h =>
                forall m', simpl_bassn b m' -> inv (m' :: h)-> a m' h)) in H.
      apply H.
      assumption.
      assumption.
    - rewrite nth_overflow;[auto | assumption].
  * intros.
    specialize (H (1 + (length (tc'_list p cl)) + 0)).
    simpl in H.
    erewrite <- map_length in H.
    rewrite app_nth2_plus in H.
    simpl in H. apply H;[ assumption | assumption ].
+ apply (H 0).
Qed.

End Tc'_list.


From Coq Require Export
  ssreflect
  ssrfun
  ssrbool.

Lemma and_swap : forall x y z, [&& x, y & z] = [&& y, x & z].
Proof. by case; case; case. Qed.

Definition decide {T : Type} (H : bool)
  (kt : (H = true)  -> T)
  (kf : (H = false) -> T) : T :=
  (fun (if_true  : (fun b : bool => protect_term (H = b) -> T) true)
       (if_false : (fun b : bool => protect_term (H = b) -> T) false) =>
    if H as b return ((fun b0 : bool => protect_term (H = b0) -> T) b)
    then if_true
    else if_false)
  (fun (E : H = true)  => kt E)
  (fun (E : H = false) => kf E)
  (erefl H).

Arguments decide {T} H kt kf.

Definition prop (b : bool) : option (is_true b) :=
  if b then Some is_true_true else None.


(** Reasoning about dominators in a graph. *)

Require Import List Equalities Orders RelationClasses Lia.
Require Import FSets FMaps.
Import ListNotations.
From Vellvm Require Import Utils.Util.

Module Type LATTICE.
  Include EqLe'.

  #[global] Declare Instance eq_equiv : Equivalence eq.
  #[global] Declare Instance le_preorder : PreOrder le.
  #[global] Declare Instance le_poset : PartialOrder eq le.

  Parameter eq_dec : forall x y, {x == y} + {x ~= y}.

  Parameter bot : t.
  Axiom le_bot : forall x, bot <= x.

  Parameter top : t.
  Axiom le_top : forall x, x <= top.

  Parameter join : t -> t -> t.
  Axiom le_join_l : forall x y, x <= join x y.
  Axiom le_join_r : forall x y, y <= join x y.
End LATTICE.

Module BoundedSet(Import S:FSetInterface.WS) <: LATTICE.

  Module Import SFacts := FSetFacts.WFacts S.

  Definition t : Type := option S.t.

  Definition eq (t1 t2: t) : Prop :=
    match t1, t2 with
      | Some s1, Some s2 => s1 [=] s2
      | None, None => True
      | _, _ => False
    end.

  Definition le (t1 t2: t) : Prop :=
    match t1, t2 with
      | Some s1, Some s2 => s2 [<=] s1
      | None, Some _ | None, None => True
      | Some _, None => False
    end.

  Include EqLeNotation.

  #[global] Instance eq_equiv : Equivalence eq.
  Proof.
    constructor.
    red. destruct x; simpl; intuition.
    red. destruct x, y; simpl; intros; intuition.
    red. destruct x, y, z; simpl; intros; intuition.
    transitivity t1; auto.
  Qed.

  #[global] Instance le_preorder : PreOrder le.
  Proof.
    constructor.
    red. destruct x; simpl; intuition.
    red. destruct x, y, z; simpl; intros; intuition.
    transitivity t1; auto.
  Qed.

  #[global] Instance le_poset : PartialOrder eq le.
  Proof.
    constructor.
    intro. repeat red. split.
    destruct x, x0; simpl in *; intuition.
    unfold Subset. intros. rewrite H; auto.
    red. destruct x, x0; simpl in *; intuition.
    unfold Subset. intros. rewrite <- H. auto.

    destruct x, x0; simpl;
      intros H; repeat red in H; simpl in H;
      intuition.
    repeat red in H1. repeat red in H0.
    red; intuition.
  Qed.

  Definition eq_dec : forall x y, {x == y} + {x ~= y}.
    refine (fun t1 t2 => match t1, t2 with
                           | Some s1, Some s2 => _
                           | None, None => left _
                           | _, _ => right _
                         end); auto using S.eq_dec.
  Defined.

  Definition bot : t := None.

  Lemma le_bot : forall x, bot <= x.
  Proof.
    simpl; destruct x; trivial.
  Qed.

  Definition top : t := Some S.empty.
  Lemma le_top : forall x, x <= top.
  Proof.
    simpl. destruct x; trivial. red. intros.
    exfalso. eapply empty_iff; eauto.
  Qed.

  Definition join (t1 t2: t) : t :=
    match t1, t2 with
      | Some s1, Some s2 => Some (S.inter s1 s2)
      | None, Some s | Some s, None => Some s
      | None, None => None
    end.

  Lemma le_join_l : forall x y, x <= join x y.
  Proof.
    intros. destruct x, y; repeat red; auto.
    intros. eapply inter_1; eauto.
  Qed.

  Lemma le_join_r : forall x y, y <= join x y.
  Proof.
    intros. destruct x, y; repeat red; auto.
    intros. eapply inter_2; eauto.
  Qed.

  Definition union (t1 t2: t) : t :=
    match t1, t2 with
      | Some s1, Some s2 => Some (S.union s1 s2)
      | None, Some s | Some s, None => None
      | None, None => None
    end.

  Definition singleton (e:S.elt) : t := Some (S.singleton e).

  Definition In (e:S.elt) (t:t) : Prop :=
    match t with
      | Some s => S.In e s
      | None => True
    end.

End BoundedSet.

(** ** GRAPH *)
(** Interface for a nonempty graph [t] with:
     - a set of _vertices_ of type [V]
     - a distinguished _entry vertex_
     - an _edge relation_ [edge]
*)

Module Type GRAPH.
  Parameter Inline t V : Type.
  Parameter Inline eq_dec_V : forall (v1 v2:V), {v1 = v2} + {v1 <> v2}.
  Parameter Inline entry : t -> V.
  Parameter Inline edge : t -> V -> V -> Prop.
  Parameter Inline mem : t -> V -> Prop.
End GRAPH.

(** ** Specification of Dominators *)

Module Spec (Import G:GRAPH).

(** Defines a path in the graph. *)

  Inductive Path (g:G.t) : V -> V -> list V -> Prop :=
  | path_nil : forall v,
      mem g v -> Path g v v [v]
  | path_cons : forall v1 v2 v3 vs,
      Path g v1 v2 vs -> mem g v3 -> edge g v2 v3
      -> Path g v1 v3 (v3::vs).

  #[export] Hint Constructors Path : core.

(** *** Definition of domination *)

  Definition Dom (g:G.t) (v1 v2: V) : Prop :=
    forall vs, Path g (entry g) v2 vs -> In v1 vs.

  Definition SDom (g:G.t) (v1 v2 : V) : Prop :=
    v1 <> v2 /\ Dom g v1 v2.

  Definition IDom (g:G.t) (v1 v2 : V) : Prop :=
    SDom g v1 v2 /\ forall v3, SDom g v3 v2 -> Dom g v3 v1.

  Definition reachable (g:G.t) (v : V) : Prop :=
    exists p, Path g (entry g) v p.

  Lemma start_in_path: forall (g:G.t) (v1 v2 : V) p,
      Path g v1 v2 p -> In v1 p.
  Proof.
    intros g v1 v2 p H.
    induction H.
    - simpl. left. reflexivity.
    - simpl. right. exact IHPath.
  Qed.

  Lemma end_in_path: forall (g:G.t) (v1 v2 : V) p,
      Path g v1 v2 p -> In v2 p.
  Proof.
    intros g v1 v2 p H.
    destruct H; left; reflexivity.
  Qed.

  Lemma acyclic_path_exists: forall (g:G.t) (v1 v2 v3 : V) p,
      Path g v1 v2 p -> In v3 p -> exists q, Path g v1 v3 (v3::q) /\ ~ In v3 q.
  Proof.
    intros g v1 v2 v3 p Hp Hin.
    generalize dependent v3.
    induction Hp; simpl; intros u Hin.
    - destruct Hin. subst. exists []. split.
      * apply path_nil. exact H.
      * simpl. auto.
      * inversion H0.
    - destruct Hin. subst.
      * destruct (in_dec eq_dec_V u vs).
      + apply IHHp in i. exact i.
      + exists vs. split. eapply path_cons; eauto. auto.
      * apply IHHp in H1. exact H1.
  Qed.

  Lemma path_splits: forall (g:G.t) (v1 v2 v3 : V) p,
      Path g v1 v2 p -> In v3 p ->
      exists p1, exists p2, Path g v1 v3 (v3::p1)
                  /\ Path g v3 v2 (v2::p2)
                  /\ p = (v2::p2 ++ p1).
  Proof.
    intros g v1 v2 v3 p Hp Hin.
    generalize dependent v3.
    induction Hp; simpl; intros u Hin.
    - destruct Hin. subst.
      * exists []. exists []. repeat split;auto.
      * destruct H0.
    - destruct Hin. subst.
      * exists vs. exists []. split.
        eapply path_cons; eauto.
        split. apply path_nil; eauto. simpl. reflexivity.
      * eapply IHHp in H1.
        destruct H1 as [p1 [p2 [Hp1 [Hp2 Heq]]]].
        exists p1. exists (v2::p2). split; auto. split.
        eapply path_cons; eauto. subst. reflexivity.
  Qed.

  Lemma Dom_reflexive : forall (g:G.t) (v : V),
      Dom g v v.
  Proof.
    intros g v.
    unfold Dom.
    intros vs Hp.
    eapply end_in_path. apply Hp.
  Qed.

  Lemma Dom_antisymmetric : forall (g:G.t) (v1 v2 : V),
      reachable g v1 ->
      Dom g v1 v2 -> Dom g v2 v1 -> v1 = v2.
  Proof.
    intros g v1 v2 H1 D1 D2.
    unfold Dom in *.
    destruct H1 as [p Hp].
    assert (In v1 p). eapply end_in_path. apply Hp.
    destruct (acyclic_path_exists g (entry g) v1 v1 p Hp H) as [p' [Hp' Hin]].
    assert (In v2 (v1 :: p')) as Hin'. eapply D2. apply Hp'.
    destruct (path_splits g (entry g) v1 v2 (v1::p') Hp' Hin') as [q1 [q2 [HQ1 [HQ2 Heq]]]].
    inversion Heq. subst. clear Heq.
    eapply D1 in HQ1.
    destruct (in_inv HQ1). auto.
    contradiction Hin. eapply in_or_app. right. apply H0.
  Qed.

  Lemma Dom_transitive : forall (g:G.t) (v1 v2 v3 : V),
      Dom g v1 v2 -> Dom g v2 v3 -> Dom g v1 v3.
  Proof.
    intros g v1 v2 v3 D1 D2.
    unfold Dom in *.
    intros vs Hp.
    destruct (path_splits g (entry g) v3 v2 vs) as [q1 [q2 [HQ1 [HQ2 Heq]]]]; auto.
    apply D1 in HQ1.
    inversion HQ1.
    - subst. rewrite app_comm_cons.
      apply in_or_app. left. eapply start_in_path. apply HQ2.
    - subst. simpl. right. apply in_or_app. right. exact H.
  Qed.

  Lemma IDom_unique : forall (g:G.t) (v1 v2 v : V),
      reachable g v1 ->
      IDom g v1 v -> IDom g v2 v -> v1 = v2.
  Proof.
    intros g v1 v2 v H H1 H2.
    destruct H1 as [S1 H1].
    destruct H2 as [S2 H2].
    apply H1 in S2.
    apply H2 in S1.
    eapply Dom_antisymmetric; eauto.
  Qed.

  Lemma dom_step : forall g v1 v2,
    mem g v2 -> edge g v1 v2 -> forall v', SDom g v' v2 -> Dom g v' v1.
  Proof.
    unfold SDom, Dom. intros g v1 v2 Hmem Hsucc v' [Hneq Hdom] p Hp.
    cut (In v' (v2::p)). inversion 1; subst; intuition.
    apply Hdom. eapply path_cons; eauto.
  Qed.

End Spec.

(** *** Relate an algorithm to the specification *)
Module Type Algdom (Import G:GRAPH).
  Module Import GS := Spec G.

  Declare Module E : UsualDecidableType with Definition t := V.
  Declare Module NS : FSetInterface.WS with Module E:=E.
  Module L := BoundedSet NS.
  Include EqLeNotation L.

  Parameter calc_sdom : G.t -> option (V -> L.t).

  Axiom entry_sound : forall g sdom,
    calc_sdom g = Some sdom ->
    sdom (entry g) == L.top.

  Axiom successors_sound : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    mem g n1 -> mem g n2 -> edge g n1 n2 ->
    L.union (L.singleton n1) (sdom n1) <= sdom n2.

  Axiom complete : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    SDom g n1 n2 -> L.In n1 (sdom n2).

End Algdom.

Module AlgdomProperties (Import G:GRAPH) (Import A : Algdom G).
  Module Import GS := Spec G.

  Lemma sound : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    L.In n1 (sdom n2) -> Dom g n1 n2.
  Proof.
    red; intros. remember (entry g). induction H1. subst.
    pose proof entry_sound g sdom H.

    destruct (sdom (entry g)); try contradiction; simpl in *.
      exfalso. rewrite H2 in H0. eapply L.SFacts.empty_iff. eauto.

    right. destruct (E.eq_dec v2 n1). subst. inversion H1; intuition.
    apply IHPath; auto.

    destruct (sdom v2) eqn:Heqv2; simpl in *; auto.
    cut (NS.In n1 (NS.union (NS.singleton v2) t0)).
    intro Hin. apply NS.union_1 in Hin as [Hin | Hin]; auto.
    contradict n. apply NS.singleton_1. assumption.

    pose proof successors_sound g sdom v2 v3 as Hss.
    simpl in Hss. rewrite Heqv2 in Hss. simpl in Hss.
    destruct (sdom v3). apply Hss; inversion H1; eauto.
    exfalso. apply Hss; inversion H1; eauto.
  Qed.

End AlgdomProperties.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-01-16 22:29:57 -0500 (Wed, 16 Jan 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)
Require Import String.
Open Scope string_scope.

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

(* From Poly.v *)

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  induction n as [| n'].
  Case "n = 0". apply le_n.
  Case "n = S n'". apply le_S. apply IHn'.
Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H as [| m'].
  Case "H = n <= n". apply le_n.
  Case "H = n <= S m'". apply le_S in IHle. apply IHle.
Qed.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
Proof.
  intros. generalize dependent m.
  induction n as [| n'];
    intros.
  Case "n = 0". apply O_le_n.
  Case "n = S n'". destruct m. inversion H.
    simpl in H. apply n_le_m__Sn_le_Sm. apply IHn'. apply H.
Qed.

Lemma ble_nat_true_iff : forall n m : nat,
  ble_nat n m = true <-> n <= m.
Proof.
  intros n m. split. apply ble_nat_true.
  generalize dependent m. induction n; intros m H. reflexivity.
    simpl. destruct m. inversion H.
    apply le_S_n in H. apply IHn. assumption.
Qed.

Theorem false_beq_nat : forall n m : nat,
     n <> m ->
     beq_nat n m = false.
Proof.
  intros. generalize dependent m.
  induction n;
    intros;
      unfold not in H;
        destruct m;
          simpl.
  destruct H. reflexivity.
  reflexivity.
  reflexivity.
  apply IHn. unfold not.
  intros H'. apply H.
  rewrite H'. reflexivity.
Qed.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

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

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.

Arguments multi [X].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.

Definition beq_id id1 id2 :=
  match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (beq_id x2 x1)...
Qed.

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


Require Import HoTT.
Require Import category_lemmas.
Require Import group_complete_1type.

Require Import Categories.
Require Import Category.Morphisms.
Section Monoidal_Category.

  Local Notation "x --> y" := (morphism _ x y) (at level 99, right associativity, y at level 200) : type_scope.
  Open Scope morphism.

  Definition BiFunctor (A B C : PreCategory) :=
    Functor A (functor_category B C).

  Definition morphism_of_1 {A B C : PreCategory} (F : BiFunctor A B C)
             {a a' : A} (f : a --> a') (b : B)  :
    F a b --> F a' b :=
    morphism_of F f b.

  Definition morphism_of_2 {A B C : PreCategory} (F : BiFunctor A B C)
             (a : A) {b b' : B} (g : b --> b') :
    F a b --> F a b' :=
    morphism_of (F a) g.

  Definition morphism_of_12 {A B C : PreCategory} (F : BiFunctor A B C)
             {a a' : A} (f : a --> a') {b b' : B} (g : b --> b') :
    F a b --> F a' b' :=
    (morphism_of_2 F a' g) o (morphism_of_1 F f b).
  (* Could define it the other way as well. . . *)

  Record Monoidal_Category :=
    {moncat : PreCategory;
     moncat_mult : BiFunctor moncat moncat moncat;
     moncat_id : moncat;

     moncat_assoc : forall a b c : moncat,
          (moncat_mult (moncat_mult a b) c) --> (moncat_mult a (moncat_mult b c));
     natl_assoc : forall (a b c a' b' c' : moncat)
                         (f : a --> a') (g : b --> b') (h : c --> c'),
         morphism_of_12 moncat_mult f (morphism_of_12 moncat_mult g h) o moncat_assoc a b c =
         moncat_assoc a' b' c' o morphism_of_12 moncat_mult (morphism_of_12 moncat_mult f g) h;
     iso_assoc : forall a b c : moncat,
         IsIsomorphism (moncat_assoc a b c);

     moncat_lid : forall a : moncat,
         (moncat_mult moncat_id a) --> a;
     natl_lid : forall (a a' : moncat) (f : a --> a'),
         f o (moncat_lid a) = (moncat_lid a') o (morphism_of_2 moncat_mult moncat_id f);
     iso_lid : forall a : moncat,
         IsIsomorphism (moncat_lid a);

     moncat_rid : forall a : moncat,
         (moncat_mult a moncat_id) -->  a;
     natl_rid : forall (a a' : moncat) (f : a --> a'),
         f o (moncat_rid a) = (moncat_rid a') o (morphism_of_1 moncat_mult f moncat_id);
     iso_rid : forall a : moncat,
         IsIsomorphism (moncat_rid a);

     moncat_triangle1 : forall (a b : moncat),
         morphism_of_1 moncat_mult (moncat_lid a) b = moncat_lid (moncat_mult a b) o moncat_assoc moncat_id a b;
     moncat_triangle2 : forall (a b : moncat),
         morphism_of_1 moncat_mult (moncat_rid a) b = morphism_of_2 moncat_mult a (moncat_lid b) o moncat_assoc a moncat_id b;

     moncat_pentagon : forall (a b c d : moncat),
         morphism_of_1 moncat_mult (moncat_assoc a b c) d =
         (moncat_assoc a (moncat_mult b c) d)^-1 o ((morphism_of_2 moncat_mult a (moncat_assoc b c d))^-1 o
         (moncat_assoc a b (moncat_mult c d) o moncat_assoc (moncat_mult a b) c d))

    }.

  (* Infix "⊗" := smontype_mult (at level 50,no associativity). *)
  Definition moncat_of_montype : Monoidal_1Type -> Monoidal_Category.
  Proof.

    intros [S m e assoc lid rid triangle1 triangle2 pentagon].
    refine
      (Build_Monoidal_Category (Type_to_Cat S) (cat_of_arrow S S o (arrow_to_functor m))%functor e assoc _ _ lid _ _ rid _ _ _ _ _); simpl.
    - intros a b c a' b' c' [] [] []. simpl. destruct (assoc a b c). reflexivity.
    - intros a a' []. destruct (lid a). reflexivity.
    - intros a a' []. destruct (rid a). reflexivity.
    - intros a b. refine (_ @ triangle1 a b).
      unfold morphism_of_1. simpl.
      destruct (lid a). reflexivity.
    - intros a b. refine (_ @ triangle2 a b).
      unfold morphism_of_1. simpl.
      destruct (rid a). reflexivity.
    - intros a b c d.
      unfold morphism_of_1. simpl.
      refine (_ @ pentagon a b c d @ _).
      + destruct (assoc a b c). reflexivity.
      + apply whiskerR. apply whiskerL.
        destruct (assoc b c d). reflexivity.
  Defined.

  (* Definition moncat_action_category (S : Symmetric_Monoidal_1Type) (X : Monoidal_1Type) (F : Monoidal_Map S X) *)
  (*            (left_cancel : forall (s t : S) (p q : s = t) (a : S), *)
  (*                ap (fun x => smontype_mult x a) p = ap (fun x => smontype_mult x a) q -> p = q) : Monoidal_Category. *)
  (* Proof. *)
  (*   srefine (Build_Monoidal_Category (monoidal_action_cat S X (monmap_to_action F) left_cancel) _ _ _ _ (fun a b c => Build_IsIsomorphism _ _ _ _ _ _ _) *)
  (*                                    _ _ (fun a => Build_IsIsomorphism _ _ _ _ _ _ _) _ _ (fun a => Build_IsIsomorphism _ _ _ _ _ _ _)). *)
  Lemma ap_homotopy {A B : Type} {a b : A} (p : a = b) (f g : A -> B) (H : g == f) :
    ap f p = (H a)^ @ (ap g p) @ (H b).
  Proof.
    destruct p. simpl. destruct (H a). reflexivity.
  Defined.

  Lemma grp_complete_bifun_lem1' (S : Symmetric_Monoidal_1Type) (a b s t : S) :
      (((smontype_assoc (t ⊗ s) a b)^ @ ap (fun x : S => x ⊗ b) (smontype_sym (t ⊗ s) a)) @ smontype_assoc a (t ⊗ s) b) @
           ap (smontype_mult a) (smontype_assoc t s b) =
      (smontype_assoc t s (a ⊗ b) @ ap (smontype_mult t) (((smontype_assoc s a b)^ @ ap (fun x : S => x ⊗ b) (smontype_sym s a)) @ smontype_assoc a s b))
        @ (((smontype_assoc t a (s ⊗ b))^ @ ap (fun x : S => x ⊗ (s ⊗ b)) (smontype_sym t a)) @ smontype_assoc a t (s ⊗ b)).
  Proof.
    repeat rewrite ap_pp. rewrite ap_V.
    assert (p : ap (smontype_mult t) (ap (fun x : S => x ⊗ b) (smontype_sym s a)) =
                (smontype_assoc t (s ⊗ a) b)^ @ ap (fun x : S => x ⊗ b) (ap (fun x : S => t ⊗ x) (smontype_sym s a)) @ smontype_assoc t (a ⊗ s) b).
    { destruct (smontype_sym s a). simpl.
      destruct (smontype_assoc t (s ⊗ a) b). simpl.  reflexivity. }
    rewrite p. clear p. repeat rewrite concat_pp_p.
    assert (p : ap (fun x : S => x ⊗ (s ⊗ b)) (smontype_sym t a) =
                (smontype_assoc (t ⊗ a) s b)^ @ ap (fun x : S => x ⊗ b) (ap (fun x : S => x ⊗ s) (smontype_sym t a)) @ smontype_assoc (a ⊗ t) s b).
    { destruct (smontype_sym t a). simpl.
      destruct (smontype_assoc (t ⊗ a) s b). simpl. reflexivity. }
    rewrite p. clear p.
    rewrite (smontype_sym_inv S t a). repeat rewrite ap_V.
    rewrite (smontype_hexagon S a t s).
    repeat rewrite ap_pp. repeat rewrite ap_V.
    repeat rewrite concat_pp_p.
    repeat rewrite (smontype_pentagon).
    repeat rewrite inv_pp. repeat rewrite inv_V.
    repeat rewrite concat_pp_p.
    repeat rewrite concat_V_pp. rewrite concat_Vp. rewrite concat_p1.
    rewrite concat_p_Vp. rewrite concat_p_Vp.
    rewrite (smontype_sym_inv S a (t ⊗ s)). rewrite ap_V. rewrite inv_V.
    rewrite (smontype_sym_inv S s a). rewrite ap_V. rewrite ap_V.
    repeat rewrite concat_V_pp.
    repeat rewrite concat_p_pp. repeat apply whiskerR. rewrite concat_pV.
    apply inverse. apply concat_1p.
  Qed.

  Lemma grp_complete_bifun_lem1
        (S : Symmetric_Monoidal_1Type)
        (a1 a2 b1 b2 : S) (c d : S * S) (s : S)
        (p : functor_prod (smontype_mult s) (smontype_mult s) (b1, b2) = c) (t : S)
        (q : functor_prod (smontype_mult t) (smontype_mult t) c = d) :
    path_prod ((t ⊗ s) ⊗ (a1 ⊗ b1), (t ⊗ s) ⊗ (a2 ⊗ b2)) (a1 ⊗ ((t ⊗ s) ⊗ b1), a2 ⊗ ((t ⊗ s) ⊗ b2))
              (((smontype_assoc (t ⊗ s) a1 b1)^ @ ap (fun x : S => x ⊗ b1) (smontype_sym (t ⊗ s) a1)) @ smontype_assoc a1 (t ⊗ s) b1)
              (((smontype_assoc (t ⊗ s) a2 b2)^ @ ap (fun x : S => x ⊗ b2) (smontype_sym (t ⊗ s) a2)) @ smontype_assoc a2 (t ⊗ s) b2) @
              ap (functor_prod (smontype_mult a1) (smontype_mult a2))
              ((path_prod (functor_prod (smontype_mult (t ⊗ s)) (smontype_mult (t ⊗ s)) (b1, b2))
                          (functor_prod (smontype_mult t) (smontype_mult t) (functor_prod (smontype_mult s) (smontype_mult s) (b1, b2)))
                          (smontype_assoc t s b1) (smontype_assoc t s b2) @ ap (functor_prod (smontype_mult t) (smontype_mult t)) p) @ q) =
    (path_prod (functor_prod (smontype_mult (t ⊗ s)) (smontype_mult (t ⊗ s)) (functor_prod (smontype_mult a1) (smontype_mult a2) (b1, b2)))
               (functor_prod (smontype_mult t) (smontype_mult t)
                             (functor_prod (smontype_mult s) (smontype_mult s) (functor_prod (smontype_mult a1) (smontype_mult a2) (b1, b2))))
               (smontype_assoc t s (a1 ⊗ b1)) (smontype_assoc t s (a2 ⊗ b2)) @
               ap (functor_prod (smontype_mult t) (smontype_mult t))
               (path_prod (s ⊗ (a1 ⊗ b1), s ⊗ (a2 ⊗ b2)) (a1 ⊗ (s ⊗ b1), a2 ⊗ (s ⊗ b2))
                          (((smontype_assoc s a1 b1)^ @ ap (fun x : S => x ⊗ b1) (smontype_sym s a1)) @ smontype_assoc a1 s b1)
                          (((smontype_assoc s a2 b2)^ @ ap (fun x : S => x ⊗ b2) (smontype_sym s a2)) @ smontype_assoc a2 s b2) @
                          ap (functor_prod (smontype_mult a1) (smontype_mult a2)) p))
      @ (path_prod (t ⊗ (a1 ⊗ fst c), t ⊗ (a2 ⊗ snd c)) (a1 ⊗ (t ⊗ fst c), a2 ⊗ (t ⊗ snd c))
                   (((smontype_assoc t a1 (fst c))^ @ ap (fun x : S => x ⊗ (let (fst, _) := c in fst))
                                                  (smontype_sym t a1)) @ smontype_assoc a1 t (fst c))
                   (((smontype_assoc t a2 (snd c))^ @ ap (fun x : S => x ⊗ (let (_, snd) := c in snd)) (smontype_sym t a2))
                      @ smontype_assoc a2 t (snd c))
                   @ ap (functor_prod (smontype_mult a1) (smontype_mult a2)) q).
  Proof.
    destruct p,q.
    repeat rewrite ap_pp.
    repeat rewrite ap_functor_prod. simpl. repeat rewrite concat_p1.
    repeat rewrite <- path_prod_pp.
    apply (ap011 (path_prod _ _)); apply grp_complete_bifun_lem1'.
  Qed.

  Lemma grp_complete_bifun_lem2 (S : Symmetric_Monoidal_1Type) (a b : S) :
            (((smontype_assoc smontype_id a b)^ @ ap (fun x : S => x ⊗ b) (smontype_sym smontype_id a)) @ smontype_assoc a smontype_id b)
              @ ap (smontype_mult a) (smontype_lid b) = smontype_lid (a ⊗ b).
  Proof.
    rewrite smontype_sym_inv. rewrite ap_V.
    rewrite smontype_hexagon.
    rewrite inv_pp. rewrite inv_pp. rewrite inv_pp. rewrite inv_pp.
    rewrite inv_V. rewrite inv_V.
    repeat rewrite concat_pp_p.
    rewrite concat_V_pp. rewrite concat_V_pp.
    assert (natl : ap (smontype_mult smontype_id) (smontype_sym a b) =
                       smontype_lid (a ⊗ b) @ smontype_sym a b @ (smontype_lid (b ⊗ a))^).
    { destruct (smontype_sym a b). destruct (smontype_lid (a ⊗ b)). reflexivity. }
    rewrite natl. clear natl.
    assert (natl : smontype_sym a (smontype_id ⊗ b) =
                   ap (smontype_mult a) (smontype_lid b) @ smontype_sym a b @ (ap (fun x => x ⊗ a) (smontype_lid b))^).
    { destruct (smontype_lid b). simpl.
      destruct (smontype_sym a (smontype_id ⊗ b)). reflexivity. }
    rewrite natl. clear natl.
    rewrite smontype_triangle1.
    rewrite inv_pp. rewrite inv_pp. rewrite inv_pp. rewrite inv_pp. rewrite inv_V. rewrite inv_V.
    repeat rewrite concat_pp_p.

    repeat rewrite concat_V_pp. rewrite concat_p_Vp. rewrite concat_Vp.
    apply concat_p1.
  Qed.

  Lemma grp_complete_bifun_lem3' (S : Symmetric_Monoidal_1Type) (a s c t : S):
    (ap (fun x : S => x ⊗ (a ⊗ c)) (smontype_sym s t))^
    @ ((smontype_assoc s t (a ⊗ c) @ (((ap (smontype_mult s) (smontype_assoc t a c))^
       @ ap (smontype_mult s) (ap (fun x : S => x ⊗ c) (smontype_sym t a)))
       @ ap (smontype_mult s) (smontype_assoc a t c))) @ (smontype_assoc s a (t ⊗ c))^) =
          (smontype_assoc t s (a ⊗ c) @ (ap (smontype_mult t) (smontype_assoc s a c))^)
            @ (((smontype_assoc t (s ⊗ a) c)^ @ ap (fun x : S => x ⊗ c) (smontype_sym t (s ⊗ a))) @ smontype_assoc (s ⊗ a) t c).
  Proof.
    assert (p : (ap (fun x : S => x ⊗ (a ⊗ c)) (smontype_sym s t)) =
                (smontype_assoc (s ⊗ t) a c)^ @ ap (fun x : S => x ⊗ c) (ap (fun x : S => x ⊗ a) (smontype_sym t s))^ @
                                                                                (smontype_assoc (t ⊗ s) a c)).
    { rewrite (smontype_sym_inv S t s). destruct (smontype_sym s t). simpl.
      destruct (smontype_assoc (s ⊗ t) a c). reflexivity. }
    rewrite p. clear p.
    assert (p : ap (smontype_mult s) (ap (fun x : S => x ⊗ c) (smontype_sym t a)) =
                (smontype_assoc s (t ⊗ a) c)^ @ ap (fun x => x ⊗ c) (ap (fun x => s ⊗ x) (smontype_sym t a)) @
                                              smontype_assoc s (a ⊗ t) c).
    { destruct (smontype_sym t a). simpl.
      destruct (smontype_assoc s (t ⊗ a) c). reflexivity. }
    rewrite p. clear p.
    repeat rewrite inv_pp. rewrite ap_V. repeat rewrite inv_V.
    rewrite (smontype_hexagon S t s).
    repeat rewrite ap_pp. repeat rewrite ap_V.
    repeat rewrite concat_pp_p.
    repeat rewrite smontype_pentagon.
    repeat rewrite inv_pp. repeat rewrite inv_V.
    change (fun x : S => s ⊗ x) with (smontype_mult s).
    repeat rewrite concat_pp_p.
    repeat rewrite concat_V_pp.
    repeat rewrite concat_p_Vp.
    repeat rewrite concat_V_pp.
    repeat apply whiskerL. rewrite concat_pV. apply concat_p1.
  Qed.

  Lemma grp_complete_bifun_lem3
        (S : Symmetric_Monoidal_1Type) (left_cancel : left_faithful montype_mult) (a1 a2 : S) (b : S * S) (s : S)
        (p : functor_prod (smontype_mult s) (smontype_mult s) (a1, a2) = b) (c1 c2 : S) (d : Core.object (group_completion S left_cancel))
        (t : S) (q : functor_prod (smontype_mult t) (smontype_mult t) (c1, c2) = d):
    (ap (fun x : S => functor_prod (smontype_mult x) (smontype_mult x) (functor_prod (smontype_mult a1) (smontype_mult a2) (c1, c2))) (smontype_sym s t))^
    @ ((path_prod (functor_prod (smontype_mult (s ⊗ t)) (smontype_mult (s ⊗ t)) (functor_prod (smontype_mult a1) (smontype_mult a2) (c1, c2)))
                  (functor_prod (smontype_mult s) (smontype_mult s)
                                (functor_prod (smontype_mult t) (smontype_mult t) (functor_prod (smontype_mult a1) (smontype_mult a2) (c1, c2))))
                  (smontype_assoc s t (a1 ⊗ c1)) (smontype_assoc s t (a2 ⊗ c2))
                  @ ap (functor_prod (smontype_mult s) (smontype_mult s)) (path_prod (t ⊗ (a1 ⊗ c1), t ⊗ (a2 ⊗ c2)) (a1 ⊗ (t ⊗ c1), a2 ⊗ (t ⊗ c2))
                    (((smontype_assoc t a1 c1)^ @ ap (fun x : S => x ⊗ c1) (smontype_sym t a1)) @ smontype_assoc a1 t c1)
                    (((smontype_assoc t a2 c2)^ @ ap (fun x : S => x ⊗ c2) (smontype_sym t a2)) @ smontype_assoc a2 t c2) @
                    ap (functor_prod (smontype_mult a1) (smontype_mult a2)) q))
         @ (path_prod (s ⊗ (a1 ⊗ fst d), s ⊗ (a2 ⊗ snd d)) ((s ⊗ a1) ⊗ fst d, (s ⊗ a2) ⊗ snd d) (smontype_assoc s a1 (fst d))^
            (smontype_assoc s a2 (snd d))^ @ ap (fun b0 : S * S => functor_prod (smontype_mult (fst b0)) (smontype_mult (snd b0)) d) p)) =
    (path_prod (functor_prod (smontype_mult (t ⊗ s)) (smontype_mult (t ⊗ s)) (functor_prod (smontype_mult a1) (smontype_mult a2) (c1, c2)))
               (functor_prod (smontype_mult t) (smontype_mult t)
                             (functor_prod (smontype_mult s) (smontype_mult s) (functor_prod (smontype_mult a1) (smontype_mult a2) (c1, c2))))
               (smontype_assoc t s (a1 ⊗ c1)) (smontype_assoc t s (a2 ⊗ c2)) @ ap (functor_prod (smontype_mult t) (smontype_mult t))
               (path_prod (s ⊗ (a1 ⊗ c1), s ⊗ (a2 ⊗ c2)) ((s ⊗ a1) ⊗ c1, (s ⊗ a2) ⊗ c2) (smontype_assoc s a1 c1)^ (smontype_assoc s a2 c2)^
                @ ap (fun b0 : S * S => functor_prod (smontype_mult (fst b0)) (smontype_mult (snd b0)) (c1, c2)) p))
      @ (path_prod (t ⊗ (fst b ⊗ c1), t ⊗ (snd b ⊗ c2)) (fst b ⊗ (t ⊗ c1), snd b ⊗ (t ⊗ c2))
                   (((smontype_assoc t (fst b) c1)^ @ ap (fun x : S => x ⊗ c1) (smontype_sym t (let (fst, _) := b in fst)))
                      @ smontype_assoc (fst b) t c1)
                   (((smontype_assoc t (snd b) c2)^ @ ap (fun x : S => x ⊗ c2) (smontype_sym t (let (_, snd) := b in snd)))
                      @ smontype_assoc (snd b) t c2) @ ap (functor_prod (smontype_mult (fst b)) (smontype_mult (snd b))) q).
  Proof.
    destruct p,q. simpl.
    repeat rewrite concat_p1.
    repeat rewrite ap_functor_prod.
    assert (p :
              (ap (fun x : S => functor_prod (smontype_mult x) (smontype_mult x) (functor_prod (smontype_mult a1) (smontype_mult a2) (c1, c2)))
                  (smontype_sym s t) =
               path_prod (_,_) (_,_)
                         (ap (fun x => x ⊗ (a1 ⊗ c1)) (smontype_sym s t)) (ap (fun x => x ⊗ (a2 ⊗ c2)) (smontype_sym s t)))).
    { destruct (smontype_sym s t). simpl. reflexivity. }
    rewrite p. clear p.
    rewrite <- path_prod_VV.
    repeat rewrite <- path_prod_pp. repeat rewrite ap_pp. repeat rewrite ap_V.
    apply (ap011 (path_prod _ _)); apply grp_complete_bifun_lem3'.
  Qed.

  Definition mult_group_completion_fix_fst (S : Symmetric_Monoidal_1Type) (left_cancel : left_faithful (@montype_mult S))
             (a : group_completion S left_cancel) :
    Functor (group_completion S left_cancel) (group_completion S left_cancel).
  Proof.
    srapply @Build_Functor.
    + simpl.
      exact (functor_prod (smontype_mult (fst a)) (smontype_mult (snd a))).
    + simpl. intros b c.
      unfold monoidal_action_morphism. simpl. unfold functor_prod. simpl.

      intros [s p].
      exists s.
      refine (_ @ ap (functor_prod (smontype_mult (fst a)) (smontype_mult (snd a))) p).
      unfold functor_prod. simpl. apply path_prod; simpl; refine ((smontype_assoc _ _ _)^ @ _ @ smontype_assoc _ _ _);
                                    apply (ap (fun x => x ⊗ _ b) (smontype_sym s (_ a))).
    + intros b c d. simpl in b,c,d.
      intros [s p] [t q]. simpl in p,q.  simpl.
      destruct a as [a1 a2]; destruct b as [b1 b2]; simpl.
      srapply @path_sigma. { reflexivity. }
      simpl.
      apply grp_complete_bifun_lem1.
    + simpl. intro b.
      srapply @path_sigma.
      { simpl. reflexivity.  }
      simpl.
      refine (whiskerL _ (ap_functor_prod _ _ _ _ _ _) @ _).
      destruct a as [a1 a2]. destruct b as [b1 b2]. simpl.
      refine ((path_prod_pp _ _ _ _ _ _ _)^ @ _).
      apply (ap011 (path_prod _ _)); apply grp_complete_bifun_lem2.
  Defined.

  Definition mult_group_completion (S : Symmetric_Monoidal_1Type) (left_cancel : left_faithful (@montype_mult S)) :
    BiFunctor (group_completion S left_cancel) (group_completion S left_cancel) (group_completion S left_cancel).
  Proof.
    unfold BiFunctor.
    srapply (Build_Functor (group_completion S left_cancel) (group_completion S left_cancel -> group_completion S left_cancel)
                         (fun (a : (group_completion S left_cancel)) => (mult_group_completion_fix_fst S left_cancel a))).
    - intros a b. simpl in a, b. simpl.
      intros [s p]. simpl in p.
      srapply @Build_NaturalTransformation.
      + simpl. intro c.
        unfold monoidal_action_morphism. simpl.
        exists s.
        refine (_ @ ap (fun b => functor_prod (smontype_mult (fst b)) (smontype_mult (snd b)) c) p).
        unfold functor_prod. simpl.
        apply path_prod;
          apply ((smontype_assoc _ _ _)^).
      + destruct a as [a1 a2]. intros [c1 c2] d.
        intros [t q]. simpl in q.
        srapply @path_sigma.
        { apply smontype_sym. }
        refine (transport_paths_Fl (smontype_sym s t) _ @ _). cbn.
        apply grp_complete_bifun_lem3.
    - intros a b c [s p] [t q].
      apply NaturalTransformation.path_natural_transformation. simpl.
      intro d. destruct p, q.
      srapply @path_sigma.
      { reflexivity. } simpl.
      abstract (
          repeat rewrite concat_p1;
          destruct d as [d1 d2]; simpl;
          change (fun b : S * S => functor_prod (smontype_mult (fst b)) (smontype_mult (snd b)) (d1, d2)) with
          (functor_prod (fun b : S =>  b ⊗ d1) (fun b : S => b ⊗ d2));
          repeat rewrite ap_functor_prod;
          repeat rewrite <- path_prod_pp;

          apply (ap011 (path_prod _ _));
          rewrite smontype_pentagon;
          repeat rewrite concat_p_pp;
          apply whiskerR;
          apply concat2;
          try rewrite concat_Vp; try apply concat_1p;
          try apply inverse; apply ap_V).
    - intros [a1 a2].
      apply NaturalTransformation.path_natural_transformation. simpl.
      intros [b1 b2]. simpl.
      srapply @path_sigma.
      { reflexivity. }
      simpl.
      change (fun b : S * S => functor_prod (smontype_mult (fst b)) (smontype_mult (snd b)) (b1, b2))
             with
             (functor_prod (fun c : S => c ⊗ b1) (fun c : S => c ⊗ b2)).
      abstract (
          rewrite ap_functor_prod;
          rewrite <- path_prod_pp;
          apply (ap011 (path_prod _ _));
          rewrite smontype_triangle1;
          rewrite concat_V_pp; reflexivity).
  Defined.

   Lemma ap_pair_path_prod {A B : Type} (f g : A -> B) {a b : A} (p : a = b) :
     ap (fun a : A => (f a, g a)) p = path_prod (f a, g a) (f b, g b) (ap f p) (ap g p).
   Proof.
     destruct p. reflexivity.
   Defined.

  (* Definition moncat_group_completion (S : Symmetric_Monoidal_1Type) *)
  (*            (left_cancel : forall (s t : S) (p q : s = t) (a : S), *)
  (*                ap (fun x => smontype_mult x a) p = ap (fun x => smontype_mult x a) q -> p = q) : Monoidal_Category. *)
  (* Proof. *)
  (*   srefine (Build_Monoidal_Category *)
  (*              (group_completion S left_cancel) (mult_group_completion S left_cancel) *)
  (*              (smontype_id, smontype_id) *)
  (*              _ _ (fun a b c => Build_IsIsomorphism _ _ _ _ _ _ _) *)
  (*              _ _ (fun a => Build_IsIsomorphism _ _ _ _ _ _ _) *)
  (*              _ _ (fun a => Build_IsIsomorphism _ _ _ _ _ _ _) _ _ _). *)
  (*   (* associative *) *)
  (*   - intros a b c. simpl. *)
  (*     unfold monoidal_action_morphism. simpl. *)
  (*     destruct a as [a1 a2]. destruct b as [b1 b2]. destruct c as [c1 c2]. *)
  (*     unfold functor_prod. simpl. *)
  (*     exists smontype_id. *)
  (*     apply path_prod; refine (smontype_lid _ @ _); apply smontype_assoc. *)
  (*   (* asssociativity is natural *) *)
  (*   - intros [a1 a2] [b1 b2] [c1 c2] a' b' c' [s p] [t q] [u r]. destruct p,q,r. simpl. *)
  (*     srapply @path_sigma. simpl. *)
  (*     { refine (smontype_rid _ @ (smontype_assoc _ _ _) @ (smontype_lid _)^). } *)
  (*     simpl. *)
  (*     refine (transport_paths_Fl *)
  (*               ((smontype_rid ((u ⊗ t) ⊗ s) @ smontype_assoc u t s) @ (smontype_lid (u ⊗ (t ⊗ s)))^) _ @ _). *)
  (*     repeat rewrite ap_pp.       repeat rewrite concat_p1. *)
  (*     repeat rewrite ap_V. repeat rewrite inv_V. *)
  (*     repeat rewrite ap_pair_path_prod. simpl. *)
  (*     repeat rewrite <- path_prod_pp. *)
  (*     rewrite <- path_prod_VV. *)
  (*     rewrite <- path_prod_pp. rewrite <- path_prod_VV. *)
  (*     rewrite <- path_prod_pp. *)
  (*     apply (ap011 (path_prod _ _)). *)
  (*     rewrite inv_pp. rewrite inv_pp. rewrite inv_V. *)
  (*     repeat rewrite concat_p_pp. admit. admit. *)
  (*   (* inverse associative *) *)
  (*   - simpl. unfold monoidal_action_morphism. simpl. unfold functor_prod. simpl. *)
  (*     destruct a as [a1 a2]. destruct b as [b1 b2]. destruct c as [c1 c2]. simpl. *)
  (*     exists smontype_id. *)
  (*     apply path_prod; refine (smontype_lid _ @ _); apply inverse; apply smontype_assoc. *)
  (*   - destruct a as [a1 a2]. destruct b as [b1 b2]. destruct c as [c1 c2]. simpl. *)
  (*     rewrite ap_functor_prod. rewrite <- path_prod_pp. rewrite <- path_prod_pp. unfold functor_prod. *)
  (*     srapply @path_sigma. *)
  (*     apply smontype_lid.           (* smontype_rid works as well *) *)
  (*     simpl. *)
  (*     refine (transport_paths_Fl (smontype_lid smontype_id) _ @ _). *)
  (*     admit. *)
  (*   - simpl. admit. *)
  (*   (* Left identity *) *)
  (*   - intros [a1 a2]. simpl. *)
  (*     unfold monoidal_action_morphism. simpl. unfold functor_prod. simpl. *)
  (*     exists smontype_id. *)
  (*     apply path_prod; refine (smontype_lid _ @ smontype_lid _). *)
  (*   - intros [a1 a2] a' [s p]. simpl in p. unfold functor_prod in p. simpl in p. destruct p. *)
  (*     simpl. admit. *)
  (*   - admit. *)
  (*   - admit. *)
  (*   - admit. *)
  (*   (* right identity *) *)
  (*   - intros [a1 a2]. simpl. unfold monoidal_action_morphism. simpl. unfold functor_prod. simpl. *)
  (*     exists smontype_id. apply path_prod; refine (smontype_lid _ @ smontype_rid _). *)
  (*   - admit. *)
  (*   - admit. *)
  (*   - admit. *)
  (*   - admit. *)
  (*   (* Coherence diagrams *) *)
  (*   - simpl. admit. *)
  (*   - admit. *)
  (*   - admit. *)
  (* Admitted.     *)

End Monoidal_Category.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import SetsClass.SetsClass.
Require Import PV.Syntax.
Import Lang_SimpleWhile.
Require Import PV.DenotationalSemantics.
Import DntSem_SimpleWhile2 DntSem_SimpleWhile3 DntSem_SimpleWhile4.
Local Open Scope Z.
Local Open Scope sets.
Local Open Scope string.

(** 习题：*)
(** 下面的递归函数_[remove_skip]_定义了在程序语句中删除多余空语句的操作。*)

Fixpoint remove_skip (c: com): com :=
  match c with
  | CSeq c1 c2 =>
      match remove_skip c1, remove_skip c2 with
      | CSkip, _ => remove_skip c2
      | _, CSkip => remove_skip c1
      | _, _ => CSeq (remove_skip c1) (remove_skip c2)
      end
  | CIf e c1 c2 =>
      CIf e (remove_skip c1) (remove_skip c2)
  | CWhile e c1 =>
      CWhile e (remove_skip c1)
  | _ =>
      c
  end.

(** 下面请证明：_[remove_skip]_之后，确实不再有多余的空语句了。所谓没有空语句，
    是指不出现_[c; SKIP]_或_[SKIP; c]_这样的语句。首先定义：局部不存在多余的空语
    句。*)

Definition not_sequencing_skip (c: com): Prop :=
  match c with
  | CSeq CSkip _ => False
  | CSeq _ CSkip => False
  | _ => True
  end.

(** 其次定义语法树的所有子树中都不存在多余的空语句。*)

Fixpoint no_sequenced_skip (c: com): Prop :=
  match c with
  | CSeq c1 c2 =>
      not_sequencing_skip c /\
      no_sequenced_skip c1 /\ no_sequenced_skip c2
  | CIf e c1 c2 =>
      no_sequenced_skip c1 /\ no_sequenced_skip c2
  | CWhile e c1 =>
      no_sequenced_skip c1
  | _ =>
      True
  end.

(** 下面是需要证明的结论。*)

Theorem remove_skip_no_sequenced_skip: forall c,
  no_sequenced_skip (remove_skip c).
Proof.
  intro.
  induction c; simpl; try tauto.
  - destruct (remove_skip c1), (remove_skip c2);
    simpl;
    tauto.
Qed.

(** 习题：*)
(** 下面我们定义一项简单的程序变换：右结合变换。例如，将_[(c1;c2);c3]_变换为
    _[c1;(c2;c3)]_。*)

(** 首先，这里定义一个辅助函数，该函数假设_[c]_与_[c0]_已经是右结合的，计算
    _[c; c0]_转换后的结果*)

Fixpoint CSeq_right_assoc (c c0: com): com :=
  match c with
  | CSeq c1 c2 => CSeq c1 (CSeq_right_assoc c2 c0)
  | _ => CSeq c c0
  end.

(** 现在，可以在_[CSeq_right_assoc]_的基础上定义右结合变换_[right_assoc]_。*)

Fixpoint right_assoc (c: com): com :=
  match c with
  | CSeq c1 c2 =>
      CSeq_right_assoc (right_assoc c1) (right_assoc c2)
  | CIf e c1 c2 =>
      CIf e (right_assoc c1) (right_assoc c2)
  | CWhile e c1 =>
      CWhile e (right_assoc c1)
  | _ =>
      c
  end.

(** 下面证明：经过右结合变换后，确实程序语句中不再有左结合的结构了。下面分为两步
    定义『无左结合结构』，即_[no_left_assoc]_。*)

Definition not_left_assoc (c: com): Prop :=
  match c with
  | CSeq (CSeq _ _) _ => False
  | _ => True
  end.

Fixpoint no_left_assoc (c: com): Prop :=
  match c with
  | CSeq c1 c2 =>
      not_left_assoc c /\
      no_left_assoc c1 /\ no_left_assoc c2
  | CIf e c1 c2 =>
      no_left_assoc c1 /\ no_left_assoc c2
  | CWhile e c1 =>
      no_left_assoc c1
  | _ =>
      True
  end.

(** 证明也需要分两步进行。请先证明关于_[CSeq_right_assoc]_的引理。*)

Lemma CSeq_right_assoc_no_left_assoc: forall c c0,
  no_left_assoc c ->
  no_left_assoc c0 ->
  no_left_assoc (CSeq_right_assoc c c0).
Proof.
  intros.
  induction c; try (simpl; tauto).
  - destruct H, H1.
    simpl.
    tauto.
Qed.

(** 下面是需要证明的最终结论。*)

Theorem right_assoc_no_left_assoc: forall c,
  no_left_assoc (right_assoc c).
Proof.
  intro.
  induction c; simpl; try tauto.
  - apply CSeq_right_assoc_no_left_assoc; tauto.
Qed.

(** 习题：*)
Example skip_seq_skip:
  eval_com (CSeq CSkip CSkip) == eval_com CSkip.
Proof.
  simpl.
  unfold seq_sem, skip_sem.
  unfold_RELS_tac.
  intros.
  split; intro.
  - destruct H, H.
    rewrite H, H0.
    reflexivity.
  - exists a.
    tauto.
Qed.

(** 习题：*)
Example inc_x_fact: forall s1 s2 n,
  eval_com (CAsgn "x" [["x" + 1]]) s1 s2 ->
  s1 "x" = n ->
  s2 "x" = n + 1.
Proof.
  intros.
  unfold eval_com in H.
  unfold asgn_sem in H.
  destruct H.
  rewrite H.
  clear H.
  simpl.
  unfold add_sem, var_sem, const_sem.
  rewrite H0.
  reflexivity.
Qed.