Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               rulesb_inf
               Typing_b
               Infrastructure_b
               Infrastructure.

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

Lemma lc_lcb: forall E e t dir A,
 ttyping E e dir A t ->
 lc_exp e ->
 lc_term t.
Proof.
  introv typ H.
  inductions typ; eauto.
  -
    inverts H1.
    pick fresh x.
    forwards*: H.
  - inverts* H.
  - inverts* H.
Qed.

(* Common Lemmas *)
Lemma ttyping_regular_1 : forall e G dir A t,
    ttyping G e dir A t -> lc_exp e.
Proof.
  intros e G dir A t H.
  induction H;
    eauto.
Qed.

Lemma ttyping_regular_2 : forall G e dir T t,
    ttyping G e dir T t -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Lemma ttyping_weaken : forall G E F e dir T t,
    ttyping (E ++ G) e dir T t ->
    uniq (E ++ F ++ G) ->
    ttyping (E ++ F ++ G) e dir T t.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply ttyp_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma ttyping_weakening : forall (E F : ctx) e dir T t,
    ttyping E e dir T t ->
    uniq (F ++ E) ->
    ttyping (F ++ E) e dir T t.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply~ ttyping_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma ttfv_in_dom: forall G e dir T t,
    ttyping G e dir T t -> fv_exp e [<=] dom G.
Proof.
  intros G e dir T t H.
  induction H; simpl; try fsetdec.
  - Case "typing_var".
    apply binds_In in H0.
    fsetdec.
  - Case "typing_abs".
    pick fresh x.
    assert (Fx : fv_exp (open_exp_wrt_exp e (e_var_f x)) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (open_exp_wrt_exp e (e_var_f x))) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma ttvalue_no_fv : forall v dir T t,
    ttyping [] v dir T t -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (ttfv_in_dom [] v).
  intuition eauto.
Qed.

Lemma ttsubst_value : forall v dir T t z u,
    ttyping [] v dir T t -> subst_exp u z v = v.
Proof.
  intros v dir T t z u Typ.
  lets* Fv: ttvalue_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma ttyping_subst_1 : forall (E F : ctx) e u uu dir S T (z : atom) t,
    ttyping (F ++ [(z,S)] ++ E) e dir T t ->
    ttyping E u Inf S uu ->
    ttyping (F ++ E) ([z ~> u] e) dir T ([z ~> uu]' t).
Proof.
  intros.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  induction H; intros F Eq; subst; simpl; autos*;
    lets Lc  : ttyping_regular_1 H0;
    lets Uni : ttyping_regular_2 H0.
  -
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    apply~ ttyping_weakening.
    solve_uniq.
  -
    pick fresh x and apply ttyp_abs; eauto.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite subst_term_open_term_wrt_term_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
    forwards*: lc_lcb H0.
Qed.

Lemma ttyping_c_subst_simpl : forall E e u uu t dir S T z,
  ttyping ([(z,S)] ++ E) e dir T t ->
  ttyping E u Inf S uu ->
  ttyping E ([z ~> u] e) dir T ([z ~> uu]' t).
Proof.
  intros E e u uu t dir S T z H1 H2.
  rewrite_env (nil ++ E).
  eapply ttyping_subst_1.
    simpl_env. apply H1.
    apply H2.
Qed.

Lemma ttinference_unique : forall G e t A1 A2,
    ttyping G e Inf A1 t ->
    ttyping G e Inf A2 t->
    A1 = A2.
Proof.
  introv Ty1.
  gen A2.
  inductions Ty1; introv Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H5.
    inverts* H.
Qed.

Lemma elaboration_soundness : forall G e t dir A,
    ttyping G e dir A t ->
    Btyping G t A.
Proof.
  introv Ty1.
  inductions Ty1; intros; eauto.
Qed.


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

(* Why3 assumption *)
Inductive t :=
  | T : t.
Axiom t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 assumption *)
Inductive x (a:Type) (b:Type) :=
  | X : t -> a -> x a b
  | Y : t -> b -> x a b.
Axiom x_WhyType : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b},
  WhyType (x a b).
Existing Instance x_WhyType.
Implicit Arguments X [[a] [b]].
Implicit Arguments Y [[a] [b]].

(* Why3 assumption *)
Inductive a1 :=
  | A0 : a1
  | A1 : a1.
Axiom a1_WhyType : WhyType a1.
Existing Instance a1_WhyType.

(* Why3 assumption *)
Inductive b :=
  | B : b.
Axiom b_WhyType : WhyType b.
Existing Instance b_WhyType.

(* Why3 goal *)
Theorem x1 : ((X T A0: (x a1 b)) = (X T A1: (x a1 b))).
(* YOU MAY EDIT THE PROOF BELOW *)
admit.
Admitted.


From BF Require Import Base Byte VM Token AST.

Inductive comir : Type :=
  | CRight (n : positive) (c : comir)
  | CLeft (n : positive) (c : comir)
  | CAdd (n : byte) (c : comir)
  | COutput (c : comir)
  | CInput (c : comir)
  | CLoop (body : comir) (c : comir)
  | CEnd.

Inductive execute : comir -> vm -> vm -> Prop :=
  | E_CRight n c v v'' :
      execute c (VM.move_right n v) v'' ->
      execute (CRight n c) v v''
  | E_CLeft n c v v' v'' :
      VM.move_left n (Some v) = Some v' ->
      execute c v' v'' ->
      execute (CLeft n c) v v''
  | E_CAdd n c v v'' :
      execute c (VM.add_cell n v) v'' ->
      execute (CAdd n c) v v''
  | E_COutput c v v'' :
      execute c (VM.output v) v'' ->
      execute (COutput c) v v''
  | E_CInput c v v' v'' :
      VM.input v = Some v' ->
      execute c v' v'' ->
      execute (CInput c) v v''
  | E_CLoop body c v v' v'' :
      v.(cell) =? #00 = false ->
      execute body v v' ->
      execute (CLoop body c) v' v'' ->
      execute (CLoop body c) v v''
  | E_CLoop_0 body c v v' :
      v.(cell) =? #00 = true ->
      execute c v v' ->
      execute (CLoop body c) v v'
  | E_CEnd v v' :
      VM.eq v v' = true ->
      execute CEnd v v'.

Definition equiv (i1 i2 : comir) : Prop := forall v v',
  execute i1 v v' <-> execute i2 v v'.

Definition transform_sound (trans : comir -> comir) : Prop := forall c,
  equiv c (trans c).

Fixpoint cons_right (n : positive) (c : comir) : comir :=
  match c with
  | CRight m c' => CRight (n + m) c'
  | CLeft m c' => match n ?= m with
                  | Eq => c'
                  | Lt => CLeft (m - n) c'
                  | Gt => cons_right (n - m) c'
                  end
  | _ => CRight n c
  end%positive.

Definition cons_left (n : positive) (c : comir) : comir :=
  match c with
  | CLeft m c' => CLeft (n + m) c'
  | _ => CLeft n c
  end.

Definition cons_add (n : byte) (c : comir) : comir :=
  match c with
  | CAdd m c' => CAdd (n + m) c'
  | _ => CAdd n c
  end.

Fixpoint lower_ast (a : ast) : comir :=
  match a with
  | ARight a' => CRight 1 (lower_ast a')
  | ALeft a' => CLeft 1 (lower_ast a')
  | AInc a' => CAdd #01 (lower_ast a')
  | ADec a' => CAdd #ff (lower_ast a')
  | AOutput a' => COutput (lower_ast a')
  | AInput a' => CInput (lower_ast a')
  | ALoop body a' => CLoop (lower_ast body) (lower_ast a')
  | AEnd => CEnd
  end.

Fixpoint raise_ast (c : comir) : ast :=
  match c with
  | CRight n c' => AST.cons_right n (raise_ast c')
  | CLeft n c' => AST.cons_left n (raise_ast c')
  | CAdd n c' => AST.cons_add n (raise_ast c')
  | COutput c' => AOutput (raise_ast c')
  | CInput c' => AInput (raise_ast c')
  | CLoop body c' => ALoop (raise_ast body) (raise_ast c')
  | CEnd => AEnd
  end.

Fixpoint combine (c : comir) : comir :=
  match c with
  | CRight n c' => cons_right n (combine c')
  | CLeft n c' => cons_left n (combine c')
  | CAdd n c' => cons_add n (combine c')
  | COutput c' => COutput (combine c')
  | CInput c' => CInput (combine c')
  | CLoop body c' => CLoop (combine body) (combine c')
  | CEnd => CEnd
  end.

Example test_execute : forall a,
  parse (lex ",>+++[-<++>]<-.") = Some a ->
  execute (lower_ast a) (VM.make [#02]) (VM [] #07 [] [#07] [] VM.norm_nil).
Proof.
  intros. inversion H; subst; clear H.
  repeat (apply E_CRight
       || (eapply E_CLeft; [reflexivity |])
       || apply E_CAdd
       || apply E_COutput
       || (eapply E_CInput; [reflexivity |])
       || (eapply E_CLoop; [reflexivity | |])
       || (eapply E_CLoop_0; [reflexivity |])
       || (apply E_CEnd; apply VM.eq_refl)).
  apply E_CEnd. reflexivity.
Qed.

Theorem lower_ast_sound : forall a v v',
  AST.execute a v v' <-> execute (lower_ast a) v v'.
Proof.
  split.
  - intros. induction H; cbn; econstructor; eassumption.
  - generalize dependent v'; generalize dependent v.
    induction a; cbn; intros;
    try (inversion H; subst; econstructor; try apply IHa; eassumption).
    dependent induction H.
    + eapply E_ALoop. assumption. apply IHa1. eassumption.
      apply IHexecute2. apply IHa2. apply IHa1. reflexivity.
    + apply E_ALoop_0, IHa2; assumption.
Qed.

Ltac destruct_compare n m :=
  destruct (n ?= m)%positive eqn:Hcomp;
  [rewrite Pos.compare_eq_iff in Hcomp; subst
  | rewrite Pos.compare_lt_iff in Hcomp
  | rewrite Pos.compare_gt_iff in Hcomp].

Theorem cons_right_correct : forall c n v v',
  execute (cons_right n c) v v' <-> execute (CRight n c) v v'.
Proof.
  split;
  generalize dependent v'; generalize dependent v; generalize dependent n.
  - induction c; cbn; intros; try assumption.
    + inversion H; subst.
      apply E_CRight, E_CRight. rewrite VM.move_right_add. assumption.
    + destruct_compare n0 n.
      * eapply E_CRight, E_CLeft. apply VM.move_right_left_refl. assumption.
      * inversion H; subst.
        eapply E_CRight, E_CLeft. rewrite VM.move_right_left_lt.
        eassumption. apply Hcomp. assumption.
      * apply IHc in H. inversion H; subst.
        eapply E_CRight, E_CLeft. apply VM.move_right_left_gt.
        apply Hcomp. assumption.
  - induction c; cbn; intros; try assumption;
    inversion H; inversion H4; subst.
    + rewrite VM.move_right_add in H9.
      apply E_CRight. assumption.
    + destruct_compare n0 n.
      * rewrite VM.move_right_left_refl in H7. inversion H7; subst. assumption.
      * rewrite VM.move_right_left_lt in H7.
        eapply E_CLeft. eassumption. assumption. apply Hcomp.
      * rewrite VM.move_right_left_gt in H7. inversion H7; subst.
        apply IHc. apply E_CRight. assumption. assumption.
Qed.

Theorem cons_left_correct : forall c n v v',
  execute (cons_left n c) v v' <-> execute (CLeft n c) v v'.
Proof.
  split;
  generalize dependent v'; generalize dependent v; generalize dependent n.
  - destruct c; cbn; intros; try assumption.
    inversion H; subst.
    rewrite Pos.add_comm, <- VM.move_left_add in H2.
    apply VM.move_left_split in H2 as [v'1 []].
    eapply E_CLeft, E_CLeft; eassumption.
  - destruct c; cbn; intros; try assumption.
    inversion H; inversion H5; subst.
    rewrite Pos.add_comm. eapply E_CLeft. rewrite <- VM.move_left_add.
    rewrite H2. eassumption. assumption.
Qed.

Theorem cons_add_correct : forall c n v v',
  execute (cons_add n c) v v' <-> execute (CAdd n c) v v'.
Proof.
  split.
  - destruct c; cbn; intros; try assumption.
    inversion H; subst.
    apply E_CAdd, E_CAdd. rewrite VM.add_add. assumption.
  - destruct c; cbn; intros; try assumption.
    inversion H; inversion H4; subst.
    apply E_CAdd. rewrite <- VM.add_add. assumption.
Qed.

Theorem combine_sound :
  transform_sound combine.
Proof.
  unfold transform_sound, equiv.
  split.
  - intros. induction H; cbn;
    try (econstructor; eassumption).
    + rewrite cons_right_correct. apply E_CRight. assumption.
    + rewrite cons_left_correct. eapply E_CLeft; eassumption.
    + rewrite cons_add_correct. apply E_CAdd. assumption.
  - generalize dependent v'; generalize dependent v.
    induction c; intros; cbn in *.
    + rewrite cons_right_correct in H. inversion H; subst.
      apply E_CRight, IHc. assumption.
    + rewrite cons_left_correct in H. inversion H; subst.
      eapply E_CLeft. eassumption. apply IHc. assumption.
    + rewrite cons_add_correct in H. inversion H; subst.
      apply E_CAdd, IHc. assumption.
    + inversion H; subst. constructor. apply IHc. assumption.
    + inversion H; subst. econstructor. eassumption. apply IHc. assumption.
    + dependent induction H.
      * eapply E_CLoop. assumption. apply IHc1. eassumption.
        apply IHexecute2; try assumption. reflexivity.
      * apply E_CLoop_0, IHc2; assumption.
    + assumption.
Qed.

Theorem lower_ast_combine_sound : forall a v v',
  AST.execute a v v' -> execute (combine (lower_ast a)) v v'.
Proof.
  intros. apply lower_ast_sound, combine_sound in H. assumption.
Qed.


Require Import Util LengthEq AllInRel Map Envs IL AutoIndTac MoreList.
Require Export DecSolve BlockType.

Set Implicit Arguments.
Inductive mutual_block {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
: nat -> list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C -> Prop :=
  | CS_nil n : mutual_block R n nil nil nil nil nil nil
  | CS_cons a1 a2 a3 a4 b c n AL1 AL2 AL3 AL4 L L' :
      mutual_block R (S n) AL1 AL2 AL3 AL4 L L'
      -> n = block_n b
      -> n = block_n c
      -> R a1 a2 a3 a4 b c
      -> mutual_block R n (a1::AL1) (a2::AL2) (a3::AL3) (a4::AL4) (b::L) (c::L').

Lemma mutual_block_zero {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b i
: mutual_block R i AL1 AL2 AL3 AL4 L L' -> get L n b -> block_n b = (n+i).
Proof.
  intros. general induction H2. inv H1; eauto.
  inv H1; eauto. erewrite IHget; eauto. omega.
Qed.

Lemma mutual_block_length {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L1:list B) (L2:list C) i
: mutual_block R i AL1 AL2 AL3 AL4 L1 L2 -> ❬AL1❭ = ❬L1❭ /\ ❬AL2❭ = ❬L1❭ /\ ❬AL3❭ = ❬L1❭  /\ ❬AL4❭ = ❬L1❭ /\ ❬L2❭ = ❬L1❭.
Proof.
  intros. general induction H1; dcr; simpl; eauto.
  repeat split; omega.
Qed.

Lemma mutual_block_get {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L1:list B) (L2:list C) i n b
: mutual_block R i AL1 AL2 AL3 AL4 L1 L2 -> get L1 n b ->
  exists a1 a2 a3 a4 c, get AL1 n a1 /\ get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4
                   /\ get L2 n c /\ R a1 a2 a3 a4 b c.
Proof.
  intros. general induction H2; inv H1; eauto 20 using get.
  edestruct IHget; dcr; eauto 20 using get.
Qed.

Lemma mutual_block_get_A1 {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L1:list B) (L2:list C) i n a1
: mutual_block R i AL1 AL2 AL3 AL4 L1 L2 -> get AL1 n a1 ->
  exists a2 a3 a4 b c, get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4 /\
                   get L1 n b /\ get L2 n c /\ R a1 a2 a3 a4 b c.
Proof.
  intros. general induction H2; inv H1; eauto 20 using get.
  edestruct IHget; dcr; eauto 20 using get.
Qed.

Lemma mutual_approx k {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 AL1' AL2' AL3' AL4' F1 F2 L1 L2
  : length AL1' = length F1
    -> length AL1' = length AL2'
    -> length AL2' = length AL3'
    -> length AL3' = length AL4'
    -> length F1 = length F2
    -> (forall n a1 a2 a3 a4 b b', get AL1' n a1 -> get AL2' n a2 -> get AL3' n a3 -> get AL4' n a4
                             -> get F1 n b -> get F2 n b' -> R AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b b')
    -> (forall i b, get F1 i b -> k + i = block_n b)
    -> (forall i b, get F2 i b -> k + i = block_n b)
    -> mutual_block (R AL1 AL2 AL3 AL4 L1 L2) k AL1' AL2' AL3' AL4' F1 F2.
Proof.
  intros. length_equify.
  general induction H1; eauto using @mutual_block.
  econstructor; eauto using get. eapply IHlength_eq; eauto 20 using get.
  intros. exploit H7. econstructor 2. eauto. omega.
  intros. exploit H8. econstructor 2. eauto. omega.
  exploit H7; eauto using get. omega.
  exploit H8; eauto using get. omega.
Qed.

Inductive inRel {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
          (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
             A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
: list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C -> Prop :=
  | LPM_nil : inRel R nil nil nil nil nil nil
  | LPM_app AL1 AL2 AL3 AL4 AL1' AL2' AL3' AL4' L1 L2 L1' L2' :
      inRel R AL1 AL2 AL3 AL4 L1 L2
      -> mutual_block (R (AL1'++AL1) (AL2'++AL2) (AL3'++AL3) (AL4'++AL4) (L1'++L1) (L2'++L2))
                     0 AL1' AL2' AL3' AL4' L1' L2'
      -> inRel R (AL1'++AL1) (AL2'++AL2) (AL3'++AL3) (AL4'++AL4) (L1'++L1) (L2'++L2).
Lemma inRel_less {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b
: inRel R AL1 AL2 AL3 AL4 L L' -> get L n b -> block_n b <= n.
Proof.
  intros. general induction H1.
  eapply get_app_cases in H3; destruct H3; dcr.
  erewrite mutual_block_zero; eauto. omega.
  rewrite IHinRel; try eapply H4. omega.
Qed.

Lemma inRel_drop {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b
: inRel R AL1 AL2 AL3 AL4 L L'
  -> get L n b
  -> inRel R
          (drop (n - block_n b) AL1)
          (drop (n - block_n b) AL2)
          (drop (n - block_n b) AL3)
          (drop (n - block_n b) AL4)
          (drop (n - block_n b) L)
          (drop (n - block_n b) L').
Proof.
  intros. general induction H1; simpl; eauto; isabsurd.
  - eapply get_app_cases in H3; destruct H3; dcr.
    + exploit (mutual_block_zero H2 H3); eauto.
      rewrite H4. orewrite (n - (n + 0)= 0). simpl; econstructor; eauto.
    + exploit (inRel_less H1 H4); eauto.
      exploit (mutual_block_length H2); dcr.
      specialize (IHinRel _ _ H4).
      repeat (rewrite drop_app_gen; [| omega]).
      assert (REO:forall m, block_n b <= n - ❬L1'❭ -> m = ❬L1'❭
                       -> n - block_n b - m = n - ❬L1'❭ - block_n b). {
        intros. omega.
      }
      repeat (rewrite REO; eauto).
Qed.

Lemma inRel_nth {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b
: inRel R AL1 AL2 AL3 AL4 L L' -> get L n b ->
  exists a1:A1, exists a2:A2, exists a3:A3, exists a4:A4, exists c:C,
            get AL1 n a1 /\ get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4 /\ get L' n c
            /\ R (drop (n - block_n b) AL1) (drop (n - block_n b) AL2) (drop (n - block_n b) AL3) (drop (n - block_n b) AL4) (drop (n - block_n b) L) (drop (n - block_n b) L') a1 a2 a3 a4 b c.
Proof.
  intros. general induction H1; isabsurd.
  eapply get_app_cases in H3; destruct H3; dcr.
  - exploit (mutual_block_zero H2 H3); eauto. rewrite H4.
    orewrite (n - (n + 0) = 0). simpl.
    edestruct (mutual_block_get H2 H3); dcr.
    eauto 20 using get_app, get.
  - edestruct IHinRel; eauto; dcr.
    pose proof (mutual_block_length H2); dcr.
    do 5 eexists.
    repeat split; try (eapply get_app_right; [ | eauto ]; omega).
    exploit (inRel_less H1 H4); eauto.
    repeat (rewrite drop_app_gen; [| omega]).
    assert (REO:forall m, block_n b <= n - ❬L1'❭ -> m = ❬L1'❭
                     -> n - block_n b - m = n - ❬L1'❭ - block_n b). {
      intros. omega.
    }
    repeat (rewrite REO; eauto).
Qed.

Lemma inRel_nth_A1 {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n a1
: inRel R AL1 AL2 AL3 AL4 L L' -> get AL1 n a1 ->
  exists a2:A2, exists a3:A3, exists a4:A4, exists b:B, exists c:C,
            get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4 /\ get L n b /\ get L' n c
            /\ R (drop (n - block_n b) AL1) (drop (n - block_n b) AL2) (drop (n - block_n b) AL3) (drop (n - block_n b) AL4) (drop (n - block_n b) L) (drop (n - block_n b) L') a1 a2 a3 a4 b c.
Proof.
  intros. general induction H1; isabsurd.
  eapply get_app_cases in H3; destruct H3; dcr.
  - edestruct (mutual_block_get_A1 H2 H3); dcr.
    exploit (mutual_block_zero H2 H8); eauto.
    eexists x, x0, x1, x2, x3.
    rewrite H4.
    orewrite (n - (n + 0) = 0). simpl.
    eauto 20 using get_app, get.
  - edestruct IHinRel; eauto; dcr.
    pose proof (mutual_block_length H2); dcr.
    do 5 eexists.
    repeat split; try (eapply get_app_right; [ | eauto ]; omega).
    exploit (inRel_less H1 H9); eauto.
    repeat (rewrite drop_app_gen; [| omega]).
    assert (REO:forall m, block_n x2 <= n - ❬AL1'❭ -> m = ❬AL1'❭
                     -> n - block_n x2 - m = n - ❬AL1'❭ - block_n x2). {
      intros. omega.
    }
    repeat (rewrite REO; eauto); try congruence.
Qed.

Tactic Notation "inRel_invs" :=
  match goal with
  | [ H : inRel ?R ?A1 ?A2 ?A3 ?A4 ?B ?C, H' : get ?A1 ?n ?b |- _ ] =>
    let InR := fresh "InR" in
    let G := fresh "G" in
    let GetL := fresh "GetL" in
    edestruct (inRel_nth_A1 H H') as [? [? [? [? [? [? [? [? [GetL [? ]]]]] ]]]]];
    let X'' := fresh "H" in
    pose proof (inRel_drop H GetL) as X'';
    repeat get_functional
  end.

Lemma mutual_block_map_A3 {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1' AL1 AL2' AL2 AL3' AL3 AL4' AL4 L1' L1 L2' L2 n (f: A3 -> A3)
      (Rf: forall AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2,
          R AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2 ->
          R AL1 AL2 (f ⊝ AL3) AL4 L1 L2 a1 a2 (f a3) a4 b1 b2 )
  : mutual_block
      (R AL1 AL2 AL3 AL4 L1 L2) n AL1' AL2' AL3' AL4' L1' L2'
    -> mutual_block (R AL1 AL2 (f ⊝ AL3) AL4 L1 L2) n AL1' AL2' (f ⊝ AL3') AL4' L1' L2'.
Proof.
  intros. general induction H1; eauto using @mutual_block.
  simpl. econstructor; eauto.
Qed.

Lemma inRel_map_A3 {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 L1 L2 (f: A3 -> A3)
      (Rf: forall AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2,
          R AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2 ->
          R AL1 AL2 (f ⊝ AL3) AL4 L1 L2 a1 a2 (f a3) a4 b1 b2 )
  : inRel R AL1 AL2 AL3 AL4 L1 L2
    -> inRel R AL1 AL2 (f ⊝ AL3) AL4 L1 L2.
Proof.
  intros IR.
  general induction IR; simpl in *; eauto using @inRel.
  - rewrite List.map_app. econstructor; eauto.
    rewrite <- List.map_app.
    eapply mutual_block_map_A3; eauto.
Qed.

Lemma inRel_length  {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 L1 L2
  : inRel R AL1 AL2 AL3 AL4 L1 L2 -> length AL1 = length AL2 /\ length AL2 = length AL3
                                   /\ length AL3 = length AL4 /\ length L1 = length L2.
Proof.
  intros. general induction H1; dcr; simpl; eauto.
  repeat rewrite app_length.
  exploit (mutual_block_length H2); eauto; dcr; omega.
Qed.


Lemma extends_get':
  forall A (E E' : env A),
    extends E E' ->
    forall x v,
      get x E  = Some v ->
      get x E' = Some v.
Proof.
  intros.
  unfold extends, binds in H.
  induction E'; auto.
Qed.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* Peter Aczel's Encoding of CZF *)

(* Using the same definition "Ens" of sets, we can developp Peter Aczel's   *)
(* encoding of "Constructive Type Theory" (CZF).                            *)
(* It is basically a simillar developement, but this time, the propositions *)
(* are objects of type "Type", i.e. are on the same level (resp. above) the *)
(* sets. The advantage is that we can extract the constructive witness of an*)
(* existential proof. The drawbacks are:                                    *)
(*  - no definition of the powerset                                         *)
(*  - complicated difference between bounded and unbounded quantification   *)
(*  - excluded middle is now much more "dangerous"                          *)

Require Import Sets.
Require Import Axioms.

Definition EQC : Ens -> Ens -> Type.
simple induction 1; intros A f eq1.
simple induction 1; intros B g eq2.
refine (prod_t _ _).
exact (forall x : A, depprod _ (fun y : B => eq1 x (g y))).
exact (forall y : B, depprod _ (fun x : A => eq1 x (g y))).
Defined.

(* APPARTENANCE *)

Definition CIN : Ens -> Ens -> Type.
simple induction 2.
intros.
exact (depprod _ (fun y : A => EQC X (e y))).
Defined.

(* INCLUSION *)

Definition CINC : Ens -> Ens -> Type.
intros E1 E2.
exact (forall E : Ens, CIN E E1 -> CIN E E2).
Defined.

(* EQ EST UNE RELATION D'EQUIVALENCE *)

Theorem EQC_refl : forall E : Ens, EQC E E.
simple induction E.
intros A f HR.
simpl in |- *.
split; intros.
exists x; auto with zfc.

exists y; auto with zfc.
Qed.

Theorem EQC_tran : forall E1 E2 E3 : Ens, EQC E1 E2 -> EQC E2 E3 -> EQC E1 E3.
simple induction E1; simple induction E2; simple induction E3; simpl in |- *;
 intros.
split; (elim X2; intros; elim X3; intros).
elim (a x); intros.
elim (a0 x0); intros.
exists x1.
apply X with (e0 x0); auto with zfc.
elim (b0 y); intros.
elim (b x); intros.
exists x0.
apply X with (e0 x); auto with zfc.
Qed.

Theorem EQC_sym : forall E1 E2 : Ens, EQC E1 E2 -> EQC E2 E1.
simple induction E1; simple induction E2; simpl in |- *; intros.
elim X1; intros; split; intros.
elim (b x); intros.
exists x0; auto with zfc.
elim (a y); intros; exists x; auto with zfc.
Qed.

Theorem EQC_INC : forall E E' : Ens, EQC E E' -> CINC E E'.
simple induction E; simple induction E'; simpl in |- *; intros;
 unfold CINC in |- *; simpl in |- *.
elim X1; intros.
elim X2; intros.
elim (a x); intros.
exists x0; apply EQC_tran with (e x); auto with zfc.
Qed.

Hint Resolve EQC_sym EQC_refl EQC_INC: zfc.

Theorem CINC_EQC : forall E E' : Ens, CINC E E' -> CINC E' E -> EQC E E'.
simple induction E; simple induction E'; unfold CINC in |- *; simpl in |- *;
 intros; split; intros.
apply X1.
exists x; auto with zfc.
cut (depprod A (fun x : A => EQC (e0 y) (e x)));
 try (simple induction 1; intros x p; exists x; auto with zfc).
apply X2; exists y; auto with zfc.
Qed.

Hint Resolve CINC_EQC: zfc.

Theorem CIN_sound_left :
 forall E E' E'' : Ens, EQC E E' -> CIN E E'' -> CIN E' E''.
simple induction E''; simpl in |- *; intros.
elim X1; intros y p; exists y.
apply EQC_tran with E; auto with zfc.
Qed.

Theorem CIN_sound_right :
 forall E E' E'' : Ens, EQC E' E'' -> CIN E E' -> CIN E E''.
simple induction E'; simple induction E''; simpl in |- *; intros.
elim X1; intros Xl Xr; elim X2; intros y p; elim (Xl y); intros y0 p0;
 exists y0; apply EQC_tran with (e y); auto with zfc.
Qed.

Theorem CINC_refl : forall E : Ens, CINC E E.
unfold CINC in |- *; auto with zfc.
Qed.

Theorem CINC_tran :
 forall E E' E'' : Ens, CINC E E' -> CINC E' E'' -> CINC E E''.
unfold CINC in |- *; auto with zfc.
Qed.

Theorem CINC_sound_left :
 forall E E' E'' : Ens, EQC E E' -> CINC E E'' -> CINC E' E''.
simple induction E''; unfold CINC in |- *; simpl in |- *;
 intros A f XR e X1 E0 i; apply X1.
apply CIN_sound_right with E'; auto with zfc.
Qed.

Theorem CINC_sound_right :
 forall E E' E'' : Ens, EQC E' E'' -> CINC E E' -> CINC E E''.
simple induction E'; simple induction E''; unfold CINC in |- *; simpl in |- *;
 intros.
elim (X2 E0); try assumption; intros.
elim X1; intros XA XB; elim (XA x); intros.
exists x0; apply EQC_tran with (e x); auto with zfc.
Qed.

Theorem tout_vide_est_VideC :
 forall E : Ens, (forall E' : Ens, CIN E' E -> F) -> EQC E Vide.
 unfold Vide in |- *; simple induction E; simpl in |- *; intros A e X H;
  split.
intros; elim (H (e x)); auto with zfc.
exists x; auto with zfc.
simple induction y.
Qed.

Theorem Paire_sound_leftC :
 forall A A' B : Ens, EQC A A' -> EQC (Paire A B) (Paire A' B).
unfold Paire in |- *.
simpl in |- *.
intros; split.
simple induction x.
exists true; auto with zfc.

exists false; auto with zfc.

simple induction y; simpl in |- *.
exists true; auto with zfc.

exists false; auto with zfc.
Qed.

Theorem Paire_sound_rightC :
 forall A B B' : Ens, EQC B B' -> EQC (Paire A B) (Paire A B').
unfold Paire in |- *; simpl in |- *; intros; split.
simple induction x.
exists true; auto with zfc.
exists false; auto with zfc.
simple induction y.
exists true; auto with zfc.
exists false; auto with zfc.
Qed.

Theorem CIN_Paire_left : forall E E' : Ens, CIN E (Paire E E').
unfold Paire in |- *; simpl in |- *; exists true; simpl in |- *;
 auto with zfc.
Qed.

Theorem CIN_Paire_right : forall E E' : Ens, CIN E' (Paire E E').
unfold Paire in |- *; simpl in |- *; exists false; simpl in |- *;
 auto with zfc.
Qed.

Inductive sum_t (A B : Type) : Type :=
  | inl_t : A -> sum_t A B
  | inr_t : B -> sum_t A B.
Hint Resolve inl_t inr_t: zfc.

Theorem Paire_CIN :
 forall E E' A : Ens, CIN A (Paire E E') -> sum_t (EQC A E) (EQC A E').
unfold Paire in |- *; simpl in |- *; simple induction 1; intros b; elim b;
 simpl in |- *; auto with zfc.
Qed.

Hint Resolve CIN_Paire_left CIN_Paire_right: zfc.

(* Singleton *)

Theorem CIN_Sing : forall E : Ens, CIN E (Sing E).
unfold Sing in |- *; auto with zfc.
Qed.

Theorem CIN_Sing_EQ : forall E E' : Ens, CIN E (Sing E') -> EQC E E'.
unfold Sing in |- *; intros E E' H; elim (Paire_CIN E' E' E);
 auto with zfc.
Qed.

Theorem EQC_EQ : forall E E' : Ens, EQC E E' -> EQ E E'.
simple induction E; intros A f ra; simple induction E'; intros B g rb;
 simpl in |- *; simple induction 1; intros H1 H2; split.
intros a; elim (H1 a); intros b; intros; exists b; auto with zfc.
intros b; elim (H2 b); intros a; intros; exists a; auto with zfc.
Qed.

Theorem CIN_IN : forall E E' : Ens, CIN E E' -> IN E E'.
simple induction E; intros A f ra; simple induction E'; intros B g rb;
 simple induction 1; intros a; unfold IN in |- *; exists a;
 auto with zfc.
apply EQC_EQ; auto with zfc.
Qed.

Theorem EQC_EXType :
 forall E E' : Ens,
 EQC E E' ->
 forall a : pi1 E,
 depprod (pi1 E') (fun b : pi1 E' => EQC (pi2 E a) (pi2 E' b)).
simple induction E; simple induction E'; simpl in |- *.
intros.
elim X1; intros.
elim (a0 a); intros.
exists x; auto with zfc.

Defined.

Theorem CIN_EXType :
 forall E E' : Ens,
 CIN E' E -> depprod (pi1 E) (fun a : pi1 E => EQC E' (pi2 E a)).
simple induction E; simpl in |- *.
intros A f r.
simple induction 1; simpl in |- *.
intros.
exists x; auto with zfc.
Qed.

Theorem CIN_Union :
 forall E E' E'' : Ens, CIN E' E -> CIN E'' E' -> CIN E'' (Union E).

simple induction E; intros A f r.
intros.
simpl in |- *.
elim (CIN_EXType (sup A f) E' X).
intros x e.
cut (EQC (pi2 (sup A f) x) E'); auto with zfc.
intros e1.
cut (CIN E'' (pi2 (sup A f) x)).
intros i1.
elim (CIN_EXType _ _ i1).
intros x0 e2.
simpl in x0.
exists (dep_i A (fun x : A => pi1 (f x)) x x0).
simpl in |- *.
exact e2.
apply CIN_sound_right with E'; auto with zfc.
Qed.

Theorem CIN_CINC_Union : forall E E' : Ens, CIN E' E -> CINC E' (Union E).
unfold CINC in |- *; simple induction E; intros A f r.
unfold Union in |- *.
intros.
simpl in |- *.
elim (CIN_EXType (sup A f) E' X).
intro.
simpl in x.
intros.
simpl in p.
elim (CIN_EXType E' E0 X0).
cut (CIN E0 (f x)).
intros.
elim (CIN_EXType _ _ X1).
simpl in |- *.
intros.
exists (dep_i A (fun x : A => pi1 (f x)) x x1); auto with zfc.

apply CIN_sound_right with E'; auto with zfc.
Qed.

(* idem depprod *)

Inductive depprod' (A : Type) (P : A -> Type) : Type :=
    dep_i' : forall x : A, P x -> depprod' A P.

Theorem Union_CIN :
 forall E E' : Ens,
 CIN E' (Union E) ->
 depprod' _ (fun E1 : Ens => prod_t (CIN E1 E) (CIN E' E1)).
simple induction E; unfold Union in |- *; simpl in |- *; intros A f r.
simple induction 1.
simple induction x.
intros a b; simpl in |- *.
intros.
exists (f a).
split.
exists a; auto with zfc.

apply CIN_sound_left with (pi2 (f a) b); auto with zfc.
simpl in |- *.
generalize b; elim (f a); simpl in |- *.
intros.
exists b0; auto with zfc.
Qed.

Theorem Union_soundC :
 forall E E' : Ens, EQC E E' -> EQC (Union E) (Union E').
unfold Union in |- *.
simpl in |- *.
simple induction E; intros A f r; simple induction E'; intros A' f' r'.
simpl in |- *.
intros.
elim X; intros.
split.
simple induction x.
intros.
elim (a x0).
intros.
elim (EQC_EXType (f x0) (f' x1) p0 p).
intros.
exists (dep_i A' (fun x : A' => pi1 (f' x)) x1 x2).
simpl in |- *.
auto with zfc.

simple induction y; intros.
elim (b x); intros.
cut (EQC (f' x) (f x0)); auto with zfc.
intros e.
elim (EQC_EXType (f' x) (f x0) e p); intros.
exists (dep_i A (fun x0 : A => pi1 (f x0)) x0 x1).
simpl in |- *; auto with zfc.
Qed.

Theorem Union_monC :
 forall E E' : Ens, CINC E E' -> CINC (Union E) (Union E').
unfold CINC in |- *; intros.
elim (Union_CIN E E0 X0); intros.
apply CIN_Union with x; elim p; intros; auto with zfc.
Qed.

(* surprinsingly, the predicative and impredicative definitions of the   *)
(* intersection do not seem equivalent.                                  *)
(* to be checked...                                                      *)


(* To install ITree, do:
     opam install coq-itree *)
From ITree Require Import
     ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From Paco Require Import paco.

Require Import Coq.Program.Basics.
Require Import Nat.
Require Import PeanoNat.
Require Import Coq.Logic.Eqdep_dec.
Require Import RelationClasses.
Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.Morphisms.
Require Import List.
Import ListNotations.

Local Open Scope equiv_scope.
Local Open Scope program_scope.

Require Import misc.
Require Import regular.
Require Import semiring.
Require Import tree.

Variant unbiasedE : Type -> Type :=
| GetUnbiased : unbiasedE bool.

Section itree_all.
  Context {A : Type} {E : Type -> Type} (P : A -> Prop).

  Inductive itree_allF (R : itree E A -> Prop) : itree' E A -> Prop :=
  | itree_allF_ret : forall x, P x -> itree_allF R (RetF x)
  | itree_allF_tau : forall t, R t -> itree_allF R (TauF t)
  | itree_allF_vis : forall {A} (e : E A) f,
      (forall x, R (f x)) ->
      itree_allF R (VisF e f).

  Definition itree_all_ R : itree E A -> Prop :=
    fun t => itree_allF R (observe t).

  Lemma itree_allF_mono R R' t
        (IN: itree_allF R t)
        (LE: R <1= R') :
    itree_allF R' t.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_all__mono : monotone1 (itree_all_).
  Proof. do 2 red. intros. eapply itree_allF_mono; eauto. Qed.
  Hint Resolve itree_all__mono : paco.

  Definition itree_all : itree E A -> Prop :=
    paco1 itree_all_ bot1.

  Lemma itree_allF_impl (t : itree' E A) (Q1 Q2 : itree E A -> Prop) :
    (forall t, Q1 t -> Q2 t) ->
    itree_allF Q1 t -> itree_allF Q2 t.
  Proof.
    intros H0 H1.
    destruct t; inversion H1; subst; constructor; auto.
    apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H4; subst; auto.
  Qed.

  Lemma itree_all_impl (t : itree E A) (Q1 Q2 : itree E A -> Prop) :
    (forall t, Q1 t -> Q2 t) ->
    paco1 itree_all_ Q1 t -> paco1 itree_all_ Q2 t.
  Proof.
    revert t.
    pcofix CH.
    intros t H0 H1.
    punfold H1; pstep.
    eapply itree_allF_impl.
    2: { apply H1. }
    intros t' [H2 | H2].
    - right; apply CH; auto.
    - right; auto.
  Qed.

  (* Lemma itree_allF_all_ {t : itree E A} r : *)
  (*   itree_allF r (observe t) <-> itree_all_ r t. *)
  (* Proof. firstorder. Qed. *)

  (* Global Instance Proper_itree_all' r *)
  (*   : Proper (eq_itree eq ==> flip impl) (paco1 itree_all_ r). *)
  (* Proof. *)
  (*   pcofix CH. *)
  (*   intros t1 t2 Heq Hall. *)
  (*   punfold Hall; pstep. *)
  (*   unfold itree_all_ in *. *)
  (*   punfold Heq. unfold eqit_ in Heq. *)
  (*   destruct (observe t1); destruct (observe t2); inversion Heq; subst; try congruence. *)
  (*   - inversion Hall; subst; constructor; auto. *)
  (*   - inversion Hall; subst. *)
  (*     destruct REL as [REL | REL]. *)
  (*     2: { inversion REL. } *)
  (*     constructor. *)
  (*     destruct H0 as [H0 | H0]. *)
  (*     + right. eapply CH. apply REL. auto. *)
  (*     + right. apply CH0. *)
  (*     constructor. right. *)
  (*     eapply CH. apply REL. *)
  (*     destruct H0 as [H0 | H0]. *)
  (*     + eapply itree_allF_impl. *)
  (*       2: { apply Hall. *)
  (*     2: { inversion H0. } *)
  (*     destruct REL as [H1 | H1]. *)
  (*     2: { inversion H1. } *)
  (*     constructor. right. eapply CH; eauto. *)
  (*   - eapply fold_eqitF with (t3 := Vis e k) (t4 := Vis e0 k0) in Heq; auto. *)
  (*     apply eqitree_inv_Vis_r in Heq. *)
  (*     destruct Heq as [k' [H0 Heq]]. *)
  (*     simpl in H0. *)
  (*     inversion H0; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H3; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H6; subst. *)
  (*     constructor; intros x. *)
  (*     right; eapply CH; eauto. *)
  (*     inversion Hall; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H6; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H7; subst. *)
  (*     destruct (H3 x) as [H | H]; auto; inversion H. *)
  (* Qed. *)

  Global Instance Proper_itree_all : Proper (eq_itree eq ==> flip impl) itree_all.
  Proof.
    pcofix CH.
    intros t1 t2 Heq Hall.
    punfold Hall; pstep.
    unfold itree_all_ in *.
    punfold Heq. unfold eqit_ in Heq.
    destruct (observe t1); destruct (observe t2); inversion Heq; subst; try congruence.
    - inversion Hall; subst; constructor; auto.
    - inversion Hall; subst.
      destruct H0 as [H0 | H0].
      2: { inversion H0. }
      destruct REL as [H1 | H1].
      2: { inversion H1. }
      constructor. right. eapply CH; eauto.
    - eapply fold_eqitF with (t3 := Vis e k) (t4 := Vis e0 k0) in Heq; auto.
      apply eqitree_inv_Vis_r in Heq.
      destruct Heq as [k' [H0 Heq]].
      simpl in H0.
      inversion H0; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H6; subst.
      constructor; intros x.
      right; eapply CH; eauto.
      inversion Hall; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H6; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H7; subst.
      destruct (H3 x) as [H | H]; auto; inversion H.
  Qed.
End itree_all.
Hint Resolve itree_all__mono : paco.

Section in_itree_lang.
  Context {A : Type} (P : A -> Prop).

  Inductive in_itree_langF (R : itree unbiasedE A -> list bool -> Prop)
    : itree' unbiasedE A -> list bool -> Prop :=
  | in_itree_langF_ret_true : forall x,
      P x ->
      in_itree_langF R (RetF x) []
  | in_itree_langF_tau : forall t bs, R t bs -> in_itree_langF R (TauF t) bs
  | in_itree_langF_vis_true : forall f bs,
      R (f true) bs ->
      in_itree_langF R (VisF GetUnbiased f) (true :: bs)
  | in_itree_langF_vis_false : forall f bs,
      R (f false) bs ->
      in_itree_langF R (VisF GetUnbiased f) (false :: bs).

  Definition in_itree_lang_ R : itree unbiasedE A -> list bool -> Prop :=
    fun t bs => in_itree_langF R (observe t) bs.

  Lemma in_itree_langF_mono R R' t bs
        (IN: in_itree_langF R t bs)
        (LE: R <2= R') :
    in_itree_langF R' t bs.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma in_itree_lang__mono : monotone2 (in_itree_lang_).
  Proof. do 2 red. intros. eapply in_itree_langF_mono; eauto. Qed.
  Hint Resolve in_itree_lang__mono : paco.

  Definition in_itree_lang : itree unbiasedE A -> list bool -> Prop :=
    paco2 in_itree_lang_ bot2.

  (* Fixpoint in_itree_aux (t : itree unbiasedE A) (bs : list bool) (n : nat) : bool := *)
  (*   match n with *)
  (*   | O => false *)
  (*   | S n' => match observe t with *)
  (*            | RetF x => P x *)
  (*            | TauF t' => in_itree_aux t' bs n' *)
  (*            | VisF GetUnbiased k => *)
  (*              match bs with *)
  (*              | nil => false *)
  (*              | false :: bs' => in_itree_aux (k false) bs' n' *)
  (*              | true :: bs' => in_itree_aux (k true) bs' n' *)
  (*              end *)
  (*            end *)
  (*   end. *)

  (* Definition in_itree (t : itree unbiasedE A) (bs : list bool) : bool := *)
  (*   in_itree_aux t bs (S (length bs)). *)

  (* Lemma in_itree_spec (t : itree unbiasedE A) (bs : list bool) : *)
  (*   itree_notau t -> *)
  (*   in_itree_aux t bs (S (length bs)) = true <-> in_itree_lang t bs. *)
  (* Proof. *)
  (*   revert t. *)
  (*   induction bs; simpl; intros t Hnotau. *)
  (*   - punfold Hnotau; unfold itree_notau_ in Hnotau. *)
  (*     destruct (observe t) eqn:Ht. *)
  (*     + split; intro H. *)
  (*       * pstep; unfold in_itree_lang_; rewrite Ht; constructor; auto. *)
  (*       * punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*         inversion H; auto. *)
  (*     + inversion Hnotau. *)
  (*     + destruct e. *)
  (*       split; intro H; try congruence. *)
  (*       punfold H; unfold in_itree_lang_ in H; rewrite Ht in H; inversion H. *)
  (*   - punfold Hnotau; unfold itree_notau_ in Hnotau. *)
  (*     destruct (observe t) eqn:Ht. *)
  (*     + split; intro H. *)
  (*       * pstep; unfold in_itree_lang_; rewrite Ht; constructor; auto. *)
  (*       * punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*         inversion H; auto. *)
  (*     + inversion Hnotau. *)
  (*     + destruct e. *)
  (*       inversion Hnotau. *)
  (*       apply Classical_Prop.EqdepTheory.inj_pair2 in H1; subst. *)
  (*       apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst. *)
  (*       destruct a. *)
  (*       * specialize (H0 true). *)
  (*         destruct H0 as [H0 | H0]. *)
  (*         2: inversion H0. *)
  (*         specialize (IHbs (k true) H0); destruct IHbs as [IH IH']. *)
  (*         split; intro H. *)
  (*         -- pstep; unfold in_itree_lang_; rewrite Ht; constructor. *)
  (*            left; apply IH; auto. *)
  (*         -- punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*            inversion H; subst. *)
  (*            destruct H3 as [H3 | H3]. *)
  (*            2: inversion H3. *)
  (*            apply Classical_Prop.EqdepTheory.inj_pair2 in H1; subst. *)
  (*            apply IH'; auto. *)
  (*       * specialize (H0 false). *)
  (*         destruct H0 as [H0 | H0]. *)
  (*         2: inversion H0. *)
  (*         specialize (IHbs (k false) H0); destruct IHbs as [IH IH']. *)
  (*         split; intro H. *)
  (*         -- pstep; unfold in_itree_lang_; rewrite Ht; constructor. *)
  (*            left; apply IH; auto. *)
  (*         -- punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*            inversion H; subst. *)
  (*            destruct H3 as [H3 | H3]. *)
  (*            2: inversion H3. *)
  (*            apply Classical_Prop.EqdepTheory.inj_pair2 in H1; subst. *)
  (*            apply IH'; auto. *)
  (* Qed. *)

  (* Lemma in_itree_reflect (t : itree unbiasedE A) (bs : list bool) : *)
  (*   itree_notau t -> *)
  (*   reflect (in_itree_lang t bs) (in_itree t bs). *)
  (* Proof. *)
  (*   intro Hnotau. *)
  (*   generalize (in_itree_spec t bs Hnotau); intro H. *)
  (*   unfold in_itree. *)
  (*   destruct (in_itree_aux t bs (S (length bs))); constructor. *)
  (*   - apply H; auto. *)
  (*   - intro HC. *)
  (*     assert (false = true). *)
  (*     { apply H; auto. } *)
  (*     congruence. *)
  (* Qed. *)
End in_itree_lang.
Hint Resolve in_itree_lang__mono : paco.

Section itree_lang.
  Context {A : Type} (P : A -> Prop).

  (* CoInductive itree_lang' : itree unbiasedE A -> (nat -> option (list bool)) -> Prop := *)
  (* | itree_lang'_false : forall x, P x = false -> itree_lang' (Ret x) seq_zero *)
  (* | itree_lang'_true : forall x, P x = true -> itree_lang' (Ret x) (seq_one []) *)
  (* | itree_lang'_vis : forall f s1 s2, *)
  (*     itree_lang' (f true) s1 -> *)
  (*     itree_lang' (f false) s2 -> *)
  (*     itree_lang' (Vis GetUnbiased f) (seq_union (option_map (cons true) ∘ s1) *)
  (*                                                (option_map (cons false) ∘ s2)). *)

  (** See Eq/Eq.v in the ITree development for explanation of this
      construction (eqitF, eqit_, etc.). *)
  Inductive itree_langF (R : itree unbiasedE A -> (nat -> option (list bool)) -> Prop)
    : itree' unbiasedE A -> (nat -> option (list bool)) -> Prop :=
  | itree_langF_ret_false : forall x, ~ P x -> itree_langF R (RetF x) seq_zero
  | itree_langF_ret_true : forall x s,
      P x ->
      s === seq_one [] ->
      itree_langF R (RetF x) s
  | itree_langF_tau : forall t s1 s2, R t s1 -> s1 === s2 -> itree_langF R (TauF t) s2
  | itree_langF_vis : forall f s1 s2 s,
      R (f true) s1 ->
      R (f false) s2 ->
      s === seq_union (option_map (cons true) ∘ s1) (option_map (cons false) ∘ s2) ->
      itree_langF R (VisF GetUnbiased f) s.

  Definition itree_lang_ R : itree unbiasedE A -> (nat -> option (list bool)) -> Prop :=
    fun t s => itree_langF R (observe t) s.

  Lemma itree_langF_mono R R' t s
        (IN: itree_langF R t s)
        (LE: R <2= R') :
    itree_langF R' t s.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_lang__mono : monotone2 (itree_lang_).
  Proof. do 2 red. intros. eapply itree_langF_mono; eauto. Qed.
  Hint Resolve itree_lang__mono : paco.

  Definition itree_lang : itree unbiasedE A -> (nat -> option (list bool)) -> Prop :=
    paco2 itree_lang_ bot2.

  Definition itree_lang' r : itree unbiasedE A -> (nat -> option (list bool)) -> Prop :=
    paco2 itree_lang_ r.

  Lemma itree_langF_impl (t : itree' unbiasedE A) s
        (r1 r2 : itree unbiasedE A -> (nat -> option (list bool)) -> Prop) :
    (forall t s, r1 t s -> r2 t s) ->
    itree_langF r1 t s -> itree_langF r2 t s.
  Proof.
    intros H0 H1.
    destruct t; inversion H1; subst.
    - constructor; auto.
    - constructor; auto.
    - econstructor; eauto.
    - apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H2; subst; auto.
      econstructor; eauto.
  Qed.

  Lemma itree_lang_impl
        (t : itree unbiasedE A) s
        (r1 r2 : itree unbiasedE A -> (nat -> option (list bool)) -> Prop) :
    (forall t s, r1 t s -> r2 t s) ->
    paco2 itree_lang_ r1 t s -> paco2 itree_lang_ r2 t s.
  Proof.
    revert t s.
    pcofix CH.
    intros t s H0 H1.
    punfold H1; pstep.
    eapply itree_langF_impl.
    2: { apply H1. }
    intros t' s' [H2 | H2].
    - right; apply CH; auto.
    - right; auto.
  Qed.

  Global Instance Proper_itree_langF R
    : Proper (eq ==> seq_bijection_upto_0 ==> iff) (itree_langF R).
  Proof.
    intros ? t ? s1 s2 Hbij; subst; split; intro H0.
    - induction H0.
      + symmetry in Hbij; apply seq_bijection_upto_0_zero in Hbij.
        subst; constructor; auto.
      + constructor; auto; rewrite <- Hbij; auto.
      + econstructor; eauto; rewrite H0; auto.
      + econstructor; eauto; rewrite <- Hbij; auto.
    - induction H0.
      + apply seq_bijection_upto_0_zero in Hbij; subst; constructor; auto.
      + constructor; auto; rewrite Hbij; auto.
      + econstructor; eauto; rewrite Hbij; auto.
      + econstructor; eauto; rewrite Hbij; auto.
  Qed.

  Lemma itree_lang_lang' r t s :
    itree_lang t s -> itree_lang' r t s.
  Proof.
    revert t s.
    pcofix CH; intros t s.
    unfold itree_lang, itree_lang' in *.
    intro H. pstep.
    punfold H.
    unfold itree_lang_ in *.
    destruct (observe t).
    + inversion H; subst; constructor; auto.
    + inversion H; subst.
      eapply itree_langF_tau; eauto.
      right. apply CH.
      destruct H1. apply H0. inversion H0.
    + destruct e.
      inversion H; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H0; subst.
      econstructor; eauto.
      * destruct H1 as [H1 | H1].
        -- apply CH in H1; right; eauto.
        -- inversion H1.
      * destruct H2 as [H2 | H2].
        -- apply CH in H2; right; eauto.
        -- inversion H2.
  Qed.

  Global Instance Proper_itree_lang' r
    : Proper (eq ==> seq_bijection_upto_0 ==> flip impl) (paco2 itree_lang_ r).
  Proof.
    intros ? t ? s1 s2 Hbij H; subst.
    pstep; punfold H; unfold itree_lang_.
    rewrite Hbij; apply H.
  Qed.

  Global Instance Proper_itree_lang : Proper (eq_itree eq ==> eq ==> flip impl) itree_lang.
  Proof.
    pcofix CH; intros x y Heq s1 s2 ? Hlang; subst.
    punfold Heq; unfold eqit_ in Heq.
    punfold Hlang; unfold itree_lang_ in Hlang.
    pstep; unfold itree_lang_.
    destruct (observe x); inversion Heq; subst;
      try congruence; rewrite <- H in Hlang; clear H.
    - inversion Hlang; subst; constructor; auto.
    - inversion Hlang; subst.
      repeat destruct_upaco.
      econstructor; eauto.
    - destruct e.
      apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
      inversion Hlang; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H; subst.
      repeat destruct_upaco.
      unfold id in REL.
      econstructor; eauto.
      + right; specialize (REL true); destruct_upaco.
        eapply CH in REL; eauto.
      + right; specialize (REL false); destruct_upaco.
        eapply CH in REL; eauto.
  Qed.
End itree_lang.
Hint Resolve itree_lang__mono : paco.

Section itree_lang2.
  Context {A : Type} (P : A -> Prop).

  (** See Eq/Eq.v in the ITree development for explanation of this
      construction (eqitF, eqit_, etc.). *)
  Inductive itree_lang2F (R : itree unbiasedE A ->
                              (nat -> option (list bool)) ->
                              (nat -> option (list bool)) -> Prop)
    : itree' unbiasedE A -> (nat -> option (list bool)) -> (nat -> option (list bool)) -> Prop :=
  | itree_lang2F_ret_false : forall x, ~ P x -> itree_lang2F R (RetF x) seq_zero seq_zero
  | itree_lang2F_ret_true : forall x s1 s2,
      P x ->
      s1 === seq_one [] ->
      s2 === seq_one [] ->
      itree_lang2F R (RetF x) s1 s2
  | itree_lang2F_tau : forall t s1 s1' s2 s2',
      R t s1 s1' ->
      s1 === s2 ->
      s1' === s2' ->
      s2 === s2' ->
      itree_lang2F R (TauF t) s2 s2'
  | itree_lang2F_vis : forall f s1 s1' s2 s2' s s',
      R (f true) s1 s1' ->
      R (f false) s2 s2' ->
      s === seq_union (option_map (cons true) ∘ s1) (option_map (cons false) ∘ s2) ->
      s' === seq_union (option_map (cons true) ∘ s1) (option_map (cons false) ∘ s2) ->
      itree_lang2F R (VisF GetUnbiased f) s s'.

  Definition itree_lang2_ R : itree unbiasedE A ->
                              (nat -> option (list bool)) ->
                              (nat -> option (list bool)) -> Prop :=
    fun t s => itree_lang2F R (observe t) s.

  Lemma itree_lang2F_mono R R' t s1 s2
        (IN: itree_lang2F R t s1 s2)
        (LE: R <3= R') :
    itree_lang2F R' t s1 s2.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_lang2__mono : monotone3 (itree_lang2_).
  Proof. do 2 red. intros. eapply itree_lang2F_mono; eauto. Qed.
  Hint Resolve itree_lang2__mono : paco.

  Definition itree_lang2 : itree unbiasedE A ->
                           (nat -> option (list bool)) ->
                           (nat -> option (list bool)) -> Prop :=
    paco3 itree_lang2_ bot3.
End itree_lang2.

Hint Resolve itree_lang2__mono : paco.

Lemma observe_Ret {A : Type} {E : Type -> Type} (t : itree E A) (x : A) :
  observe t = RetF x ->
  t ≅ Ret x.
Proof.
  intro H; pstep; unfold eqit_; simpl; rewrite H; constructor; reflexivity.
Qed.

Lemma observe_Tau {A : Type} {E : Type -> Type} (t1 t2 : itree E A) :
  observe t1 = TauF t2 ->
  t1 ≅ Tau t2.
Proof.
  intro H; pstep; unfold eqit_; simpl.
  rewrite H; apply EqTau; left; apply Reflexive_eqit_eq.
Qed.

Lemma observe_Vis {A B : Type} {E : Type -> Type} (t : itree E A) (e : E B) (f : B -> itree E A) :
  observe t = VisF e f ->
  t ≅ Vis e f.
Proof.
  intro H; pstep; unfold eqit_; simpl.
  rewrite H; constructor; left; apply Reflexive_eqit_eq.
Qed.

Lemma seq_product_option_mult_comm (s1 s2 : nat -> option (list bool)) (b : bool) :
  seq_product MonoidList (option_map (cons b) ∘ s1) s2 =
  option_map (cons b) ∘ (seq_product MonoidList s1 s2).
Proof.
  replace (option_map (cons b)) with (option_mult MonoidList (Some [b])) by reflexivity.
  apply seq_product_option_mult_comm; apply MonoidLawsList.
Qed.

Lemma itree_lang_langF {A : Type} (P : A -> Prop) r t s :
  itree_lang_ P r t s ->
  itree_langF P r (observe t) s.
Proof. firstorder. Qed.

Lemma itree_langF_lang {A : Type} (P : A -> Prop) r t s :
  itree_langF P r (observe t) s ->
  itree_lang_ P r t s.
Proof. firstorder. Qed.

Lemma itree_lang_unfold_bind {A B : Type} (t : itree unbiasedE A) (k : A -> itree unbiasedE B) s r P :
  paco2 (itree_lang_ P) r (match observe t with
                           | RetF r => k r
                           | TauF t0 => Tau (x <- t0;; k x)
                           | VisF e ke => Vis e (fun x => x <- ke x;; k x)
                           end) s ->
  paco2 (itree_lang_ P) r (x <- t;; k x) s.
Proof.
  revert t k s.
  pcofix CH; intros t k s H.
  punfold H. pstep.
  unfold itree_lang_ in H.
  unfold ITree.bind.
  unfold ITree.subst.
  compute.
  apply itree_lang_langF.
  rewrite _observe_observe.
  destruct (observe t) eqn:Ht.
  - unfold itree_lang_.
    eapply itree_langF_impl.
    2: { eauto. }
    intros t' s' [H0 | H0].
    + left; eapply itree_lang_impl; eauto.
    + right; auto.
  - inversion H; subst.
    econstructor; eauto.
    destruct H1 as [H1 | H1].
    + left; eapply itree_lang_impl; eauto.
    + right; auto.
  - destruct e.
    inversion H; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H0; subst.
    destruct H2 as [H2 | H2]; destruct H1 as [H1 | H1];
      econstructor; eauto; left; eapply itree_lang_impl; eauto.
Qed.

Lemma itree_lang_unfold_iter {A B : Type} P (f : A -> itree unbiasedE (A + B)) x s r :
  paco2 (itree_lang_ P) r (lr <- f x ;; match lr with
                                       | inl l => Tau (ITree.iter f l)
                                       | inr r => Ret r
                                       end) s ->
  paco2 (itree_lang_ P) r (ITree.iter f x) s.
Proof.
  revert f x s.
  pcofix CH; intros f x s H.
  punfold H. pstep.
  unfold itree_lang_ in *.
  unfold ITree.bind in H.
  unfold ITree.subst in H.
  compute in H.
  apply itree_langF_lang.
  rewrite 2!_observe_observe in H.
  unfold ITree.iter. compute.
  apply itree_lang_langF.
  rewrite _observe_observe.
  destruct (observe (f x)) eqn:Hfx.
  - destruct r1.
    + unfold itree_lang_.
      simpl in *.
      inversion H; subst.
      econstructor; eauto.
      destruct H1 as [H1 | H1].
      * left; eapply itree_lang_impl; eauto.
      * right; apply CH0; auto.
    + inversion H; subst; constructor; auto.
  - inversion H; subst.
    econstructor; eauto.
    destruct H1 as [H1 | H1].
    * left; eapply itree_lang_impl; eauto.
    * right; apply CH0; auto.
  - destruct e.
    inversion H; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H0; subst.
    destruct H2 as [H2 | H2]; destruct H1 as [H1 | H1];
      econstructor; eauto; left; eapply itree_lang_impl; eauto.
Qed.

Lemma itree_lang_bind {A : Type} (t1 : itree unbiasedE (unit + A)) (t2 : unit -> itree unbiasedE A)
      (P : A -> Prop) (s1 s1' s2 : nat -> option (list bool))
      (r : itree unbiasedE A -> (nat -> option (list bool)) -> Prop) :
  itree_lang (cotuple (const True) (const False)) t1 s1 ->
  itree_lang (cotuple (const False) P) t1 s1' ->
  r (t2 tt) s2 ->
  paco2 (itree_lang_ P) r (lr <- t1;; match lr with
                                     | inl l => Tau (t2 l)
                                     | inr r => Ret r
                                     end) (seq_union s1' (seq_product MonoidList s1 s2)).
Proof.
  intros H0 H1 H2.
  revert H0 H1.
  revert t1 s1 s1'.
  pcofix CH. intros t1 s1 s1'.
  intros H0 H1.
  apply itree_lang_unfold_bind.
  pstep.
  punfold H0. punfold H1.
  unfold itree_lang_ in *.
  destruct (observe t1) eqn:Ht1.
  - destruct r0 eqn:Hr.
    + inversion H0; subst.
      * simpl in H3; exfalso; apply H3; apply I.
      * clear H3.
        inversion H1; subst.
        2: { inversion H3. }
        clear H3.
        pstep_reverse. rewrite H4.
        rewrite seq_union_zero_l.
        rewrite seq_product_unit_l.
        pstep.
        destruct u.
        econstructor; eauto; reflexivity.
        apply MonoidLawsList.
    + inversion H0; subst.
      2: { inversion H3. }
      clear H3.
      inversion H1; subst; simpl in H3.
      * pstep_reverse.
        rewrite seq_union_zero_l.
        rewrite seq_product_zero_l.
        pstep.
        constructor; auto.
      * constructor; auto.
        rewrite seq_product_zero_l.
        rewrite seq_union_zero_r; auto.
  - econstructor; eauto; try reflexivity.
    right. apply CH.
    + inversion H0; subst. rewrite <- H4. destruct H3.
      apply H. inversion H.
    + inversion H1; subst. rewrite <- H4. destruct H3.
      apply H. inversion H.
  - inversion H0; subst; clear H0.
    destruct e; clear H3.
    apply Eqdep.EqdepTheory.inj_pair2 in H4; subst.
    inversion H1; subst; clear H1.
    apply Eqdep.EqdepTheory.inj_pair2 in H; subst.
    destruct H7 as [H7 | H7].
    2: { inversion H7. }
    destruct H5 as [H5 | H5].
    2: { inversion H5. }
    destruct H3 as [H3 | H3].
    2: { inversion H3. }
    destruct H0 as [H0 | H0].
    2: { inversion H0. }
    pstep_reverse.
    rewrite H4, H8.
    rewrite seq_product_union_distr_r.
    rewrite 2!seq_product_option_mult_comm.
    rewrite seq_union_comm_4.
    rewrite 2!seq_union_compose.
    pstep.
    econstructor; eauto; reflexivity.
Qed.

Lemma itree_lang_iter_reps_product_P {A : Type} (t : itree unbiasedE (nat + A))
      (s1 s2 : nat -> option (list bool)) P l :
  itree_lang (cotuple (eq l) (const False)) t s1 ->
  itree_lang (cotuple (const False) P) t s2 ->
  itree_lang (cotuple (const False) P)
             (ITree.iter (fun _ => x <- t ;;
                                match x with
                                | inl n =>
                                  if n =? l
                                  then ret (inl tt)
                                  else ret (inr (inl n))
                                | inr y =>
                                  ret (inr (inr y))
                                end) tt)
             (seq_product MonoidList (seq_reps MonoidList s1) s2).
Proof.
  intros Hl Hr.
  pcofix CH.
  apply itree_lang_unfold_iter.
  rewrite seq_reps_unfold.
  rewrite seq_product_union_distr_r.
  rewrite seq_product_unit_l.
  2: { apply MonoidLawsList. }
  rewrite seq_product_assoc.
  2: { apply MonoidLawsList. }
  apply itree_lang_bind; auto.
  - clear CH. clear r. clear Hr. clear s2. clear P.
    revert Hl. revert t l s1.
    pcofix CH.
    intros t l s1 H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- simpl in H1.
           apply PeanoNat.Nat.eqb_neq in H1.
           rewrite PeanoNat.Nat.eqb_sym in H1.
           rewrite H1.
           pstep; constructor; intuition.
        -- clear H1.
           pstep; constructor; intuition.
      * destruct r0.
        -- simpl in H1; subst.
           rewrite PeanoNat.Nat.eqb_refl.
           pstep; constructor; auto; apply I.
        -- inversion H1.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - clear CH. clear r. clear Hl. clear s1.
    revert Hr. revert t l s2.
    pcofix CH.
    intros t l s2 H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- clear H1. pstep.
           destruct (PeanoNat.Nat.eqb_spec n l); subst; constructor; auto.
        -- simpl in H1.
           pstep; constructor; auto.
      * destruct r0.
        -- inversion H1.
        -- simpl in H1.
           pstep; constructor; auto.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - apply MonoidLawsList.
Qed.

Lemma itree_all_itree_lang_iter_P {A : Type} (t : itree unbiasedE (nat + A))
      (s1 s2 : nat -> option (list bool)) P l :
  itree_all (cotuple (eq l) (const True)) t ->
  itree_lang (cotuple (eq l) (const False)) t s1 ->
  itree_lang (cotuple (const False) P) t s2 ->
  itree_lang P (ITree.iter (fun _ => x <- t ;;
                                  match x with
                                  | inl _ => ret (inl tt)
                                  | inr y => ret (inr y)
                                  end) tt)
             (seq_product MonoidList (seq_reps MonoidList s1) s2).
Proof.
  intros Hall Hl Hr.
  pcofix CH.
  apply itree_lang_unfold_iter.
  rewrite seq_reps_unfold.
  rewrite seq_product_union_distr_r.
  rewrite seq_product_unit_l.
  2: { apply MonoidLawsList. }
  rewrite seq_product_assoc.
  2: { apply MonoidLawsList. }
  apply itree_lang_bind; auto.
  - clear CH. clear r. clear Hr. clear s2. clear P.
    revert Hall Hl. revert t s1.
    pcofix CH.
    intros t s1 Hall H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    punfold Hall. unfold itree_all_ in Hall.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- inversion Hall; subst; simpl in *; congruence.
        -- pstep; constructor; intuition.
      * destruct r0.
        -- pstep; constructor; auto; apply I.
        -- inversion H1.
    + inversion Hall; subst.
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      inversion H0; subst.
      destruct H2; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      inversion Hall; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H4; subst.
      pose proof (H1 false) as H2.
      specialize (H1 true).
      destruct H2 as [H2 | H2].
      2: { inversion H2. }
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - clear CH. clear r. clear Hl. clear s1.
    revert Hall Hr. revert t s2.
    pcofix CH.
    intros t s2 Hall H0.
    apply itree_lang_unfold_bind.
    punfold Hall. unfold itree_all_ in Hall.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0; pstep; constructor; auto.
      * destruct r0.
        -- inversion H1.
        -- simpl in H1.
           pstep; constructor; auto.
    + inversion Hall; subst.
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      inversion H0; subst.
      destruct H2; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      inversion Hall; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H4; subst.
      pose proof (H1 false) as H2.
      specialize (H1 true).
      destruct H2 as [H2 | H2].
      2: { inversion H2. }
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - apply MonoidLawsList.
Qed.

Lemma itree_lang_iter_reps_product_lbl {A : Type} (t : itree unbiasedE (nat + A))
      (s1 s2 : nat -> option (list bool)) l m :
  l <> m ->
  itree_lang (cotuple (eq l) (const False)) t s1 ->
  itree_lang (cotuple (eq m) (const False)) t s2 ->
  itree_lang (cotuple (eq m) (const False))
             (ITree.iter (fun _ => x <- t ;;
                                match x with
                                | inl n =>
                                  if n =? l
                                  then ret (inl tt)
                                  else ret (inr (inl n))
                                | inr y =>
                                  ret (inr (inr y))
                                end) tt)
             (seq_product MonoidList (seq_reps MonoidList s1) s2).
Proof.
  intros Hneq Hl Hr.
  pcofix CH.
  apply itree_lang_unfold_iter.
  rewrite seq_reps_unfold.
  rewrite seq_product_union_distr_r.
  rewrite seq_product_unit_l.
  2: { apply MonoidLawsList. }
  rewrite seq_product_assoc.
  2: { apply MonoidLawsList. }
  apply itree_lang_bind; auto.
  - clear CH. clear r. clear Hr. clear s2.
    revert Hneq Hl. revert t l m s1.
    pcofix CH.
    intros t l m s1 Hneq H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- simpl in H1.
           apply PeanoNat.Nat.eqb_neq in H1.
           rewrite PeanoNat.Nat.eqb_sym in H1.
           rewrite H1.
           pstep; constructor; intuition.
        -- clear H1.
           pstep; constructor; intuition.
      * destruct r0.
        -- simpl in H1; subst.
           rewrite PeanoNat.Nat.eqb_refl.
           pstep; constructor; auto; apply I.
        -- inversion H1.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - clear CH. clear r. clear Hl. clear s1.
    revert Hneq Hr. revert t l s2.
    pcofix CH.
    intros t l s2 Hneq H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- simpl in H1; pstep.
           destruct (PeanoNat.Nat.eqb_spec n l); subst; constructor; auto.
        -- simpl in H1; pstep; constructor; auto.
      * destruct r0.
        -- pstep.
           destruct (PeanoNat.Nat.eqb_spec n l); subst.
           ++ simpl in H1; subst; congruence.
           ++ constructor; auto.
        -- simpl in H1.
           pstep; constructor; auto.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - apply MonoidLawsList.
Qed.


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

(**********************************************************************)
(*                    Fieska_Normal.v                                 *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.
Require Import IntensionalLib.Fieska_calculus.Fieska_Tactics.
Require Import IntensionalLib.Fieska_calculus.Fieska_reduction.

Inductive status_val :=
| Active : status_val
| Passive : status_val
.

Fixpoint status M :=
match M with
| Ref _ => Active
| Op _ => Passive
| App (App (App (Op Fop) M1) _ ) _ => status M1
| App (App (Op Eop) M1) M2  => match status M1 with Active => Active | _ => status M2 end
| App M1 _ => status M1
end.

(* normal terms *)

Inductive normal : Fieska -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_active : forall M1 M2, normal M1 -> normal M2 ->
                              status (App M1 M2) = Active ->
                              normal (App M1 M2)
| nf_compound : forall M1 M2, normal M1 -> normal M2 ->
                              compound (App M1 M2) -> normal (App M1 M2)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) sf_seqred1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M sf_seqred1.
Proof.
intros M nor; induction nor; split_all.
eapply2 ref_irreducible.
red; split_all. inversion H.
intro. intro. inversion H0; subst; simpl in *; try discriminate.
(* 7 *)
eapply2 IHnor1.
(* 6 *)
eapply2 IHnor2.
(* 5 *)
gen2_case H4 H P; subst; inv1 compound; subst; split_all; discriminate.
(* 4 *)
gen2_case H4 H M2; subst; inv1 compound; subst; split_all; discriminate.
(* 3 *)
gen2_case H4 H M; subst; inv1 compound; subst; split_all; discriminate.
(* 2 *)
gen2_case H3 H M; subst; inv1 compound; subst; split_all; discriminate.
(* 1 *)
intro. intro. inversion H0; subst; simpl in *; try (inversion H; fail).
eapply2 IHnor1.
eapply2 IHnor2.
Qed.

Theorem Fieska_progress : forall (M : Fieska), normal M \/ (exists N, sf_seqred1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 1 *)
inversion IHM1; split_all. 2: right; inversion H; exist (App x M2).
inversion IHM2; split_all. 2: right; inversion H0; exist (App M1 x).
gen_case H M1. case o; try (right; eauto; fail); left; auto.
inversion H; subst.
(* 2 *)
left; auto.
eapply2 nf_active. gen_case H5 f. discriminate.  gen_case H5 f1. gen_case H5 o.
discriminate.
(* 1 *)
gen2_case H3 H5 f.
gen2_case H3 H5 o; try (right; eauto; fail); try (left; auto; fail).
inversion H4; subst; try (right; eauto; fail); try (left; auto; fail).
inversion H0; subst; try (right; eauto; fail); try (left; auto; fail).
right. assert(o0 = o1 \/ o0 <> o1) by decide equality.
inversion H1; subst; eauto.
left. eapply2 nf_active. simpl in *. rewrite H6. auto.
inversion H0; subst; try (left; auto; fail); try (right; eauto; fail).
left; eapply2 nf_active. inversion H6; simpl; auto.
left; eapply2 nf_active. inversion H6; simpl; auto.
inversion H5; subst; try (right;  eauto; fail).
inversion H3; subst; inversion H7; subst; try (right;  eauto; fail); try (left; auto; fail).
Qed.