Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.Morphisms_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Coq.Logic.Classical_Prop.
Require Import SetsClass.SetsClass.
Require Import compcert.lib.Integers.
Import SetsNotation.
Require Import PV.Syntax.
Import Lang_While.
Require Import PV.PracticalDenotations.
Import DntSem_While.
Require Import PV.EquivAndRefine.
Require Import PV.Assignment0306.
Local Open Scope Z.
Local Open Scope sets.
Local Open Scope string.
Arguments Rels.id: simpl never.
Arguments Rels.concat: simpl never.
Arguments Sets.indexed_union: simpl never.

(** 习题：*)

(** 先前，我们证明过_[remove_skip]_操作过后的程序语句中不会再在顺序执行的任何一
    侧出现_[skip]_。下面请证明_[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.

Lemma remove_skip_l:
  forall c, c ~=~ [[ skip ; c ]].
Proof.
  intro.
  split;
  simpl;
  rewrite Rels_concat_id_l;
  try rewrite Sets_empty_union;
  reflexivity.
Qed.

Lemma remove_skip_r:
  forall c, c ~=~ [[ c ; skip ]].
Proof.
  intro.
  split;
  simpl;
  try rewrite Rels_concat_id_r;
  try rewrite Rels_concat_empty_r;
  try rewrite Sets_union_empty;
  reflexivity.
Qed.

Lemma remove_skip_sound: forall c,
  remove_skip c ~=~ c.
Proof.
  induction c; try reflexivity; simpl.
  - destruct (remove_skip c1);
    simpl;
    try (
      rewrite <- IHc1, IHc2;
      apply remove_skip_l
    );
    destruct (remove_skip c2);
    try (
      rewrite IHc1, <- IHc2;
      apply remove_skip_r
    );
    rewrite IHc1, IHc2;
    reflexivity.
  - rewrite IHc1, IHc2.
    reflexivity.
  - rewrite IHc.
    reflexivity.
Qed.

(** 习题：*)

(** 下面定义的_[right_assoc]_操作能将所有的顺序执行语法树变为右结合的形式。而
    _[CSeq_right_assoc]_是其中要用到的辅助定义。*)

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.

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.

(** 下面请分两步证明：_[right_assoc]_变换前后的程序是语义等价的。*)

Lemma CSeq_right_assoc_sound: forall c c0,
    CSeq_right_assoc c c0 ~=~ [[c ; c0]].
Proof.
  intros.
  induction c; simpl; try reflexivity.
  rewrite IHc2.
  apply CSeq_assoc.
Qed.

Lemma right_assoc_sound: forall c,
  right_assoc c ~=~ c.
Proof.
  intro.
  induction c; simpl; try reflexivity.
  - rewrite CSeq_right_assoc_sound.
    rewrite IHc1, IHc2.
    reflexivity.
  - rewrite IHc1, IHc2.
    reflexivity.
  - rewrite IHc.
    reflexivity.
Qed.

(** 习题：*)

Module StatewiseEequiv.

(** 下面我们将定义一种新的更细粒度的等价关系_[statewise_eequiv]_，可以用符号：
    _[e1 @ s1 ~=~ e2 @ e2]_表示。其含义是，_[e1]_在_[s1]_这个程序状态上的求值结
    果与_[e2]_在_[s2]_这个程序状态上的求值结果相同。如果

       _[H: e1 @ s1 ~=~ e2 @ e2]_

    那么 _[H.(nrm_eequiv_s): forall i, ⟦ e1 ⟧.(nrm) s1 i <-> ⟦ e2 ⟧.(nrm) s2 i]_
    并且 _[H.(err_eequiv_s): ⟦ e1 ⟧.(err) s1 <-> ⟦ e2 ⟧.(err) s2]_。

    如果反过来，需要证明_[e1 @ s1 ~=~ e2 @ e2]_，那么可以用_[skip; simpl]_来拆解
    这一结论。下面是相关定义，可以忽略其中的细节。*)

Record statewise_eequiv
         (p1: expr * state)
         (p2: expr * state): Prop :=
{
  nrm_eequiv_s':
    forall i, ⟦ fst p1 ⟧.(nrm) (snd p1) i <-> ⟦ fst p2 ⟧.(nrm) (snd p2) i;
  err_eequiv_s':
    ⟦ fst p1 ⟧.(err) (snd p1) <-> ⟦ fst p2 ⟧.(err) (snd p2);
}.

Notation "e @ s" := (@pair expr state e s) (at level 59, no associativity).
Notation "p1 '~=~' p2" := (statewise_eequiv p1 p2)
  (at level 69, only printing, no associativity).
Ltac any_equiv x y ::=
  match type of x with
  | expr => exact (eequiv x y)
  | com => exact (cequiv x y)
  | prod expr state => exact (statewise_eequiv x y)
  | _ => match type of y with
         | expr => exact (eequiv x y)
         | com => exact (cequiv x y)
         | prod expr state => exact (statewise_eequiv x y)
         end
  end.

Lemma nrm_eequiv_s: forall (e1 e2: expr) (s1 s2: state),
  (e1 @ s1) ~=~ (e2 @ s2) ->
  forall i, ⟦ e1 ⟧.(nrm) s1 i <-> ⟦ e2 ⟧.(nrm) s2 i.
Proof. intros ? ? ? ?. apply nrm_eequiv_s'. Qed.

Lemma err_eequiv_s: forall (e1 e2: expr) (s1 s2: state),
  (e1 @ s1) ~=~ (e2 @ s2) ->
  (⟦ e1 ⟧.(err) s1 <-> ⟦ e2 ⟧.(err) s2).
Proof. intros ? ? ? ?. apply err_eequiv_s'. Qed.

Notation "x '.(nrm_eequiv_s)'" := (nrm_eequiv_s _ _ _ _ x)
  (at level 1).

Notation "x '.(err_eequiv_s)'" := (err_eequiv_s _ _ _ _ x)
  (at level 1).

(** 下面请证明，这种细粒度的等价关系也是一种等价关系。*)

Instance statewise_eequiv_refl:
  Reflexive statewise_eequiv.
Proof.
  unfold Reflexive.
  intros [e s].
  split.
  - intro.
    reflexivity.
  - reflexivity.
Qed.

Instance statewise_eequiv_sym:
  Symmetric statewise_eequiv.
Proof.
  unfold Symmetric.
  intros [e1 s1] [e2 s2].
  intro.
  destruct H.
  split.
  - intro.
    split; apply nrm_eequiv_s'0.
  - split; apply err_eequiv_s'0.
Qed.

Instance statewise_eequiv_trans:
  Transitive statewise_eequiv.
Proof.
  unfold Transitive.
  intros [e1 s1] [e2 s2] [e3 s3].
  intros.
  destruct H, H0.
  split.
  - intro.
    split;
    rewrite nrm_eequiv_s'0;
    apply nrm_eequiv_s'1.
  - split;
    rewrite err_eequiv_s'0;
    apply err_eequiv_s'1.
Qed.

(** 下面我们的引理证明了二元运算符与一元运算符能够保持这种_[statewise_eequiv]_关
    系。这些证明不需要你完成。*)

Lemma arith_sem1_nrm_congr_s:
  forall Zfun (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      arith_sem1_nrm Zfun ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      arith_sem1_nrm Zfun ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold arith_sem1_nrm.
  apply ex_iff_morphism; intros i1.
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma arith_sem1_err_congr_s:
  forall Zfun (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    ((⟦ e11 ⟧.(err) ∪ ⟦ e21 ⟧.(err) ∪
      arith_sem1_err Zfun ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm)) s1) <->
    ((⟦ e12 ⟧.(err) ∪ ⟦ e22 ⟧.(err) ∪
      arith_sem1_err Zfun ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm)) s2).
Proof.
  intros.
  unfold arith_sem1_err.
  apply or_iff_morphism.
  + apply or_iff_morphism.
    - apply H.(err_eequiv_s).
    - apply H0.(err_eequiv_s).
  + apply ex_iff_morphism; intros i1.
    apply ex_iff_morphism; intros i2.
    apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
    apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
    reflexivity.
Qed.

Lemma arith_sem2_nrm_congr_s:
  forall int64fun (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      arith_sem2_nrm int64fun ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      arith_sem2_nrm int64fun ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold arith_sem2_nrm.
  apply ex_iff_morphism; intros i1.
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma arith_sem2_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ ⟦ e21 ⟧.(err) ∪
      arith_sem2_err ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm)) s1 <->
    (⟦ e12 ⟧.(err) ∪ ⟦ e22 ⟧.(err) ∪
      arith_sem2_err ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm)) s2.
Proof.
  intros.
  unfold arith_sem2_err.
  apply or_iff_morphism.
  + apply or_iff_morphism.
    - apply H.(err_eequiv_s).
    - apply H0.(err_eequiv_s).
  + apply ex_iff_morphism; intros i1.
    apply ex_iff_morphism; intros i2.
    apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
    apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
    reflexivity.
Qed.

Lemma cmp_sem_nrm_congr_s:
  forall op (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      cmp_sem_nrm op ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      cmp_sem_nrm op ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold cmp_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma cmp_sem_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ ⟦ e21 ⟧.(err)) s1 <->
    (⟦ e12 ⟧.(err) ∪ ⟦ e22 ⟧.(err)) s2.
Proof.
  intros.
  apply or_iff_morphism.
  + apply H.(err_eequiv_s).
  + apply H0.(err_eequiv_s).
Qed.

Lemma and_sem_nrm_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      and_sem_nrm ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      and_sem_nrm ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold and_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply or_iff_morphism; [reflexivity |].
  apply and_iff_morphism; [reflexivity |].
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma and_sem_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ and_sem_err ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(err)) s1 <->
    (⟦ e12 ⟧.(err) ∪ and_sem_err ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(err)) s2.
Proof.
  intros.
  unfold and_sem_err.
  apply or_iff_morphism; [apply H.(err_eequiv_s) |].
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [| apply H0.(err_eequiv_s)].
  reflexivity.
Qed.

Lemma or_sem_nrm_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      or_sem_nrm ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      or_sem_nrm ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold or_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply or_iff_morphism; [reflexivity |].
  apply and_iff_morphism; [reflexivity |].
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma or_sem_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ or_sem_err ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(err)) s1 <->
    (⟦ e12 ⟧.(err) ∪ or_sem_err ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(err)) s2.
Proof.
  intros.
  unfold or_sem_err.
  apply or_iff_morphism; [apply H.(err_eequiv_s) |].
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [| apply H0.(err_eequiv_s)].
  reflexivity.
Qed.

Lemma not_sem_nrm_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    forall i,
      not_sem_nrm ⟦ e1 ⟧.(nrm) s1 i <->
      not_sem_nrm ⟦ e2 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold not_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma not_sem_err_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    ⟦ e1 ⟧.(err) s1 <-> ⟦ e2 ⟧.(err) s2.
Proof.
  intros.
  apply H.(err_eequiv_s).
Qed.

Lemma neg_sem_nrm_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    forall i,
      neg_sem_nrm ⟦ e1 ⟧.(nrm) s1 i <->
      neg_sem_nrm ⟦ e2 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold neg_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma neg_sem_err_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    (⟦ e1 ⟧.(err) ∪ neg_sem_err ⟦ e1 ⟧.(nrm)) s1 <->
    (⟦ e2 ⟧.(err) ∪ neg_sem_err ⟦ e2 ⟧.(nrm)) s2.
Proof.
  intros.
  unfold neg_sem_err.
  apply or_iff_morphism; [apply H.(err_eequiv_s) |].
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma EBinop_congr_s:
  forall op (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    EBinop op e11 e21 @ s1 ~=~ EBinop op e12 e22 @ s2.
Proof.
  intros.
  destruct op.
  + split; simpl.
    - apply or_sem_nrm_congr_s; tauto.
    - apply or_sem_err_congr_s; tauto.
  + split; simpl.
    - apply and_sem_nrm_congr_s; tauto.
    - apply and_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem1_nrm_congr_s; tauto.
    - apply arith_sem1_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem1_nrm_congr_s; tauto.
    - apply arith_sem1_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem1_nrm_congr_s; tauto.
    - apply arith_sem1_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem2_nrm_congr_s; tauto.
    - apply arith_sem2_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem2_nrm_congr_s; tauto.
    - apply arith_sem2_err_congr_s; tauto.
Qed.

Lemma EUnop_congr_s:
  forall op (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    EUnop op e1 @ s1 ~=~ EUnop op e2 @ s2.
Proof.
  intros.
  destruct op.
  + split; simpl.
    - apply not_sem_nrm_congr_s; tauto.
    - apply not_sem_err_congr_s; tauto.
  + split; simpl.
    - apply neg_sem_nrm_congr_s; tauto.
    - apply neg_sem_err_congr_s; tauto.
Qed.

(** 下面请你证明两条关于_[statewise_eequiv]_的性质，在证明中可能需要你手动运用上
    面给出的_[EBinop_congr_s]_进行证明。

    下面定义的_[subst_const]_关系说的是：可以将_[e1]_中出现的变量_[x]_替换成常数
    _[n]_得到_[e2]_。如果_[x]_在_[e1]_中出现多次，那么_[subst_const]_关系允许只
    替换其中的0次、1次或任意多次乃至全部。请你分两步证明，如果在程序状态_[s]_上
    变量_[x]_的值是_[n]_，那么上述_[e1]_与_[e2]_满足：_[e1 @ s ~=~ e2 @ s]_。*)

Fixpoint subst_const (e1 e2: expr) (x: var_name) (n: Z): Prop :=
  match e1, e2 with
  | EConst n1, EConst n2 => n1 = n2
  | EVar x1, EVar x2 => x1 = x2
  | EVar x1, EConst n2 => x1 = x /\ n2 = n
  | EBinop op1 e11 e12, EBinop op2 e21 e22 =>
      op1 = op2 /\ subst_const e11 e21 x n /\ subst_const e12 e22 x n
  | EUnop op1 e11, EUnop op2 e21 =>
      op1 = op2 /\ subst_const e11 e21 x n
  | _, _ => False
  end.

(** 这是一条辅助引理：*)

Lemma subst_const_base_sound: forall (s: state) (x: var_name) (n: Z),
  Int64.min_signed <= n <= Int64.max_signed ->
  s x = Vint (Int64.repr n) ->
  x @ s ~=~ n @ s.
Proof.
  intros.
  simpl.
  split.
  - intro.
    simpl.
    rewrite H0.
    split; intro.
    + injection H1 as H2.
      split.
      * rewrite H2.
        reflexivity.
      * exact H.
    + destruct H1.
      rewrite H1.
      reflexivity.
  - simpl.
    rewrite H0.
    split; intro.
    + discriminate.
    + lia.
Qed.

(** 这是最终需要证明的性质：*)

Theorem subst_const_sound: forall (s: state) e1 e2 (x: var_name) n,
  Int64.min_signed <= n <= Int64.max_signed ->
  s x = Vint (Int64.repr n) ->
  subst_const e1 e2 x n ->
  e1 @ s ~=~ e2 @ s.
Proof.
  intros.
  revert H1.
  revert e2.
  induction e1;
  intros;
  induction e2;
  simpl in H1;
  try tauto.
  - rewrite H1.
    reflexivity.
  - destruct H1.
    rewrite H1, H2.
    apply (subst_const_base_sound _ _ _ H H0).
  - rewrite H1.
    reflexivity.
  - destruct H1, H2.
    rewrite <- H1.
    clear op0 H1.
    apply EBinop_congr_s.
    + apply IHe1_1.
      tauto.
    + apply IHe1_2.
      tauto.
  - destruct H1.
    rewrite <- H1.
    clear op0 H1.
    apply EUnop_congr_s.
    apply IHe1.
    tauto.
Qed.

(** 下面定义的命题_[appears_in_expr e x]_说的是：程序变量_[x]_会在表达式_[e]_中
    出现至少一次。*)

Fixpoint appears_in_expr (e: expr) (x: var_name): Prop :=
  match e with
  | EConst _ => False
  | EVar y => x = y
  | EBinop op e1 e2 => appears_in_expr e1 x \/ appears_in_expr e2 x
  | EUnop op e1 => appears_in_expr e1 x
  end.

(** 请证明：如果_[e]_中出现的每个变量都在_[s1]_与_[s2]_这两个程序状态上取值相同，
    那么_[e]_在这两个程序状态上的求值结果就相同。*)

Lemma forall_or_imply_l { T : Type } { A B C : T -> Prop } :
  (forall x : T, A x \/ B x -> C x) -> (forall x : T, A x -> C x).
Proof.
  intros.
  specialize (H x).
  tauto.
Qed.

Lemma forall_or_imply_r { T : Type } { A B C : T -> Prop } :
  (forall x : T, A x \/ B x -> C x) -> (forall x : T, B x -> C x).
Proof.
  intros.
  specialize (H x).
  tauto.
Qed.

Theorem eeval_appears: forall s1 s2 e,
  (forall x: var_name, appears_in_expr e x -> s1 x = s2 x) ->
  e @ s1 ~=~ e @ s2.
intros.
  induction e; simpl in H.
  - split; split; tauto.
  - specialize (H x).
    assert (H1 : x = x) by reflexivity.
    specialize (H H1).
    split; split; simpl; rewrite H; tauto.
  - apply EBinop_congr_s.
    + exact (IHe1 (forall_or_imply_l H)).
    + exact (IHe2 (forall_or_imply_r H)).
  - apply EUnop_congr_s.
    exact (IHe H).
Qed.

End StatewiseEequiv.


(** Summary of the formalization (kernel)

Tip: The Coq command [About ident] prints where the ident was defined
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Adamek.
Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.graphs.eqdiag.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.coslicecat.

Require Import UniMath.CategoryTheory.SkewMonoidal.SkewMonoidalCategories.
Require Import UniMath.CategoryTheory.SkewMonoidal.CategoriesOfMonoids.
Require Import UniMath.CategoryTheory.limits.graphs.coequalizers.

Require Import StructuralStrengths.
Require Import IModules.
Require Import Complements.
Require Import InitialAlgebraicMonoid.

Local Open Scope cat.

(** Notation for product of functors *)
Delimit Scope functor_scope with F.
Infix "××" := pair_functor (at level 31).

(* Notation for product category *)
Infix "×C" := precategory_binproduct (at level 38).
(** Notation for constructing objects and morphisms of a product category *)
Notation "( c , d )" := (make_catbinprod c d).
Notation "( f #, g )" := (catbinprodmor f g).

(**
The command:

Check (x ≡ y)

succeeds if and only if [x] is convertible to [y]

*)
Notation  "x ≡ y :> A "  := (@paths_refl A x = @paths_refl A y) (at level 70, y at next level, no associativity).
Notation  "x ≡ y"  := (paths_refl x = paths_refl y) (at level 70, no associativity).

Fail Check (true ≡ false).
Check (true ≡ true).

Section Summary.

(** We suppose given a skew monoidal category V
 *)
Context (V : skewmonoidal_category).

(** Some notations for the monoidal structure *)
Notation tensor := (skewmonoidal_tensor (data_from_skewmonoidal V)).
Notation I := (skewmonoidal_I (data_from_skewmonoidal V)).
Notation α' := (skewmonoidal_assoc (data_from_skewmonoidal V)).
Notation λ' := (skewmonoidal_unitl (data_from_skewmonoidal V)).
Notation ρ' := (skewmonoidal_unitr (data_from_skewmonoidal V)).

(** We denote ⊗ the tensor product, and #⊗ the action on morphisms *)
Notation "X ⊗ Y" := (tensor (X , Y)).
Notation "f #⊗ g" :=
   (functor_on_morphisms (functor_data_from_functor _ _ tensor) (f #, g))
                         (at level 31).

(** * I-modules and pointed I-modules
covered by IModules.v
 *)

(**
A I-module on V consists of an object F of V together
with a map F ⊗ I → F, subject to some laws given later.
There is an implicit coercion between I-modules and objects of V
 *)
Check ((IModule_data V) ≡ (∑ (F : V), F ⊗ I --> F : UU)).

(** Some notations for the action *)
Check (∏  F : IModule_data V, im_action V F ≡ (pr2 F : F ⊗ I --> F)).
Notation σ := (im_action V).

(** A I-module consists of the data previously defined subject to
  two laws *)
Check (IModule V ≡
         ∑ (F : IModule_data V) ,
         (** First law *)
         (ρ' F · σ F  = identity _)
           ×
           (** Second law *)
           (α' F I I · (identity _) #⊗ λ' I · σ F  =
            σ F #⊗ identity I · σ F)
      ).

(** A morphism between I-modules X and Y is a morphism between
underlying objects of V preserving the action
 *)
Check  (∏ (X Y : IModule V),
        IModule_Mor V X Y ≡
          ∑ (f :  V ⟦X, Y⟧) ,
            (** the morphism is compatible with σ *)
             σ X · f = (f #⊗ identity _) · σ Y).

          (* (** the unit is preserved *) *)
          (* (ϵ X · f = ϵ Y) *)

(** I-modules form a category  *)
Check (precategory_IModule V ≡
          (make_precategory_ob_mor (IModule V) (IModule_Mor V)
             ,, _) ,, _ ,, _).

(** The unit can be given the structure of a pointed I-module *)
Notation IM := (IModule_I V).
(** Checking the underlying V object. *)
Check ((IM : V) ≡ I).

(** The category of pointed I-modules is the coslice category of the category
of I-modules under I *)
Check (precategory_PtIModule V ≡
                             coslice_precat (precategory_IModule V ) IM
                             (has_homsets_IModule V IM)).

Notation PtIM_Cat := (category_PtIModule V).

Check (PtIModule V ≡ ob PtIM_Cat).

(* Notation for the point *)
Notation ϵ := (im_unit V).

(** IM is canonically a pointed I-module *)
Notation IP := (PtIModule_I V).
Check ((IP : IModule V) ≡ IM).
Check (ϵ IP ≡ identity (C := precategory_IModule V) IM).

(** The forgetful functor from pointed I-modules to V *)
Check (forget_PtIModules V : functor PtIM_Cat V).

(** We use the notation 𝒰 in the following when we want to make explicit the
coercion between pointed I-modules and objects of V. *)
Notation 𝒰 := (forget_PtIModules V).
Check (∏ (X : PtIModule V), 𝒰 X ≡ (X : V)).

(** There is a tensor product on pointed I-modules, defined as a coequalizer,
here called [PtIModule_tensor].
This requires that V has coequalizers (in fact, reflexive coequalizers are enough), and
the tensoring on the right with I preserves them.
 *)
Context (coeqsV : coequalizers.Coequalizers V).
Context  (tensorl_coeqs : preserves_colimits_of_shape
                            ((functor_fix_snd_arg _ _ _ tensor I)) coequalizers.Coequalizer_graph ).

Check (PtIModule_tensor V coeqsV tensorl_coeqs
       : PtIModule V → PtIModule V → PtIModule V).
Infix "⊠M" := (PtIModule_tensor V coeqsV tensorl_coeqs) (at level 31).

(** The underlying object of V of the tensor is the coequalizer of two morphisms
 from (X ⊗ I) ⊗ Y to X ⊗ Y
 *)
Check  (∏ (X Y : PtIModule V),
        𝒰 (X ⊠M Y) ≡
          CoequalizerObject
               V (coeqsV ((X ⊗ I) ⊗ Y) (X ⊗ Y)
                         (** Here is the first one *)
                         (α' X I Y · identity X #⊗ λ' Y)
                         (** Here is the second one *)
                         (σ X #⊗ identity Y)
            )).

(** Notation for the coequalizer arrow *)
Notation κ := (IModule_tensor'_proj V coeqsV tensorl_coeqs).
Check (fun (M N : PtIModule V) => κ M N : M ⊗ N --> M ⊠M N).

(** The tensor product can be lifted to the category of I-modules, there
 called [IModule_tensor] *)
(*
Check (IModule_tensor V : IModule V -> IModule V -> IModule V ).
Infix "⊗M" := (IModule_tensor V) (at level 31).

Lemma IModule_tensor_lifts_tensor (A B : IModule V) :
  𝒰 (A ⊗M B) = (𝒰 A) ⊗ (𝒰 B).
Proof.
  reflexivity.
Qed.
*)

(** * Structural strengths
covered by StructuralStrengths.v

************* *)

(** We suppose given an endofunctor H on V *)
Context  (H : V ⟶ V).

(** A structural strength consists of a natural transformation between
the two relevant parallel functors from V × M (denoted by V ⊠ M below)
to V, subject to two laws.

There is an implicit coercion between strengths and natural
transformations.  *)
Check (strength coeqsV tensorl_coeqs H ≡
         ∑ (st : nat_trans (C := V ×C PtIM_Cat) (C' := V)
                   ((H ×× 𝒰) ∙ tensor)
                   ((functor_identity _ ×× 𝒰) ∙ tensor ∙ H)
           ),
         (** first law: triangle *)
         (∏ (a : V), ρ' (H a) · st (a, (IP : PtIM_Cat))  = # H (ρ' a))
         (** second law: pentagon *)
           ×
           (∏ (a : V),
            ∏ (x y : PtIModule V) ,
            α' (H a) x y · identity (H a) #⊗ κ x y · st (a , (x ⊠M y : PtIM_Cat))
            =
            (st (a, (x : PtIM_Cat)) #⊗ identity y)
              · st ((a ⊗ x), (y : PtIM_Cat))
              · # H (α' a x y · identity a #⊗ κ x y))).

(** * Skew H-monoids

.. for H a strong endofonctor on V

covered by StructuralStrengths.v

************* *)

(** Notations for the unit and multiplication of a (skew) monoid (see
    SkewMonoids.v for the precise definition) *)
Local Definition η (m : skewMonoid V) : V ⟦I , m⟧ := sm_unit V m.
Local Definition μ (m : skewMonoid V) : V ⟦m ⊗ m, m⟧ := sm_mult V m.

(** We suppose given a strength for the endofunctor H *)
Context (st : strength coeqsV tensorl_coeqs H).

(**
A H-monoid consists of a skew monoid with an H algebra structure,
subject to some laws.
There is an implicit coercion between H-monoids and skew monoids.
 *)
Check (@algMonoid_data V H ≡ ∑ X : skewMonoid V, H X --> X).

(** Notation for the algebra structure *)
Check (∏ (X : algMonoid_data), am_alg X ≡ (pr2 X : H X --> X)).

Local Notation γ := am_alg.

(** A H-monoid consists of the data previously detailed subject to an equation *)
Check (algMonoid st ≡
         ∑ (X : algMonoid_data),
         st X (PtIModule_from_monoid _ X)
           · # H (μ X) · γ X
         = γ X #⊗ identity X · (μ X)).

(** A H-monoid morphism between H-monoids X and Y consists of a morphism that is
both a morphism of skew monoids and of algebras *)
Check  (∏ (X Y : algMonoid st),
        algMonoid_Mor X Y ≡
          ∑ (f : skewMonoid_Mor _ X Y) , γ X · f = # H f · (γ Y)).

(** H-monoids form a category (see StructuralStrengths.precategory_algMonoid
   for the details)
 *)
Check ( precategory_algMonoid st ≡
          (make_precategory_ob_mor (algMonoid st) (algMonoid_Mor (F := H) )
             ,, _) ,, _ ,, _).

End Summary.

(** * Axiomatized theorem from Fiore-Saville

Covered by Complements.v
Axiomatization of Theorem 4.7 of "List object with
algebraic structure" (Fiore-Saville, extended version).

This is the only admitted result of this formalization.

 *)

Check (@Thm47 :
         ∏ {D C B A : category}
           (OC : Initial C)(chC : Colims_of_shape nat_graph C)
           (chA : Colims_of_shape nat_graph A)
           {J : C ⟶ A}(OJ : isInitial _ (J (InitialObject OC)))
           (omegaJ : is_omega_cocont J)
           {F : D ×C C ⟶ C}
           (omegaF : ∏ d , is_omega_cocont (functor_fix_fst_arg _ _ _ F d))
           {G : B ×C A ⟶ A}
           (omegaG : ∏ b , is_omega_cocont (functor_fix_fst_arg _ _ _ G b))
           {K : D ⟶ B} (h : F ∙ J ⟹ (K ×× J) ∙ G)
           {a : A}{d : D}(α : A ⟦ G (K d , a) , a ⟧)
           (** Initial algebra of F(_, d) using Adamek's lemma *)
           (μFd :=
              (InitialObject
                 (colimAlgInitial
                    OC (omegaF d)
                    (chC (initChain OC (functor_fix_fst_arg D C C F d)))))),
         ∃! (β : A ⟦ J (alg_carrier _ μFd) , a ⟧),
         h (d , alg_carrier _ μFd) · # G ( identity _ #, β ) · α  =
         # J (alg_map _ μFd) · β).

(** * Main result,
 stated in a void context: the category of H-monoids has an
 initial object under the following assumptions

covered by InitialAlgebraicMonoid.v
 *)
Check (algMonoid_Initial :
           (** V is a skew monoidal category *)
        ∏ (V : skewmonoidal_category),
         (** V has colimits of chains *)
         Colims_of_shape nat_graph V ->
         (** V has an initial object *)
         Initial V ->
         (** V has binary coproducts *)
         BinCoproducts V ->
         (** V has coequalizers *)
         ∏ (coeqsV : Coequalizers V)
         (** the tensor is left cocontinuous *)
         (ltensor_CC : (∏ X : V,
                 is_cocont
                   (functor_fix_snd_arg V V V (skewmonoidal_tensor V) X)))
         (** H is an endofunctor on V with a strength *),
      ∏ (H : V ⟶ V) (st : strength coeqsV _ H),
         (** H is omega cocontinuous *)
         is_omega_cocont H →
         Initial (precategory_algMonoid st)
         ).

(** Notation for binary coproducts of functors *)
Infix "++" := (BinCoproduct_of_functors _ _ _) .

(** The underlying object of V is the initial algebra of the endofunctor
    X ↦ I + H(X) *)
Definition underlying_object :
         ∏ (V : skewmonoidal_category)
         ω O cp coeqsV lcc
         H st
         Hωcc,
       ((InitialObject (algMonoid_Initial V ω O cp coeqsV lcc H st Hωcc)
         : algMonoid st)
          (** The coercion yields the underlying object of V *)
        : V) =
       (** [alg_carrier F a] takes an F-algebra a and returns the underlying
           object *)
         alg_carrier
           (** here, F = I + H *)
           (constant_functor _ _ (skewmonoidal_I V) ++ H)
           (** and we consider the initial algebra *)
           (InitialObject (colimAlgInitial _ _ _))
  :=
    (* The proof *)
    (fun V ω O cp coeqsV lcc H st Hωcc =>
       A_is_InitialAlg_sumFI V ω O cp H Hωcc).


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime14139308836963 : prime 14139308836963.
Proof.
 apply (Pocklington_refl
         (Pock_certif 14139308836963 2 ((10607, 1)::(2,1)::nil) 6921)
        ((Proof_certif 10607 prime10607) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime6789012345678901234567903: prime  6789012345678901234567903.
apply (Pocklington_refl

(SPock_certif
6789012345678901234567903
2
((14139308836963, 1)::nil))
( (Proof_certif 14139308836963 prime14139308836963) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import TestSuite.admit.
Generalizable All Variables.
Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
Open Scope function_scope.
Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
Axiom IsHSet : Type -> Type.
Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000.
admit.
Defined.
Set Primitive Projections.
Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
Global Instance isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y).
admit.
Defined.
Local Open Scope equiv_scope.
Axiom equiv_path : forall (A B : Type) (p : A = B), A <~> B.

Goal forall (C D : hSet), IsEquiv (fun x : C = D => (equiv_path C D (ap setT x))).
  intros.
  change (IsEquiv (equiv_path C D o @ap _ _ setT C D)).
  apply @isequiv_compose; [ | admit ].
  Set Typeclasses Debug.
  typeclasses eauto.


Require Export Contexts.
Require Export HOASCircuits.
Require Export HOASLib.
Require Export DBCircuits.
Require Export QuantumLib.Quantum.
Require Export Denotation.

Fact denote_compose : forall safe w (c : Circuit w) (Γ : Ctx),
  Γ ⊢ c :Circ ->
     forall w' (f : Pat w -> Circuit w') (Γ0 Γ1 Γ1' Γ01 : Ctx),
  Γ1 ⊢ f :Fun ->
  Γ1' == Γ1 ∙ Γ ->
  Γ01 == Γ0 ∙ Γ1 ->
      denote_circuit safe (HOASCircuits.compose c f) Γ0 Γ1'
    = compose_super
        (denote_circuit safe (f (add_fresh_pat w Γ1)) Γ0 (add_fresh_state w Γ1))
        (denote_circuit safe c Γ01 Γ).
Proof.
  intros safe w c Γ TP.
  dependent induction TP.
  - intros w' f Γ0 Γ1 Γ1' Γ01 WT pf_merge1 pf_merge2.
    simpl.
    unfold compose_super.
    unfold denote_circuit.
    simpl.
    unfold pad.
    rewrite (ctx_wtype_size w p Γ) by easy.
    rewrite Nat.add_sub.
    rewrite size_fresh_ctx.
    destruct pf_merge1 as [V1 M1].
    replace (size_ctx Γ1') with (size_octx Γ1') by easy.
    rewrite M1 in *.
    rewrite size_octx_merge by easy.
    simpl.
    rewrite (ctx_wtype_size w p Γ t).
    admit. (* property about f being parametric *)
    (* ⟨ Γ0 | Γ1 ⋓ Γ2 ⊩ f p ⟩
    =  ⟨ Γ0 | fresh_state Γ2 ⊩ f (fresh_pat w Γ2) ⟩ ∘ ⟨ Γ1 ⊩ p ⟩
    *)
  - intros w' h Γ3 Γ2 Γ3' Γ03 WT pf_merge1 pf_merge2.
    replace (HOASCircuits.compose (gate g p1 f) h)
      with (gate g p1 (fun p2 => HOASCircuits.compose (f p2) h))
      by auto.
    repeat rewrite denote_gate_circuit; fold_denotation.

    set (p2 := process_gate_pat g p1 Γ3').
    set (Γ3'' := process_gate_state g p1 Γ3').

(*
    evar (Γ4 : OCtx).
    set (Γ4' := process_gate_state g p1 Γ1').
    assert (pf2 : Γ2' == Γ2 ∙ Γ) by admit.
    assert (H_p2 : Γ2 ⊢ process_gate_pat g p1 Γ3' :Pat) by admit.
    assert (H_h : Γ3 ⊢ h :Fun) by auto.
    assert (pf3 : Γ3'' == Γ3 ∙ Γ2') by admit.

    specialize (H Γ2 Γ2' (process_gate_pat g p1 Γ3') pf2 H_p2 w' h Γ0 Γ3 Γ3'' H_h pf3).
    fold p2 in H.
*)
  (*  rewrite H. *)

    admit (* sort of close *).

  - admit.
Admitted.

(**********************)
(* Composition lemmas *)
(**********************)

Theorem inSeq_correct : forall W1 W2 W3 (g : Box W2 W3) (f : Box W1 W2) (safe : bool),
      Typed_Box g -> Typed_Box f ->
      denote_box safe (inSeq f g) =
      compose_super (denote_box safe g) (denote_box safe f).
Proof.
  intros W1 W2 W3 g f safe types_g types_f.
  autounfold with den_db; simpl.

  destruct f as [f].
  destruct g as [g].
  autounfold with den_db; simpl.

  destruct (add_fresh W1 []) as [p1 Γ1] eqn:E1. simpl.
  destruct (add_fresh W2 []) as [p2 Γ2] eqn:E2. simpl.

  rewrite add_fresh_split in E1, E2.
  inversion E1. inversion E2.

  assert (S1 : ⟦Γ1⟧ = ⟦W1⟧).
    rewrite <- H1. rewrite size_fresh_ctx; auto.
  assert (S2 : ⟦Γ2⟧ = ⟦W2⟧).
    rewrite <- H3. rewrite size_fresh_ctx; auto.

  rewrite H0, H1, H2, H3.

  replace 0%nat with (⟦[]:Ctx⟧:nat) by auto.
  replace (size_wtype W1) with (⟦Γ1⟧).
  replace (size_wtype W2) with (⟦Γ2⟧).

  specialize denote_compose as DC.
  unfold denote_circuit in DC.

  rewrite DC with (Γ1 := []).
  simpl.
  unfold compose_super.
  rewrite H2, H3.
  reflexivity.
  * apply types_f. rewrite <- H0, <- H1. apply add_fresh_typed_empty. rewrite add_fresh_split. easy.
  * unfold Typed_Box in types_g. intros Γ Γ' p pf wf_p.
    solve_merge.
    apply types_g. monoid. rewrite merge_nil_r. auto.
  * solve_merge.
  * split; [validate|monoid].
Qed.

Fact inPar_correct : forall W1 W1' W2 W2' (f : Box W1 W1') (g : Box W2 W2') (safe : bool)
     (ρ1 : Square (2^⟦W1⟧)) (ρ2 : Square (2^⟦W2⟧)),
     Typed_Box f -> Typed_Box g ->
     WF_Matrix ρ1 ->
     WF_Matrix ρ2 ->
     denote_box safe (inPar f g) (ρ1 ⊗ ρ2)%M =
    (denote_box safe f ρ1 ⊗ denote_box safe g ρ2)%M.
Proof.
(*
  intros W1 W1' W2 W2' f g safe ρ1 ρ2 types_f types_g mixed_ρ1 mixed_ρ2.
  destruct f as [f].
  destruct g as [g].
  repeat (autounfold with den_db; simpl).

  set (p_1 := add_fresh_pat W1 []).
  set (Γ_1 := add_fresh_state W1 []).
  set (p_2 := add_fresh_pat W2 Γ_1).
  set (Γ_2 := add_fresh_state W2 Γ_1).
  assert (Γ_1 ⊢ p_1 :Pat) by apply fresh_state_empty_types_fresh_pat.
  assert (Γ_2 ⊢ p_2 :Pat) by admit (* need a vaiant of fresh_pat_typed *).

  replace 0%nat with (⟦[]:Ctx⟧) by auto.
  replace (size_wtype W1 + size_wtype W2)%nat with (⟦Γ_2⟧).
  replace (size_wtype W1) with (⟦Γ_1⟧).
  replace (size_wtype W2) with (⟦add_fresh_state W2 []⟧).

  specialize denote_compose as DC. unfold denote_circuit in DC.
  rewrite DC with (Γ1' := Γ_2) (Γ1 := Γ_2) (Γ := Γ_1).
  set (Γ_3 := pat_to_ctx (fresh_pat W1' Γ_2)).
  rewrite DC with (Γ1' := fresh_state W1' Γ_2) (Γ1 := Γ_3) (Γ := Γ_2). clear DC.

  autounfold with den_db.
  repeat rewrite merge_nil_l.
  (*
  repeat rewrite denote_tensor.
  Search (⟨ _ | _ ⊩ output _ ⟩).
  rewrite denote_output.
  autorewrite with proof_db.*)
  admit (* stuck *).
  * apply types_g; auto.
  * intros.
    destruct H1. econstructor. reflexivity.
    econstructor. 4: apply H2. assumption.
    rewrite merge_comm in pf_merge. apply pf_merge.
    unfold Γ_3.
    Search (pat_to_ctx) fresh_pat.
    admit (* need a variant of fresh_pat_typed *).
  * unfold Γ_3.
    assert (valid_Γ_2 : is_valid Γ_2) by admit.
    generalize (fresh_state_decompose W1' Γ_2 valid_Γ_2); intros assertion.
    solve_merge.
    rewrite pf_merge. monoid.
  * apply types_f; auto.
  * intros. eapply compose_typing. apply types_g. apply H0.
    intros. econstructor. reflexivity. econstructor.
    destruct H3. assumption.
    2: apply H2. 2: apply H4.
    rewrite merge_comm. destruct H3. apply pf_merge.
    destruct H1; constructor; [|rewrite merge_comm]; easy.
  * admit (* this is not true... *).
  * rewrite size_octx_fresh; auto. validate.
  * unfold Γ_1. rewrite size_octx_fresh. auto. validate.
  * unfold Γ_2, Γ_1. repeat rewrite size_octx_fresh. auto.
    validate. validate.
*)
Admitted.

Lemma HOAS_Equiv_inSeq : forall w1 w2 w3 (c1 c1' : Box w1 w2) (c2 c2' : Box w2 w3),
    Typed_Box c1 -> Typed_Box c1' ->  Typed_Box c2 -> Typed_Box c2' ->
    c1 ≡ c1' -> c2 ≡ c2' -> (c2 · c1) ≡ (c2' · c1').
Proof.
  intros w1 w2 w3 c1 c1' c2 c2' T1 T1' T2 T2' E1 E2.
  intros ρ b Mρ.
  simpl_rewrite inSeq_correct; trivial.
  simpl_rewrite inSeq_correct; trivial.
  unfold compose_super.
  rewrite E1 by easy.
  rewrite E2.
  easy.
  apply WF_denote_box; easy.
Qed.


Require Import List Nat Arith.
Import ListNotations.
Require Import Mmx.ast_instructions.

Check (1,2).
Check pair nat nat.
Definition tag_opcode_assoc :=
  list (tag * nat).

Scheme Equality for list.
Check list_beq.

(* actually this is a good name for this function :p *)
Fixpoint lookup (t : tag) (l : tag_opcode_assoc) : option nat :=
  match l with
    | [] => None
    | (t',n) :: tl => if tag_beq t t'
                      then Some n
                      else lookup t tl
  end.
(* actually this is a good name for this function :p *)
Fixpoint lookdown (n : nat) (l : tag_opcode_assoc) : option tag :=
  match l with
    | [] => None
    | (t,n') :: tl => if  eqb n n'
                      then Some t
                      else lookdown n tl
  end.

(* this table is an association list of type tag_opcode_assoc with every associations that can be made in our langage *)
Definition encdec : tag_opcode_assoc := [(tag_t_n(ADD),0);(tag_t_n(AND),1);(tag_t_i(ADD_I),2);(tag_t_i(AND_I),3);
                                        (tag_d_n(JUMP),4);(tag_d_n(JUMPC),5);(tag_d_i(JUMP_I),6);(tag_d_i(JUMP_IC),7)].

Theorem lookup_encdec : forall (t : tag), exists n,
                          lookup t encdec = Some n.
Proof.
  destruct t.
  -destruct t.
   +simpl. exists 0. reflexivity.
   +simpl. exists 1. reflexivity.
  -destruct t.
   +simpl. exists 2. reflexivity.
   +simpl. exists 3. reflexivity.
  -destruct t.
   +simpl. exists 6. reflexivity.
   +simpl. exists 7. reflexivity.
  -destruct t.
   +simpl. exists 4. reflexivity.
   +simpl. exists 5. reflexivity.
Qed.

Require Import Bool.

Print tag.

Definition forall_tag_ter_n (p : tag_ter_normal -> bool): bool :=
  andb (p ADD) (p AND).

Definition forall_tag_ter_i (p : tag_ter_immediate -> bool): bool :=
  andb (p ADD_I) (p AND_I).

Definition forall_tag_duo_n (p : tag_duo_normal -> bool): bool :=
  andb (p JUMP) (p JUMPC).

Definition forall_tag_duo_i (p : tag_duo_immediate -> bool): bool :=
  andb (p JUMP_I) (p JUMP_IC).

Definition forall_tag (p : tag -> bool): bool :=
  andb (andb (forall_tag_ter_n (fun (x : tag_ter_normal) => p (tag_t_n x)))
             (forall_tag_ter_i (fun (x : tag_ter_immediate) => p (tag_t_i x))))
       (andb (forall_tag_duo_n (fun (x : tag_duo_normal) => p (tag_d_n x)))
             (forall_tag_duo_i (fun (x : tag_duo_immediate) => p (tag_d_i x)))).

Print reflect.

Definition propP := forall x : nat, x = x.
Check propP.

Lemma test_reflect : True -> reflect True true.
Proof.
  exact (ReflectT True).
Qed.

Lemma helpBefore1 : forall (f : tag -> bool), forall_tag f = true -> (forall (t: tag), f t = true).
Proof.
  intros f.
  unfold forall_tag.
  intros H.
  Search (_ && _ = true).
  apply andb_prop in H.
  unfold forall_tag_ter_n in H.
  unfold forall_tag_ter_i in H.
  unfold forall_tag_duo_n in H.
  unfold forall_tag_duo_i in H.
  destruct H.
  apply andb_prop in H.
  destruct H.
  apply andb_prop in H0.
  destruct H0.
  apply andb_prop in H.
  destruct H.
  apply andb_prop in H1.
  destruct H1.
  apply andb_prop in H0.
  destruct H0.
  apply andb_prop in H2.
  destruct H2.
  destruct t.
  {
    -destruct t.
     +rewrite H.
      reflexivity.
     +rewrite H3.
      reflexivity.
  }
  {
     -destruct t.
      +rewrite H1.
       reflexivity.
      +rewrite H4.
       reflexivity.
  }
  {
    -destruct t.
     +rewrite H2.
      reflexivity.
     +rewrite H6.
      reflexivity.
  }
  {
      {
    -destruct t.
     +rewrite H0.
      reflexivity.
     +rewrite H5.
      reflexivity.
  }
  }
Qed.

Lemma helpBefore2 : forall (f : tag -> bool), (forall (t: tag), f t = true) -> forall_tag f = true.
Proof.
  intros f H.
  unfold forall_tag.
  Search (_ && _ = true).
  apply andb_true_intro.
  split.
  -compute. rewrite H. rewrite H. apply andb_true_intro.
   split.
   +apply H.
   +apply H.
  -compute. rewrite H. rewrite H. apply andb_true_intro.
   split.
   +apply H.
   +apply H.
Qed.

Lemma forall_tagP: forall (P : tag -> Prop)(f : tag -> bool),
    (forall (t : tag), reflect (P t) (f t)) ->
    reflect (forall t, P t) (forall_tag f).
Proof.
  intros P f H.
  Search reflect.
  apply iff_reflect.
  apply iff_to_and.
  split.
  -Search forall_tag.
   intros.
   rewrite helpBefore2.
   +reflexivity.
   +intros t.
    specialize (H t).
    Search forall_tag.
    apply reflect_iff in H.
    inversion H.
    specialize (H0 t).
    apply H1.
    exact H0.
    (* this part is ok !!! ;) *)
  -intros.
   specialize (H t).
   rewrite helpBefore1 in H.
   inversion H.
   +exact H1.
   +exact H0.
Qed.

SearchAbout leb.
(* the first nat is the maximum we wan't to have in this bounded nat interval *)
Fixpoint forall_bounded (n : nat) (f : nat -> bool) : bool :=
  match n with
  | 0 => f 0
  | S n => f (S n) && forall_bounded n f
  end.

Check forall_bounded.
(* (* SAVE THIS *) *)
(* Lemma help_forall_findP1 : forall (f : nat -> bool), (forall (n: nat), f n = true) -> forall (k : nat), forall_bounded k f = true. *)
(* Proof. *)
(*   intros. *)
(*   induction k. *)
(*   -simpl. *)
(*    apply H. *)
(*   -simpl. *)
(*    rewrite IHk. *)
(*    Search (_ && _ = true). *)
(*    apply andb_true_intro. *)
(*    split. *)
(*    +apply H. *)
(*    +reflexivity. *)
(* Qed. *)
Lemma help_forall_findP1 : forall (f : nat -> bool) (k : nat), (forall (n: nat), n <= k -> f n = true) -> forall_bounded k f = true.
Proof.
  intros.
  induction k.
  -apply H.
   reflexivity.
  -simpl.
   Search (_ && _ = true).
   apply andb_true_intro.
   split.
   +apply H.
    reflexivity.
   +apply IHk.
    intros n.
    specialize (H n).
    intros.
    apply H.
    Search (_ <= S _).
    apply le_S in H0.
    exact H0.
Qed.

Lemma help_forall_findP2 :
  forall (k : nat) (f : nat -> bool), forall_bounded k f = true -> (forall (n: nat), n <= k -> f n = true).
Proof.
  induction k.
  -simpl.
   intros.
   Search (_ <= 0).
   apply le_n_0_eq in H0.
   rewrite <- H0.
   exact H.
  -destruct n.
   +intros.
    apply IHk.
    simpl in H.
    Search (_ && _ = true).
    apply andb_prop in H.
    destruct H.
    exact H1.
    apply Peano.le_0_n.
   +apply andb_prop in H.
    fold forall_bounded in H.
    destruct H.
    intros.
    change (f (S n) = true) with ((fun n => f (S n)) n = true).
    apply IHk.
    {(* c'est donner par H0 et H mais faut trouver un théoreme pour reussir a exprimer ça *)
      assert (forall (k' : nat) (f' : nat -> bool) , f' (S k') = true -> forall_bounded k' f' = true -> forall_bounded k' (fun n0 : nat => f' (S n0)) = true).
      {
        induction k'.
        -intros.
         simpl.
         auto.
        -intros.
         simpl.
         rewrite H2.
         simpl.
         apply IHk'.
         +unfold forall_bounded in H3.
          fold forall_bounded in H3.
          apply andb_true_iff in H3.
          destruct H3.
          auto.
         +unfold forall_bounded in H3.
          fold forall_bounded in H3.
          apply andb_true_iff in H3.
          destruct H3.
          auto.
      }
      auto.
    }
    {
      Search (S _ <= S _).
      apply le_S_n in H1.
      exact H1.
    }
Qed.

Lemma forall_finP: forall (P : nat -> Prop)(f : nat -> bool) (k : nat),
    (forall (n : nat), reflect (P n) (f n)) ->
    reflect (forall n, n <= k -> P n) (forall_bounded k f).
Proof.
  intros P f k H.
  apply iff_reflect.
  apply iff_to_and.
  split.
  -intros.
   Check help_forall_findP1.
   apply help_forall_findP1.
   intros.
   specialize (H n).
   apply reflect_iff in H.
   inversion H.
   apply H2.
   apply H0.
   exact H1.
  -intros.
   Check help_forall_findP2.
   eapply help_forall_findP2 in H0.
   specialize (H n).
   rewrite H0 in H.
   inversion H.
   exact H2.
   exact H1.
Qed.

Definition imply (a b : bool): bool := if a then b else true.

Lemma implyP: forall A B a b, reflect A a -> reflect B b -> reflect (A -> B) (imply a b).
Proof.
  intros.
  apply reflect_iff in H.
  inversion H.
  apply reflect_iff in H0.
  inversion H0.
  apply iff_reflect.
  apply iff_to_and.
  unfold imply.
  split.
  -intros.
   destruct a.
   +apply H3.
    apply H5.
    apply H2.
    reflexivity.
   +reflexivity.
  -intros.
   destruct b.
   +apply H4.
    reflexivity.
   +destruct a.
    {
      discriminate.
    }
    {
      apply H4.
      apply H1.
      exact H6.
    }
Qed.

SearchAbout beq_nat.

Definition eq_mtag (t1 t2: option tag): bool :=
  match t1,t2 with
  | Some t1', Some t2' => tag_beq t1' t2'
  | _,_ => false
  end.

Lemma eq_mtag_equiv : forall (t1 t2 : option tag), eq_mtag t1 t2 = true -> t1 = t2.
Proof.
  destruct t1.
  -destruct t2.
   +simpl.
   intros.
   apply tag_beq_different in H.
   rewrite H.
   reflexivity.
   +discriminate.
  -discriminate.
Qed.

Definition eq_mnat (t1 t2: option nat): bool :=
  match t1,t2 with
  | Some n1,Some n2 => beq_nat n1 n2
  | _,_ => false
  end.

Lemma eq_mnat_equiv : forall (n1 n2 : option nat), eq_mnat n1 n2 = true -> n1 = n2.
Proof.
  destruct n1.
  -destruct n2.
   +simpl.
    intros.
    Search (_ =? _ = true).
    apply beq_nat_true in H.
    rewrite H.
    reflexivity.
   +discriminate.
  -discriminate.
Qed.

Definition lookdown_encdecP : bool :=
  forall_bounded 7 (fun n =>
                      forall_tag (fun t => imply (eq_mtag (lookdown n encdec) (Some t))
                                                 (eq_mnat (lookup t encdec) (Some n)))).
Definition lookdown_encdecP' : bool :=
  forall_bounded 7 (fun n =>
                      forall_tag (fun t => imply (eq_mnat (lookup t encdec) (Some n))
                                                 (eq_mtag (lookdown n encdec) (Some t)))).

Lemma lookdown_n_inf_7 : forall (n : nat) (t : tag), lookdown n encdec = Some t -> n <=7.
Proof.
  destruct n.
  -intros.
   Search (0 <= _).
   apply Peano.le_0_n.
  -{destruct n.
    -intros.
     Search (S _ <= S _).
     apply le_n_S.
     apply Peano.le_0_n.
    -{
        destruct n.
        -intros.
         repeat (apply le_n_S).
         apply Peano.le_0_n.
        -{
            destruct n.
            -intros.
             repeat (apply le_n_S).
             apply Peano.le_0_n.
            -{destruct n.
              -intros.
               Search (S _ <= S _).
               repeat apply le_n_S.
               apply Peano.le_0_n.
              -{destruct n.
                -intros.
                 Search (S _ <= S _).
                 repeat apply le_n_S.
                 apply Peano.le_0_n.
                -{destruct n.
                  -intros.
                   Search (S _ <= S _).
                   repeat apply le_n_S.
                   apply Peano.le_0_n.
                  -{destruct n.
                    -intros.
                     Search (S _ <= S _).
                     repeat apply le_n_S.
                     apply Peano.le_0_n.
                    -discriminate.
                   }
                 }
               }
             }
          }
      }
   }
Qed.

Theorem lookdown_encdec : forall (n : nat) (t : tag), lookdown n encdec = Some t -> lookup t encdec = Some n.
Proof.
  SearchAbout (_ < _ \/ _).
  assert (reflect (forall (n : nat), n <= 7 -> forall
                       (t : tag), lookdown n encdec = Some t -> lookup t encdec = Some n)
                  lookdown_encdecP).
  {
    unfold lookdown_encdecP.
    SearchAbout forall_bounded.
    Check forall_finP.
    apply forall_finP.
    intro n.
    Check forall_tag.
    apply forall_tagP.
    SearchAbout imply.
    intros t.
    apply implyP.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
    {
      apply iff_reflect.
      apply iff_to_and.
      split.
      +intros.
       rewrite H.
       simpl.
       rewrite tag_beq_reflexivity.
       reflexivity.
      +intros.
       apply eq_mtag_equiv in H.
       exact H.
    }
    exact H.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
    {
      apply iff_reflect.
      apply iff_to_and.
      split.
      -intros.
      rewrite H.
      simpl.
      Search (_ =? _).
      rewrite <- beq_nat_refl.
      reflexivity.
      -intros.
       apply eq_mnat_equiv in H.
       exact H.
    }
    exact H.
  }
  assert (H': lookdown_encdecP = true) by reflexivity.
  rewrite H' in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 7).
  intros.
  destruct H1.
  -apply H0.
   exact H1.
   exact H2.
  -assert (exists m, n = 8 + m).
   {
     (* not that simple *)
     Search (_ < _).
     admit.
   }
   destruct H3.
   subst n.
   simpl in H2.
   discriminate.
  Admitted.

Theorem lookup_encdecP : forall (n : nat) (t : tag) , lookup t encdec = Some n -> lookdown n encdec = Some t.
Proof.
  SearchAbout reflect.
  assert (reflect (forall (n : nat), n <= 7 -> forall (t : tag), lookup t encdec = Some n -> lookdown n encdec = Some t) lookdown_encdecP').
  {
    unfold lookdown_encdecP.
    SearchAbout reflect.
    Check forall_finP.
    apply forall_finP.
    Check forall_tagP.
    intros n.
    apply forall_tagP.
    SearchAbout reflect.
    Check implyP.
    intros t.
    apply implyP.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply Nat.eqb_refl.
       +intros.
        apply eq_mnat_equiv in H.
        exact H.
     }
     exact H.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply tag_beq_reflexivity.
       +intros.
        apply eq_mtag_equiv in H.
        exact H.
     }
     exact H.
  }
  assert (lookdown_encdecP' = true) by reflexivity.
  rewrite H0 in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 7).
  intros.
  destruct H2.
  -apply H1.
   exact H2.
   exact H3.
  -assert (exists m, n = 8 + m).
   {
     admit.
   }
   destruct H4.
   subst n.
   Check lookdown_n_inf_7.
   simpl in H3.
Admitted.


(**
   This file is part of the supplementary material accompanying the
   submission to CPP'20:
   _An Equational Theory for Weak Bisimulation via Generalized Parameterized Coinduction_
 *)
(**
   These few examples illustrates the shortcoming of paco and the use of euttG.
*)
(* begin hide *)
From Paco Require Import paco.
From Coq Require Import
     Nat
     Morphisms
     Program.

From EuttG Require Import stream euttG.
(* end hide *)

Section Examples.

  Open Scope stream_scope.

  Notation euttF := (bisim_ true true).

  Lemma ex_incr f1 f2 g1 g2
        (EQF1: forall n, f1 n = Tau (Vis n (f2 n)))
        (EQF2: forall n, f2 n = if n =? 0
                                then Tau (f1 (n+1))
                                else Tau (f2 (n+1)))
        (EQG1: forall n, g1 n = Vis n (g2 n))
        (EQG2: forall n, g2 n = if n =? 0
                                then Tau (g1 (n+1))
                                else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    do 2 red. pcofix CIH1. intros.
    rewrite EQF1, EQG1.
    pstep; do 2 econstructor; repeat red.
    left. revert n. pcofix CIH2. intros.
    rewrite EQF2, EQG2.
    destruct (n =? 0); simpl.
    - pstep; econstructor; repeat red.
      right. apply CIH1.
    - pstep; econstructor; repeat red.
      right. apply CIH2.
  Qed.

  Lemma ex_incr2_awkward f1 f2 g1 g2
        (EQF1: forall n, f1 n = Tau (Vis n (f2 n)))
        (EQF2: forall n, f2 n = if n =? 0
                                then (* Tau *) (f1 (n+1))
                                else Tau (f2 (n+1)))
        (EQG1: forall n, g1 n = Vis n (g2 n))
        (EQG2: forall n, g2 n = if n =? 0
                                then (* Tau *) (g1 (n+1))
                                else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    pcofix CIH1. intros.
    rewrite EQF1, EQG1.
    pstep; do 2 econstructor; repeat red.
    left.
    revert n. pcofix CIH2. intros.
    rewrite EQF2, EQG2.
    destruct (n =? 0); simpl.
    - (* We can't use CIH1 here *)
      (* begin unnecessary reasoning *)
      rewrite EQF1, EQG1.
      pstep; do 2 econstructor; repeat red.
      right. apply CIH2.
    (* end unnecessary reasoning *)
    - pstep; econstructor; repeat red.
      right. apply CIH2.
  Qed.

  Lemma ex_incr2 f1 f2 g1 g2
        (EQF1: forall n, f1 n = Tau (Vis n (f2 n)))
        (EQF2: forall n, f2 n = if n =? 0
                                then (* Tau *) (f1 (n+1))
                                else Tau (f2 (n+1)))
        (EQG1: forall n, g1 n = Vis n (g2 n))
        (EQG2: forall n, g2 n = if n =? 0
                                then (* Tau *) (g1 (n+1))
                                else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    ginit. gcofix CIH1. intros.
    rewrite EQF1, EQG1.
    gstep; do 2 econstructor; repeat red.
    revert n. gcofix CIH2. intros.
    rewrite EQF2, EQG2.
    destruct n; simpl.
    - gbase. apply CIH1.
    - gstep; econstructor; repeat red.
      gbase. apply CIH2.
  Qed.

  Lemma ex_upto h1 h2 f1 f2 g1 g2
        (EQH: forall n, eutt (h1 n) (h2 n))
        (EQF1: forall n, f1 n ≳ (h1 n ;; Vis n (f2 n)))
        (EQF2: forall n, f2 n ≳ if n =? 0
                                then f1 (n+1)
                                else Tau (f2 (n+1)))
        (EQG1: forall n, g1 n ≳ (h2 n ;; Vis n (g2 n)))
        (EQG2: forall n, g2 n ≳ if n =? 0
                                then g1 (n+1)
                                else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    ginit. gcofix CIH1. intros.
    (* guclo bisim_clo_trans. econstructor. *)
    (* { eapply EQF1. } *)
    (* { eapply EQG1. } *)
    rewrite EQF1, EQG1.
    guclo bisim_clo_concat. econstructor.
    { apply EQH. }
    gstep; econstructor; repeat red.
    revert n. gcofix CIH2. intros.
    guclo bisim_clo_trans. econstructor.
    { eapply EQF2. }
    { eapply EQG2. }
    destruct n; simpl.
    - gbase. apply CIH1.
    - gstep; econstructor; repeat red.
      gbase. apply CIH2.
  Qed.

  Lemma ex_upto' h1 h2 f1 f2 g1 g2
        (EQH: forall n, eutt (h1 n) (h2 n))
        (EQF1: forall n, f1 n ≳ (h1 n ;; Vis n (f2 n)))
        (EQF2: forall n, f2 n ≳ if n =? 0
                                then f1 (n+1)
                                else Tau (f2 (n+1)))
        (EQG1: forall n, g1 n ≳ (h2 n ;; Vis n (g2 n)))
        (EQG2: forall n, g2 n ≳ if n =? 0
                                then g1 (n+1)
                                else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    ginit. gcofix CIH1. intros.
    guclo bisim_clo_trans. econstructor.
    { eapply EQF1. }
    { eapply EQG1. }
    guclo bisim_clo_concat. econstructor.
    { apply EQH. }
    gstep; econstructor; repeat red.
    revert n. gcofix CIH2. intros.
    guclo bisim_clo_trans. econstructor.
    { eapply EQF2. }
    { eapply EQG2. }
    destruct n; simpl.
    - gbase. apply CIH1.
    - gstep; econstructor; repeat red.
      gbase. apply CIH2.
  Qed.

  Lemma ex_upto_rewrite h1 h2 f1 f2 g1 g2
        (EQH: forall n, eutt (h1 n) (h2 n))
        (EQF1: forall n, f1 n ≳ (h1 n ;; Vis n (f2 n)))
        (EQF2: forall n, f2 n ≳ if n =? 0
                                then f1 (n+1)
                                else Tau (f2 (n+1)))
        (EQG1: forall n, g1 n ≳ (h2 n ;; Vis n (g2 n)))
        (EQG2: forall n, g2 n ≳ if n =? 0
                           then g1 (n+1)
                           else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    ginit. gcofix CIH1. intros.
    rewrite EQF1, EQG1.
    guclo bisim_clo_concat. econstructor. { apply EQH. }
                                       gstep; econstructor; repeat red.
    revert n. gcofix CIH2. intros.
    rewrite EQF2, EQG2.
    destruct n; simpl.
    - gbase. apply CIH1.
    - gstep; econstructor; repeat red.
      gbase. apply CIH2.
  Qed.

  (* Example illustrating the rewriting by directed eutt *)
  Lemma ex_eutt h1 h2 f1 f2 g1 g2
        (EQH: forall n, eutt (h1 n) (h2 n))
        (EQF1: forall n, eutt (f1 n) (h1 n ;; Vis n (f2 n)))
        (EQF2: forall n, f2 n ≳ if n =? 0
                           then f1 (n+1)
                           else Tau (f2 (n+1)))
        (EQG1: forall n, eutt (g1 n) ((h2 n ;; Vis n (g2 n))))
        (EQG2: forall n, g2 n ≳ if n =? 0
                           then g1 (n+1)
                           else Tau (g2 (n+1))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    einit. ecofix CIH1. intros.
    edrop. rewrite EQF1, EQG1.
    econcat. econstructor.
    { apply EQH. }
    estep.
    revert n. ecofix CIH2. intros.
    rewrite EQF2, EQG2.
    destruct n; simpl.
    - ebase.
    - estep.
  Qed.

  (* The same statement assuming eutt is incorrect, and indeed the rewriting up
  to undirected eutt has correctly dropped too much information to conclude *)
  Lemma ex_eutt_failed h1 h2 f1 f2 g1 g2
        (EQH: forall n, eutt (h1 n) (h2 n))
        (EQF1: forall n, eutt (f1 n) (h1 n ;; Vis n (f2 n)))
        (EQF2: forall n, eutt (f2 n) (if n =? 0
                                 then f1 (n+1)
                                 else Tau (f2 (n+1))))
        (EQG1: forall n, eutt (g1 n) ((h2 n ;; Vis n (g2 n))))
        (EQG2: forall n, eutt (g2 n) (if n =? 0
                                 then g1 (n+1)
                                 else Tau (g2 (n+1)))):
    forall n, eutt (f1 n) (g1 n).
  Proof.
    einit. ecofix CIH1. intros.
    edrop. rewrite EQF1, EQG1.
    econcat. econstructor.
    { apply EQH. }
    estep.
    revert n. ecofix CIH2. intros.
    edrop. rewrite EQF2, EQG2.
    destruct n; simpl.
    - ebase.
    - estep. (* We (rightfully) cannot conclude! *)
  Abort.

End Examples.


(** * ImpParser: Lexing and Parsing in Coq *)

(** The development of the [Imp] language in Imp.v completely ignores
    issues of concrete syntax -- how an ascii string that a programmer
    might write gets translated into the abstract syntax trees defined
    by the datatypes [aexp], [bexp], and [com].  In this file we
    illustrate how the rest of the story can be filled in by building
    a simple lexical analyzer and parser using Coq's functional
    programming facilities.

    This development is not intended to be understood in detail: the
    explanations are fairly terse and there are no exercises.  The
    main point is simply to demonstrate that it can be done.  You are
    invited to look through the code -- most of it is not very
    complicated, though the parser relies on some "monadic"
    programming idioms that may require a little work to make out --
    but most readers will probably want to just skip down to the
    Examples section at the very end to get the punchline. *)

(* ####################################################### *)
(** * Internals *)

Require Import SfLib.
Require Import Imp.

Require Import String.
Require Import Ascii.

Open Scope list_scope.

(* ####################################################### *)
(** ** Lexical Analysis *)

Definition isWhite (c : ascii) : bool :=
  let n := nat_of_ascii c in
  orb (orb (beq_nat n 32)   (* space *)
           (beq_nat n 9))   (* tab *)
      (orb (beq_nat n 10)   (* linefeed *)
           (beq_nat n 13)). (* Carriage return. *)

Notation "x '<=?' y" := (ble_nat x y)
  (at level 70, no associativity) : nat_scope.

Definition isLowerAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (97 <=? n) (n <=? 122).

Definition isAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    orb (andb (65 <=? n) (n <=? 90))
        (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c : ascii) : bool :=
  let n := nat_of_ascii c in
     andb (48 <=? n) (n <=? 57).

Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c : ascii) : chartype :=
  if isWhite c then
    white
  else if isAlpha c then
    alpha
  else if isDigit c then
    digit
  else
    other.

Fixpoint list_of_string (s : string) : list ascii :=
  match s with
  | EmptyString => []
  | String c s => c :: (list_of_string s)
  end.

Fixpoint string_of_list (xs : list ascii) : string :=
  fold_right String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii)
                       : list (list ascii) :=
  let tk := match acc with [] => [] | _::_ => [rev acc] end in
  match xs with
  | [] => tk
  | (x::xs') =>
    match cls, classifyChar x, x with
    | _, _, "("      => tk ++ ["("]::(tokenize_helper other [] xs')
    | _, _, ")"      => tk ++ [")"]::(tokenize_helper other [] xs')
    | _, white, _    => tk ++ (tokenize_helper white [] xs')
    | alpha,alpha,x  => tokenize_helper alpha (x::acc) xs'
    | digit,digit,x  => tokenize_helper digit (x::acc) xs'
    | other,other,x  => tokenize_helper other (x::acc) xs'
    | _,tp,x         => tk ++ (tokenize_helper tp [x] xs')
    end
  end %char.

Definition tokenize (s : string) : list string :=
  map string_of_list (tokenize_helper white [] (list_of_string s)).

Example tokenize_ex1 :
    tokenize "abc12==3  223*(3+(a+c))" %string
  = ["abc"; "12"; "=="; "3"; "223";
       "*"; "("; "3"; "+"; "(";
       "a"; "+"; "c"; ")"; ")"]%string.
Proof. reflexivity. Qed.

(* ####################################################### *)
(** ** Parsing *)

(* ####################################################### *)
(** *** Options with Errors *)

(* An option with error messages. *)
Inductive optionE (X:Type) : Type :=
  | SomeE : X -> optionE X
  | NoneE : string -> optionE X.

Implicit Arguments SomeE [[X]].
Implicit Arguments NoneE [[X]].

(* Some syntactic sugar to make writing nested match-expressions on
   optionE more convenient. *)

Notation "'DO' ( x , y ) <== e1 ; e2"
   := (match e1 with
         | SomeE (x,y) => e2
         | NoneE err => NoneE err
       end)
   (right associativity, at level 60).

Notation "'DO' ( x , y ) <-- e1 ; e2 'OR' e3"
   := (match e1 with
         | SomeE (x,y) => e2
         | NoneE err => e3
       end)
   (right associativity, at level 60, e2 at next level).

(* ####################################################### *)
(** *** Symbol Table *)

(* Build a mapping from [tokens] to [nats].  A real parser would do
   this incrementally as it encountered new symbols, but passing
   around the symbol table inside the parsing functions is a bit
   inconvenient, so instead we do it as a first pass. *)
Fixpoint build_symtable (xs : list token) (n : nat) : (token -> nat) :=
  match xs with
  | [] => (fun s => n)
  | x::xs =>
    if (forallb isLowerAlpha (list_of_string x))
     then (fun s => if string_dec s x then n else (build_symtable xs (S n) s))
     else build_symtable xs n
  end.

(* ####################################################### *)
(** *** Generic Combinators for Building Parsers *)

Open Scope string_scope.

Definition parser (T : Type) :=
  list token -> optionE (T * list token).

Fixpoint many_helper {T} (p : parser T) acc steps xs :=
match steps, p xs with
| 0, _ => NoneE "Too many recursive calls"
| _, NoneE _ => SomeE ((rev acc), xs)
| S steps', SomeE (t, xs') => many_helper p (t::acc) steps' xs'
end.

(* A (step-indexed) parser which expects zero or more [p]s *)
Fixpoint many {T} (p : parser T) (steps : nat) : parser (list T) :=
  many_helper p [] steps.

(* A parser which expects a given token, followed by p *)
Definition firstExpect {T} (t : token) (p : parser T) : parser T :=
  fun xs => match xs with
              | x::xs' => if string_dec x t
                           then p xs'
                          else NoneE ("expected '" ++ t ++ "'.")
              | [] =>  NoneE ("expected '" ++ t ++ "'.")
            end.

(* A parser which expects a particular token *)
Definition expect (t : token) : parser unit :=
  firstExpect t (fun xs => SomeE(tt, xs)).

(* ####################################################### *)
(** *** A Recursive-Descent Parser for Imp *)

(* Identifiers *)
Definition parseIdentifier (symtable :string->nat) (xs : list token)
                         : optionE (id * list token) :=
match xs with
| [] => NoneE "Expected identifier"
| x::xs' =>
    if forallb isLowerAlpha (list_of_string x) then
      SomeE (Id (symtable x), xs')
    else
      NoneE ("Illegal identifier:'" ++ x ++ "'")
end.

(* Numbers *)
Definition parseNumber (xs : list token) : optionE (nat * list token) :=
match xs with
| [] => NoneE "Expected number"
| x::xs' =>
    if forallb isDigit (list_of_string x) then
      SomeE (fold_left (fun n d =>
                        10 * n + (nat_of_ascii d - nat_of_ascii "0"%char))
                (list_of_string x)
                0,
              xs')
    else
      NoneE "Expected number"
end.

(* Parse arithmetic expressions *)
Fixpoint parsePrimaryExp (steps:nat) symtable (xs : list token)
   : optionE (aexp * list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
      DO (i, rest) <-- parseIdentifier symtable xs ;
          SomeE (AId i, rest)
      OR DO (n, rest) <-- parseNumber xs ;
          SomeE (ANum n, rest)
      OR (DO (e, rest)  <== firstExpect "(" (parseSumExp steps' symtable) xs;
          DO (u, rest') <== expect ")" rest ;
          SomeE(e,rest'))
  end
with parseProductExp (steps:nat) symtable (xs : list token)  :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parsePrimaryExp steps' symtable xs ;
    DO (es, rest') <==
      many (firstExpect "*" (parsePrimaryExp steps' symtable)) steps' rest;
    SomeE (fold_left AMult es e, rest')
  end
with parseSumExp (steps:nat) symtable (xs : list token)  :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parseProductExp steps' symtable xs ;
    DO (es, rest') <==
      many (fun xs =>
             DO (e,rest') <--
               firstExpect "+" (parseProductExp steps' symtable) xs;
                                 SomeE ( (true, e), rest')
             OR DO (e,rest') <==
               firstExpect "-" (parseProductExp steps' symtable) xs;
                                 SomeE ( (false, e), rest'))
                            steps' rest;
      SomeE (fold_left (fun e0 term =>
                          match term with
                            (true,  e) => APlus e0 e
                          | (false, e) => AMinus e0 e
                          end)
                       es e,
             rest')
  end.

Definition parseAExp := parseSumExp.

(* Parsing boolean expressions. *)
Fixpoint parseAtomicExp (steps:nat) (symtable : string->nat) (xs : list token)  :=
match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
     DO    (u,rest) <-- expect "true" xs;
         SomeE (BTrue,rest)
     OR DO (u,rest) <-- expect "false" xs;
         SomeE (BFalse,rest)
     OR DO (e,rest) <-- firstExpect "not" (parseAtomicExp steps' symtable) xs;
         SomeE (BNot e, rest)
     OR DO (e,rest) <-- firstExpect "(" (parseConjunctionExp steps' symtable) xs;
          (DO (u,rest') <== expect ")" rest; SomeE (e, rest'))
     OR DO (e, rest) <== parseProductExp steps' symtable xs ;
            (DO (e', rest') <--
              firstExpect "==" (parseAExp steps' symtable) rest ;
              SomeE (BEq e e', rest')
             OR DO (e', rest') <--
               firstExpect "<=" (parseAExp steps' symtable) rest ;
               SomeE (BLe e e', rest')
             OR
               NoneE "Expected '==' or '<=' after arithmetic expression")
end
with parseConjunctionExp (steps:nat) (symtable : string->nat) (xs : list token)   :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parseAtomicExp steps' symtable xs ;
    DO (es, rest') <==
      many (firstExpect "&&" (parseAtomicExp steps' symtable)) steps' rest;
    SomeE (fold_left BAnd es e, rest')
  end.

Definition parseBExp := parseConjunctionExp.

(*
Eval compute in
  (parseProductExp 100 (tokenize "x*y*(x*x)*x")).

Eval compute in
  (parseDisjunctionExp 100 (tokenize "not((x==x||x*x<=(x*x)*x)&&x==x)")).
*)

(* Parsing commands *)
Fixpoint parseSimpleCommand (steps:nat) (symtable:string->nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (u, rest) <-- expect "SKIP" xs;
      SomeE (SKIP, rest)
    OR DO (e,rest) <--
         firstExpect "IF" (parseBExp steps' symtable) xs;
       DO (c,rest')  <==
         firstExpect "THEN" (parseSequencedCommand steps' symtable) rest;
       DO (c',rest'') <==
         firstExpect "ELSE" (parseSequencedCommand steps' symtable) rest';
       DO (u,rest''') <==
         expect "END" rest'';
       SomeE(IFB e THEN c ELSE c' FI, rest''')
    OR DO (e,rest) <--
         firstExpect "WHILE" (parseBExp steps' symtable) xs;
       DO (c,rest') <==
         firstExpect "DO" (parseSequencedCommand steps' symtable) rest;
       DO (u,rest'') <==
         expect "END" rest';
       SomeE(WHILE e DO c END, rest'')
    OR DO (i, rest) <==
         parseIdentifier symtable xs;
       DO (e, rest') <==
         firstExpect ":=" (parseAExp steps' symtable) rest;
       SomeE(i ::= e, rest')
  end

with parseSequencedCommand (steps:nat) (symtable:string->nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
      DO (c, rest) <==
        parseSimpleCommand steps' symtable xs;
      DO (c', rest') <--
        firstExpect ";;" (parseSequencedCommand steps' symtable) rest;
        SomeE(c ;; c', rest')
      OR
        SomeE(c, rest)
  end.

Definition bignumber := 1000.

Definition parse (str : string) : optionE (com * list token) :=
  let tokens := tokenize str in
  parseSequencedCommand bignumber (build_symtable tokens 0) tokens.

(* ####################################################### *)
(** * Examples *)

(*
Eval compute in parse "
    IF x == y + 1 + 2 - y * 6 + 3 THEN
      x := x * 1;;
      y := 0
    ELSE
      SKIP
    END  ".
====>
    SomeE
       (IFB BEq (AId (Id 0))
                (APlus
                   (AMinus (APlus (APlus (AId (Id 1)) (ANum 1)) (ANum 2))
                      (AMult (AId (Id 1)) (ANum 6)))
                   (ANum 3))
        THEN Id 0 ::= AMult (AId (Id 0)) (ANum 1);; Id 1 ::= ANum 0
        ELSE SKIP FI, [])
*)

(*
Eval compute in parse "
    SKIP;;
    z:=x*y*(x*x);;
    WHILE x==x DO
      IF z <= z*z && not x == 2 THEN
        x := z;;
        y := z
      ELSE
        SKIP
      END;;
      SKIP
    END;;
    x:=z  ".
====>
     SomeE
        (SKIP;;
         Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2)))
                        (AMult (AId (Id 1)) (AId (Id 1)));;
         WHILE BEq (AId (Id 1)) (AId (Id 1)) DO
           IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0))))
                     (BNot (BEq (AId (Id 1)) (ANum 2)))
              THEN Id 1 ::= AId (Id 0);; Id 2 ::= AId (Id 0)
              ELSE SKIP FI;;
           SKIP
         END;;
         Id 1 ::= AId (Id 0),
        [])
*)

(*
Eval compute in parse "
   SKIP;;
   z:=x*y*(x*x);;
   WHILE x==x DO
     IF z <= z*z && not x == 2 THEN
       x := z;;
       y := z
     ELSE
       SKIP
     END;;
     SKIP
   END;;
   x:=z  ".
=====>
      SomeE
         (SKIP;;
          Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2)))
                (AMult (AId (Id 1)) (AId (Id 1)));;
          WHILE BEq (AId (Id 1)) (AId (Id 1)) DO
            IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0))))
                     (BNot (BEq (AId (Id 1)) (ANum 2)))
              THEN Id 1 ::= AId (Id 0);;
                   Id 2 ::= AId (Id 0)
              ELSE SKIP
            FI;;
            SKIP
          END;;
          Id 1 ::= AId (Id 0),
         []).
*)

(** $Date: 2014-12-31 11:17:56 -0500 (Wed, 31 Dec 2014) $ *)


Require Import Coq.Structures.OrderedType.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Vars.

Import Map_TID.
(** * Phaser *)
(** A phaser is a map from tasks to phase numbers. *)

Definition phaser := t nat.

(** Operation advance increments the phase of the given task. *)

Definition advance (ph:phaser) (t:tid) : phaser :=
  match find t ph with
    | Some n => Map_TID.add t (n + 1) ph
    | None => ph
  end.

(** Operation await holds when every member of the phaser has
    reached at least phase [n]. *)

Definition await (ph:phaser) (n:nat) : Prop :=
  forall t n',
  MapsTo t n' ph ->
  n' <= n.

(** Operation [register] assigns a new member in the phaser. *)

Definition register (ph:phaser) (t:tid) (n:nat) : phaser :=
  add t n ph.

(** Operation [deregister] revokes the membership of a task in the phaser. *)

Definition deregister (ph:phaser) (t:tid) : phaser :=
  remove t ph.

(** Operation [phase] looks up the phase associated with a given task,
    or yields [None] if the given task  is unregistered. *)

Definition phase (ph:phaser) (t:tid) : option nat :=
  find t ph.

(** Creates a phaser with a given task initialized at phase [0]. *)

Definition make (t:tid) : phaser :=
  add t 0 (empty nat).

(** Defines the API of a phaser. *)

Inductive op :=
  | ADV : op
  | REG : tid -> op
  | DEREG : op.

(** Applies a phaser operation according to the tag. *)

Definition eval (ph:phaser) (t:tid) (o:op) : phaser :=
  match o with
    | ADV => advance ph t
    | REG t' =>
      match phase ph t with
        | Some n => register ph t' n
        | None => ph
      end
    | DEREG => deregister ph t
  end.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ C D /\ (col_ A B C /\ (col_ A M B /\ col_ C M D))))) -> col_ A M C)).
Proof.
  time tac.
Qed.

End FOFProblem.