From mathcomp Require Import all_ssreflect.
From Paco Require Import paco paco2.
Require Import Setoid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Reserved Notation "x =l y" (at level 70, no associativity).
Reserved Notation "x =g y" (at level 70, no associativity).
Reserved Notation "x =a/g y" (at level 70, no associativity).
Reserved Notation "x '=1/g' y" (at level 70, no associativity).
Reserved Notation "x '=1/a' y" (at level 70, no associativity).
Reserved Notation "x '=1/a/g' y" (at level 70, no associativity).
Reserved Notation "x '=1/sval' y" (at level 70, no associativity).

(****************************************************************************)
(** Assumptions and Strict positivisation of functors                      **)
(****************************************************************************)

Module Type AType.
  Axiom t : Type.
End AType.

Reserved Notation "f =e g" (at level 70, no associativity).

Module Type EType.
  Parameter t : Type.
  Parameter eq_r : t -> t -> Prop.
  Axiom e_refl : forall x, eq_r x x.
  Axiom e_sym : forall x y, eq_r x y -> eq_r y x.
  Axiom e_trans : forall x y z, eq_r x y -> eq_r y z -> eq_r x z.
End EType.

Module MkEType (A : AType) <: EType.
  Definition t := A.t.

  Definition eq_r := @eq t.
  Definition e_refl := @erefl t.
  Definition e_sym := @esym t.
  Definition e_trans := @etrans t.
End MkEType.

Module Theory (T : EType).
  Notation "f =e g" := (T.eq_r f g).

  Add Parametric Relation : T.t T.eq_r
      reflexivity proved by T.e_refl
      symmetry proved by T.e_sym
      transitivity proved by T.e_trans
        as ExtEq.
End Theory.

Module Type Functor.
  Axiom shape : Type.
  Axiom position : Type.
  Axiom dom : shape -> position -> bool.
End Functor.

Module App (F : Functor) (X : EType).
  Module XT := Theory(X).
  Import XT.
  Definition t := {sh : F.shape & sig (F.dom sh) -> X.t}.

  Lemma cont_irr (sh : F.shape) (f : sig (F.dom sh) -> X.t)
    : forall x p1 p2, f (exist _ x p1) = f (exist _ x p2).
  Proof. move=> x/= p1 p2; by rewrite (bool_irrelevance p1 p2). Qed.

  Definition appR (x y : t) : Prop
    := projT1 x = projT1 y /\
       (forall e d1 d2, projT2 x (exist _ e d1) =e projT2 y (exist _ e d2)).

  Lemma AppR_inv_sh x y : @appR x y -> projT1 x = projT1 y.
  Proof. by case. Qed.

  Lemma AppR_inv_k x y :
    @appR x y ->
    forall e d1 d2, projT2 x (exist _ e d1) =e projT2 y (exist _ e d2).
  Proof. by case. Qed.
End App.

Module AppTy (F : Functor) (X : EType) <: EType.
  Module FX := App(F)(X).
  Definition t := FX.t.

  Definition eq_r (f g : t) := FX.appR f g.
  Lemma e_refl : forall f, eq_r f f.
  Proof.
    move=> [s k]; split=>//= e d1 d2.
    by rewrite (bool_irrelevance d2 d1); reflexivity.
  Qed.

  Lemma e_sym : forall f g, eq_r f g -> eq_r g f.
  Proof.
    move=> x y [Sxy Exy]; split; first by apply/esym.
    by move=> e d1 d2; symmetry.
  Qed.

  Lemma e_trans : forall x y z, eq_r x y -> eq_r y z -> eq_r x z.
  Proof.
    move=> x y z [Sxy Exy] [Syz Eyz]; split; first by rewrite Sxy.
    move=>e d1 d2; have d3: F.dom (projT1 y) e by move: d1; rewrite Sxy.
    by rewrite (Exy e d1 d3).
  Qed.
End AppTy.

Module Type Func(A B : EType).
  Axiom f : A.t -> B.t.
  Axiom f_eq : forall x y, A.eq_r x y -> B.eq_r (f x) (f y).
End Func.

Module FuncTy (DOM COD : EType) <: EType.
  Module BTheory := Theory(COD).
  Import BTheory.

  Definition t := DOM.t -> COD.t.
  Definition eq_r (f g : t) := forall x, f x =e g x.
  Lemma e_refl : forall f, eq_r f f.
  Proof. move=> f x; by reflexivity. Qed.

  Lemma e_sym : forall f g, eq_r f g -> eq_r g f.
  Proof. move=> f g H x. by symmetry. Qed.

  Lemma e_trans : forall x y z, eq_r x y -> eq_r y z -> eq_r x z.
  Proof. move=> f g h H1 H2 x; by rewrite H1. Qed.
End FuncTy.

Module FMap (A B : EType) (F : Functor) (f : Func(A)(B)).
  Module DOM := AppTy(F)(A).
  Module COD := AppTy(F)(B).
  Module Def <: Func(DOM)(COD).
    Definition f (x : DOM.t) : COD.t
      := existT _ (projT1 x) (f.f \o projT2 x).

    Lemma f_eq : forall x y, DOM.eq_r x y -> COD.eq_r (f x) (f y).
    Proof.
      move=> [sx kx] [sy ky] [/=Es Ek]; split=>//= e d1 d2.
        by apply/f.f_eq/Ek.
    Qed.
  End Def.
End FMap.

Module Comp (A B C : EType) (f : Func(B)(C)) (g : Func(A)(B)) <: Func(A)(C).
  Definition f : A.t -> C.t := f.f \o g.f.

  Lemma f_eq : forall x y, A.eq_r x y -> C.eq_r (f x) (f y).
  Proof. by move=> x y H; apply/f.f_eq/g.f_eq. Qed.
End Comp.

Module Id (A : EType) <: Func(A)(A).
  Definition f := fun x : A.t => x.

  Lemma f_eq : forall x y, A.eq_r x y -> A.eq_r (f x) (f y).
  Proof. by []. Qed.
End Id.

Module Type Alg (F : Functor) (A : EType).
  Module FA := AppTy(F)(A).
  Declare Module Def : Func(FA)(A).
End Alg.

Module Type CoAlg (F : Functor) (A : EType).
  Module FA := AppTy(F)(A).
  Declare Module Def : Func(A)(FA).
End CoAlg.

Module LFix(A : Alg).
  M
  Inductive LFixT F : Type :=
  | LFix_in (sh : Shape F): (sig (dom sh) -> LFixT F) -> LFixT F.

Lemma fmap_id F A : fmapA F (id A) =e id _.
Proof.
  move=> [s k]/=; rewrite /fmapA_f/=; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1); by reflexivity.
Qed.

Lemma fmap_comp F A B C (f : arrow B C) (g : arrow A B)
  : fmapA F (f \o g) =e fmapA F f \o fmapA F g.
Proof.
  move=> [s k]/=; rewrite /fmapA_f/=; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1); by reflexivity.
Qed.

Add Parametric Morphism F (A B : TyEq) : (@fmapA F A B)
    with signature
    (eqRel (Eq (arrow A B)))
      ==> (eqRel (Eq (arrow (App F A) (App F B))))
      as fmapMorphism.
Proof.
  move=> f1 f2 Ef [s k]; split=>//= e d1 d2.
  by rewrite (bool_irrelevance d1 d2).
Qed.

Add Parametric Morphism (A B C : TyEq) : (@acomp A B C)
    with signature
    (eqRel (Eq (arrow B C)))
      ==> (eqRel (Eq (arrow A B)))
      ==> (eqRel (Eq (arrow A C)))
      as compMorphism.
Proof.
  move=> f1 f2 Ef g1 g2 Eg x=>//=.
  by apply/(e_trans (Ef (g1 x)))/f_eq/Eg.
Qed.

Definition Alg F A := arrow (App F A) A.
Definition CoAlg F A := arrow A (App F A).

Inductive LFixT F : Type :=
| LFix_in (sh : Shape F): (sig (dom sh) -> LFixT F) -> LFixT F.

Definition l_shape F (x : LFixT F) :=
  match x with
  | LFix_in sh _ => sh
  end.
Definition l_cont F (x : LFixT F) :=
  match x return sig (dom (l_shape x)) -> LFixT F with
  | LFix_in _ k => k
  end.

Fixpoint LFixR F (x y : LFixT F) : Prop :=
  l_shape x = l_shape y /\
  forall e d1 d2,
      LFixR (@l_cont F x (exist _ e d1)) (@l_cont F y (exist _ e d2)).

Lemma LFixR_inv_sh F (x y : LFixT F) : LFixR x y -> l_shape x = l_shape y.
Proof. by case: x=>[sx kx]; case: y=>[sy ky] []. Qed.

Lemma LFixR_inv_k F (x y : LFixT F)
  : LFixR x y ->
    forall e d1 d2,
      LFixR (@l_cont F x (exist _ e d1)) (@l_cont F y (exist _ e d2)).
Proof. by case: x=>[sx kx]; case: y=>[sy ky] []. Qed.

Lemma LFixR_refl F x : @LFixR F x x.
Proof.
  elim: x=>// shx k Ih; constructor=>//=x p1 p2.
  by rewrite (bool_irrelevance p1 p2); apply: Ih.
Qed.

Lemma LFixR_sym F x y : @LFixR F x y -> @LFixR F y x.
Proof.
  elim: x => sx kx Ih in y *; case: y => sy ky /=[/esym-Sxy E].
  split=>// e d1 d2; by apply/Ih/E.
Qed.

Lemma LFixR_trans F x y z : @LFixR F x y -> @LFixR F y z -> @LFixR F x z.
Proof.
  elim: x=> sx kx Ih in y z *; case: y=> sy ky/=; case: z=> sz kz/=.
  move=> [Sxy Exy] [Syz Eyz]; split; first by rewrite Sxy.
  move=> e d1 d2; apply: Ih; first by apply: Exy; rewrite Syz.
  by apply/Eyz.
Qed.

Definition LFix_Eq F :=
  {| eqRel := @LFixR F;
     e_refl := @LFixR_refl F;
     e_sym := @LFixR_sym F;
     e_trans := @LFixR_trans F;
  |}.

Definition LFix F :=
  {| Ty := LFixT F; Eq := @LFix_Eq F; |}.

Definition l_in_f F (x : App F (LFix F)) : LFix F :=
  LFix_in (projT2 x).

Lemma l_in_eq F x y : x =e y -> @l_in_f F x =e @l_in_f F y.
Proof. by case: x=> sx kx; case: y=> sy ky/= [/=Es Ek]; split. Qed.

Definition l_out_f F (x : LFix F) : App F (LFix F) :=
  match x with
  | LFix_in sh k => existT _ sh k
  end.

Lemma l_out_eq F x y : x =e y -> @l_out_f F x  =e @l_out_f F y.
Proof. by case: x=> sx kx; case: y=> sy ky/= [/=Es Ek]; split. Qed.

Definition l_in F : Alg F (LFix F) :=
  {| func := _; f_eq := @l_in_eq F |}.
Definition l_out F : CoAlg F (LFix F) :=
  {| func := _; f_eq := @l_out_eq F |}.

Lemma l_in_out F : l_in F \o l_out F =e id _.
Proof.
  move=>[s k]/=; split=>//= e d1 d2; rewrite (bool_irrelevance d1 d2).
  by apply: LFixR_refl.
Qed.

Lemma l_out_in F : l_out F \o l_in F =e id _.
Proof.
  move=>[s k]/=; split=>//= e d1 d2; rewrite (bool_irrelevance d1 d2).
  by apply: LFixR_refl.
Qed.

Definition cata_f F A (g : Alg F A) : Ty (LFix F) -> Ty A
  := fix f x :=
       match x with
       | LFix_in s k => g (existT _ s (comp f k))
       end.

Lemma cata_arr F A (g : Alg F A) :
  forall x y, x =e y -> cata_f g x =e cata_f g y.
Proof.
  move=> x y /=; elim: x => sx kx Ih/= in y *; case: y=> sy ky/= [Es Ek].
  apply/(f_eq g); split=>//= e d1 d2; by apply/Ih.
Qed.

Definition cata F A (g : Alg F A) : arrow (LFix F) A
  := {| func := _; f_eq := cata_arr g |}.

Lemma cata_univ_r F A (g : Alg F A) (f : arrow (LFix F) A)
  : f =e g \o fmapA F f \o @l_out F -> f =e cata g.
Proof.
  move=> H.
  elim=> sx kx /= Ih.
  rewrite (H _)/=; apply/f_eq; rewrite /fmapA_f/=.
  split=>//= e d1 d2.
  rewrite Ih (cont_irr (X:=LFix F) kx).
  by auto with ffix.
Qed.

Lemma cata_univ_l F A (g : Alg F A) (f : arrow (LFix F) A)
  : f =e cata g -> f =e g \o fmapA F f \o @l_out F.
Proof.
  move=> H.
  elim=> sx kx /= Ih.
  rewrite (H _)/=; apply/(f_eq g); rewrite /fmapA_f/=.
  split=>//= e d1 d2.
  rewrite Ih (cont_irr (X:=LFix F) kx).
  rewrite -[cata_f g _]/(cata g _) -(H _) Ih.
  by auto with ffix.
Qed.

Lemma cata_univ F A (g : Alg F A) (f : arrow (LFix F) A)
  : f =e cata g <-> f =e g \o fmapA F f \o @l_out F.
Proof. by split;[apply/cata_univ_l|apply/cata_univ_r]. Qed.

(* Finite anamorphisms *)
Inductive FinF F A (h : CoAlg F A) : A -> Prop :=
| FinF_fold x : (forall e, FinF h (projT2 (h x) e)) -> FinF h x.

Lemma FinF_inv F A (h : CoAlg F A) x
  : FinF h x -> forall e, FinF h (projT2 (h x) e).
Proof. by case. Defined.

(* Finite coalgebras *)
Structure FCoAlg F A :=
  { coalg :> CoAlg F A;
    finite : forall x, FinF coalg x
  }.

Definition ana_f_ F A (h : CoAlg F A) : forall (x : A), FinF h x -> LFix F
  := fix f x H :=
       let hx := h x in
       LFix_in (fun e => f (projT2 hx e) (FinF_inv H e)).

Lemma ana_f_irr F A (h : CoAlg F A)
  : forall (x : A) (F1 F2 : FinF h x), ana_f_ F1 =e ana_f_ F2.
Proof.
  move=>/=; fix Ih 2; move=> x [{}x Fx] F2; move: F2 Fx=> [{}x Fy] Fx/=.
  split=>// e d1 d2; rewrite (bool_irrelevance d2 d1) => {d2}.
  by apply: Ih.
Qed.

Definition ana_f F A (h : FCoAlg F A) : A -> LFix F
  := fun x => ana_f_ (finite h x).

Lemma ana_arr F A (h : FCoAlg F A) :
  forall x y, x =e y -> ana_f h x =e ana_f h y.
Proof.
  rewrite /ana_f; move=> x y; move: x y (finite h x) (finite h y).
  fix Ih 3; move=> x y [x' Fx] [y' Fy]/=; split.
  - by case: (f_eq (coalg h) H).
  - move=> e d1 d2 /=; apply: Ih.
    by move: (f_eq (coalg h) H)=> [E1 /(_ e d1 d2)].
Qed.

Definition ana F A (h : FCoAlg F A) : arrow A (LFix F)
  := {| func := ana_f h; f_eq := ana_arr h |}.

Lemma ana_univ_r F A (h : FCoAlg F A) (f : arrow A (LFix F))
  : f =e @l_in F \o fmapA F f \o coalg h -> f =e ana h.
Proof.
  move=> H; rewrite /ana/ana_f/==>x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite -[LFixR (f x) _]/(eqRel (Eq _) (f x) _) (H _)/=; split=>// e d1 d2.
  rewrite (bool_irrelevance d2 d1); by apply: Ih.
Qed.

Lemma ana_univ_l F A (h : FCoAlg F A) (f : arrow A (LFix F))
  : f =e ana h -> f =e @l_in F \o fmapA F f \o coalg h.
Proof.
  move=> H x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite (H _) /=/ana_f; move: (finite h x)=>Fx'; move: Fx' Fx.
  move=>[{}x Fx'] Fx/=; split=>// e d1 d2.
  rewrite (bool_irrelevance d2 d1).
  rewrite -[LFixR _ _]/(eqRel (Eq _) _ _).
  move: (H (projT2 (coalg h x) (exist _ e d1))); rewrite /ana/ana_f/=.
  rewrite -![LFixR _ _]/(eqRel (Eq _) _ _).
  rewrite ana_f_irr =><-/=; by apply: LFixR_refl.
Qed.

Lemma ana_univ F A (h : FCoAlg F A) (f : arrow A (LFix F))
  : f =e ana h <-> f =e @l_in F \o fmapA F f \o coalg h.
Proof. by split;[apply/ana_univ_l|apply/ana_univ_r]. Qed.

(** Hylomorphisms **)

Definition hylo_f_ F A B (g : Alg F B) (h : CoAlg F A)
  : forall (x : A), FinF h x -> B
  := fix f x H :=
       let hx := h x in
       g (existT (fun sh=> sig (dom sh) -> B)
                 (projT1 hx)
                 (fun e => f (projT2 hx e) (FinF_inv H e))).

Lemma hylo_f_irr F A B (g : Alg F B) (h : CoAlg F A)
  : forall (x : A) (F1 F2 : FinF h x), hylo_f_ g F1 =e hylo_f_ g F2.
Proof.
  move=>/=; fix Ih 2; move=> x [{}x Fx] F2; move: F2 Fx=> [{}x Fy] Fx/=.
  apply/f_eq=>/=; split=>//= e d1 d2; rewrite (bool_irrelevance d2 d1)=>{d2}.
  by apply: Ih.
Qed.

Definition hylo_f F A B (g : Alg F B) (h : FCoAlg F A)
  := fun x => hylo_f_ g (finite h x).

Lemma hylo_arr F A B (g : Alg F B) (h : FCoAlg F A)
  : forall x y, x =e y -> hylo_f g h x =e hylo_f g h y.
Proof.
  rewrite /hylo_f; move=> x y; move: x y (finite h x) (finite h y).
  fix Ih 3; move=> x y [x' Fx] [y' Fy]/= H; apply/f_eq=>/=.
  case: (f_eq (coalg h) H)=>/= Es Ek; split=>//= e d1 d2.
  by apply/Ih/Ek.
Qed.

Definition hylo F A B (g : Alg F B) (h : FCoAlg F A) : arrow A B
  := {| func := _ ; f_eq := hylo_arr g h |}.

Lemma hylo_univ_r F A B (g : Alg F B) (h : FCoAlg F A) (f : arrow A B)
  : f =e g \o fmapA F f \o coalg h -> f =e hylo g h.
Proof.
  move=> H; rewrite /hylo/hylo_f/==>x; move: x (finite h x).
  fix Ih 2; move=> x Fx; rewrite (H _)/=/fmapA_f/=; case: Fx=> {}x Fx/=.
  apply/f_eq => /=; split=>//= e d1 d2.
  by rewrite (bool_irrelevance d2 d1); apply/Ih.
Qed.

Lemma hylo_univ_l F A B (g : Alg F B) (h : FCoAlg F A) (f : arrow A B)
  : f =e hylo g h -> f =e g \o fmapA F f \o coalg h.
Proof.
  move=> H x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite (H _) /=/hylo_f; move: (finite h x)=>Fx'; move: Fx' Fx.
  move=>[{}x Fx'] Fx/=; apply/f_eq; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1) (H _) /=/hylo_f/= hylo_f_irr.
  by eauto with ffix.
Qed.

Lemma hylo_univ F A B (g : Alg F B) (h : FCoAlg F A) (f : arrow A B)
  : f =e hylo g h <-> f =e g \o fmapA F f \o coalg h.
Proof. by split;[apply/hylo_univ_l|apply/hylo_univ_r]. Qed.

Corollary hylo_unr F A B (g : Alg F B) (h : FCoAlg F A)
  : hylo g h =e g \o fmapA F (hylo g h) \o coalg h.
Proof. by rewrite -hylo_univ; reflexivity. Qed.

Lemma fin_out F : forall x, FinF (@l_out F) x.
Proof. by elim=>s k Ih; constructor; apply: Ih. Qed.

Definition f_out F : FCoAlg F (LFix F) :=
  {| coalg := @l_out F; finite := @fin_out F|}.

Lemma hylo_cata F B (g : Alg F B)
  : cata g =e hylo g (f_out F).
Proof. rewrite hylo_univ; apply/cata_univ; reflexivity. Qed.

Lemma hylo_ana F A (h : FCoAlg F A)
  : ana h =e hylo (l_in F) h.
Proof. by rewrite hylo_univ; apply/ana_univ; reflexivity. Qed.

Lemma compA A B C D (f : arrow C D) (g : arrow B C) (h : arrow A B)
  : f \o (g \o h) =e (f \o g) \o h.
Proof. move=>x; by eauto with ffix. Qed.

Lemma idKl A B (f : arrow A B)
  : f \o id A =e f.
Proof. move=> x; by eauto with ffix. Qed.

Lemma idKr A B (f : arrow A B)
  : id B \o f  =e f.
Proof. move=> x; by eauto with ffix. Qed.

Lemma compKl A B C (f : arrow B C) (g1 g2 : arrow A B)
  : g1 =e g2 -> f \o g1 =e f \o g2.
Proof. by move=>->; eauto with ffix. Qed.

Lemma compKr A B C (f1 f2: arrow B C) (g : arrow A B)
  : f1 =e f2 -> f1 \o g =e f2 \o g.
Proof. by move=>->; eauto with ffix. Qed.

Lemma hylo_fusion_l F A B C
      (h1 : FCoAlg F A) (g1 : Alg F B) (g2 : Alg F C) (f2 : arrow B C)
      (E2 : f2 \o g1 =e g2 \o fmapA F f2)
  : f2 \o hylo g1 h1 =e hylo g2 h1.
Proof.
  rewrite hylo_univ fmap_comp.
  rewrite compA -E2 -compA -compA.
  apply/compKl.
  rewrite compA -hylo_univ.
  reflexivity.
Qed.

Lemma hylo_fusion_r F A B C
      (h1 : FCoAlg F B) (g1 : Alg F C) (h2 : FCoAlg F A)
      (f1 : arrow A B) (E1 : h1 \o f1 =e fmapA F f1 \o h2)
  : hylo g1 h1 \o f1 =e hylo g1 h2.
Proof.
  rewrite hylo_univ fmap_comp.
  rewrite -!compA -E1 !compA.
  apply/compKr.
  rewrite -hylo_univ.
  reflexivity.
Qed.

Lemma deforest F A B C
      (h1 : FCoAlg F A) (g1 : Alg F B) (h2 : FCoAlg F B) (g2 : Alg F C)
      (INV: h2 \o g1 =e id _)
  : hylo g2 h2 \o hylo g1 h1 =e hylo g2 h1.
Proof.
  apply/hylo_fusion_l.
  rewrite [in H in H =e _]hylo_unr.
  rewrite -compA INV idKl.
  reflexivity.
  Restart.
  apply/hylo_fusion_r.
  rewrite [in H in H =e _]hylo_unr.
  rewrite compA compA INV idKr.
  reflexivity.
Qed.

Corollary cata_ana_hylo F A B (g : Alg F B) (h : FCoAlg F A)
  : cata g \o ana h =e hylo g h.
Proof. by rewrite hylo_cata hylo_ana; apply/deforest/l_out_in. Qed.

Section ExQsort.

  (* Defining a tree *)
  Inductive Ts A :=
  | Leaf | Node (ELEM : A).
  Inductive Tp := | Lbranch | Rbranch.
  Definition t_dom A (s : Ts A) : Tp -> bool :=
    match s with
    | Node _ => fun=>true
    | _ => fun=> false
    end.
  Definition Tree A :=
    {| Shape := Ts A;
       Position := Tp;
       dom := @t_dom A;
    |}.
  Lemma dom_leaf_false A : {y | t_dom (Leaf A) y} -> False.
  Proof. by move=>[]. Qed.
  Definition dom_leaf A B (x : {y | t_dom (Leaf A) y}) : B :=
    False_rect _ (dom_leaf_false x).

  Definition a_leaf A X : App (Tree A) X := existT _ (Leaf A) (@dom_leaf A _).
  Definition a_node A X (x : A) (l r : X) : App (Tree A) X :=
    existT _ (Node x) (fun p => match proj1_sig p with
                                | Lbranch => l
                                | Rbranch => r
                                end).

  Definition a_out A X (x : App (Tree A) X)
    : option (A * X * X)
    := match x with
       | existT s k =>
         match s return (sig (t_dom s) -> X) -> _ with
         | Leaf => fun=> None
         | Node x =>
           fun k=>
             Some (x,
                   k (exist _ Lbranch is_true_true),
                   k (exist _ Rbranch is_true_true))
         end k
       end.
  (* end tree *)

  Definition m_merge (x : App (Tree nat) (seq nat)) : Ty (seq nat) :=
    match a_out x with
    | None => [::]
    | Some (h, l, r) => l ++ h :: r
    end.
  Lemma m_merge_arr : forall x y, x =e y -> m_merge x =e m_merge y.
  Proof.
    move=>[[|hx]/= kx]/= [[|hy]//= ky] [//= [<-]] H.
    by rewrite /m_merge/= !H.
  Qed.
  Definition merge : Alg (Tree nat) (seq nat)
    := {| func := m_merge; f_eq := m_merge_arr |}.

  Definition m_split (x : Ty (seq nat)) : App (Tree nat) (seq nat) :=
    match x with
    | [::] => a_leaf _ _
    | h :: t => a_node h [seq x <- t | x <= h] [seq x <- t | x > h]
    end.
  Lemma m_split_arr : forall x y, x =e y -> m_split x =e m_split y.
  Proof. by move=> x y ->; eauto with ffix. Qed.
  Definition c_split : CoAlg (Tree nat) (seq nat)
    := {| func := m_split; f_eq := m_split_arr |}.

  (* Needs to be defined, otherwise msort does not reduce! *)
  Lemma split_fin : forall x, FinF c_split x.
  Proof.
    move=>x; move: {-1}(size x) (leqnn (size x))=> n.
    elim: n => [|n Ih] in x *; case: x=> [|h t]/=; eauto=>E; constructor=>/=.
    - by case.
    - by [].
    - move=> [e /=_]; apply/Ih.
      by case: e; rewrite size_filter (leq_trans (count_size _ _)).
  Defined.

  Definition tsplit := {| coalg := c_split; finite := split_fin |}.
  Definition msort : seq nat -> seq nat := func (hylo merge tsplit).
End ExQsort.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlNatInt.
Set Extraction TypeExpand.
Set Extraction Flag 2047.
Extract Inductive sigT => "(*)"  [ "(,)" ].
Extraction Inline Ty.
Extraction Inline Eq.
Extraction Inline func.
Extraction Inline coalg.
Extraction Inline getTy.
Extraction Inline hylo.
Extraction Inline hylo_f.
Extraction Inline hylo_f_.
Extraction Inline projT1.
Extraction Inline projT2.

Extraction Inline merge.
Extraction Inline a_leaf.
Extraction Inline a_node.
Extraction Inline m_merge.
Extraction Inline m_split.
Extraction Inline a_out.
Extraction Inline c_split.
Extraction Inline tsplit.
Recursive Extraction msort.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06

This file provides a specification of finite multiset data-type along
with specification of operations on multisets.
*)

Set Implicit Arguments.

From CoLoR Require RelExtras.
From Coq Require Import Min Relations.

Module Type MultisetCore.

  Declare Module Export Sid : RelExtras.Eqset_dec.

  Parameter Multiset : Type.

  Parameter mult : A -> Multiset -> nat.

  Parameter meq : relation Multiset.

  Parameter empty : Multiset.

  Parameter singleton : A -> Multiset.

  Parameter union : Multiset -> Multiset -> Multiset.

  Parameter intersection : Multiset -> Multiset -> Multiset.

  Parameter diff : Multiset -> Multiset -> Multiset.

  Notation "X =mul= Y" := (meq X Y) (at level 70) : msets_scope.
  Notation "X <>mul Y" := (~meq X Y) (at level 50) : msets_scope.
  Notation "{{ x }}" := (singleton x) (at level 5) : msets_scope.
  Notation "X + Y" := (union X Y) : msets_scope.
  Notation "X - Y" := (diff X Y) : msets_scope.
  Notation "X # Y" := (intersection X Y) (at level 50, left associativity)
                      : msets_scope.
  Notation "x / M" := (mult x M) : msets_scope.

  Delimit Scope msets_scope with msets.
  Open Scope msets_scope.
  Bind Scope msets_scope with Multiset.

  Section Specification.

    Variables (M N P : Multiset) (x y z : A) (n : nat).

    Parameter mult_eqA_compat: x =A= y -> x/M = y/M.

    Parameter meq_multeq: M =mul= N -> (forall x, x/M = x/N).

    Parameter multeq_meq: (forall x, x/M = x/N) -> M =mul= N.

    Parameter empty_mult: x/empty = 0.

    Parameter union_mult: x/(M+N) = (x/M + x/N)%nat.

    Parameter diff_mult: x/(M-N) = (x/M - x/N)%nat.

    Parameter intersection_mult: x/(M#N) = min (x/M) (x/N).

    Parameter singleton_mult_in: x =A= y -> x/{{y}} = 1.

    Parameter singleton_mult_notin: ~x =A= y -> x/{{y}} = 0.

    Parameter mset_ind_type: forall P : Multiset -> Type,
        P empty -> (forall M a, P M -> P (M + {{a}})) -> forall M, P M.

  End Specification.

  Hint Resolve mult_eqA_compat
               meq_multeq
               multeq_meq
               empty_mult
               union_mult
               diff_mult
               intersection_mult
               singleton_mult_in
               singleton_mult_notin : multisets.

  Hint Rewrite empty_mult
               union_mult
	       diff_mult
	       intersection_mult using trivial : multisets.

End MultisetCore.

Section Multiset_IntersectionAsDifference.

  Variables
    (A : Type) (Multiset : Type) (meq : relation Multiset)
    (mult : A -> Multiset -> nat)
    (diff : Multiset -> Multiset -> Multiset)
    (diff_mult : forall M N x, mult x (diff M N) = mult x M - mult x N).

  Definition inter_as_diff x y := diff x (diff x y).

  Lemma inter_as_diff_ok : forall M N x,
    mult x (inter_as_diff M N) = Min.min (mult x M) (mult x N).

  Proof.
    intros M N x. unfold inter_as_diff. rewrite !diff_mult.
    From Coq Require Import Psatz. lia.
  Qed.

End Multiset_IntersectionAsDifference.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Import ListNotations.
Open Scope char_scope.
Require Import Hw5Util.

(* ---------------------------------------------------------------------------*)

(**

Use `yield_def`.

 *)
Theorem yield_eq:
  forall G A w, List.In (A, w) (Hw5Util.grammar_rules G) -> Hw5Util.Yield G [A] w.
Proof.
  simpl.
  intros N.
  intros O.
  intros P.
  intros Q.
  apply yield_def with (u := []) (v := []) (w := P) (A := O).
  - simpl.
    apply Q.
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> app_nil_r.
    reflexivity.
Qed.

(**

Use `yield_def` and `app_assoc` to correct the parenthesis.

 *)
Theorem yield_right:
  forall G w1 w2 r w3 w4, Hw5Util.Yield G w1 w2 -> w3 = w1 ++ r -> w4 = w2 ++ r -> Hw5Util.Yield G w3 w4.
Proof.
  simpl.
  intros N.
  intros O.
  intros P.
  intros Q.
  intros R.
  intros S.
  intros T.
  intros U.
  intros V.
  rewrite -> U.
  rewrite -> V.
  inversion T.
  rewrite -> H0.
  rewrite -> H1.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  apply yield_def with (u := u) (v := v ++ Q) (w := w) (A := A).
  - simpl.
    apply H.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

(**

Similar proof than `yield_right`, but you should rewrite with
`app_assoc` after using `yield_def`, not before.

 *)

Theorem yield_left:
  forall G w1 w2 l w3 w4, Hw5Util.Yield G w1 w2 -> w3 = l ++ w1 -> w4 = l ++ w2 -> Hw5Util.Yield G w3 w4.
Proof.
  simpl.
  intros N.
  intros O.
  intros P.
  intros Q.
  intros R.
  intros S.
  intros T.
  intros U.
  intros V.
  rewrite -> U.
  rewrite -> V.
  inversion T.
  rewrite -> H0.
  rewrite -> H1.
  apply yield_def with (u := Q ++ u) (v := v) (w := w) (A := A).
  - simpl.
    apply H.
  - simpl.
    rewrite -> app_assoc.
    reflexivity.
  - simpl.
    rewrite -> app_assoc.
    reflexivity.
Qed.

(**

Consider using one of the lemmas you have just proved.
When your goal is `In ("C", ...) (grammar_rules g1)`, `simpl; auto`
should solve it.

 *)
Theorem g1_rule_1:
  Hw5Util.Yield g1 ["C"] ["{"; "C"; "}"].
Proof.
  simpl.
  apply yield_def with (u := []) (v := []) (w := ["{"; "C"; "}"]) (A := "C").
  - simpl.
    apply or_introl.
    apply @eq_refl.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

(**

Consider using one of the lemmas you have just proved.
When your goal is `In ("C", ...) (grammar_rules g1)`, `simpl; auto`
should solve it.

 *)
Theorem g1_rule_2:
  Hw5Util.Yield g1 ["C"] ["C"; "C"].
Proof.
  simpl.
  apply yield_def with (u := []) (v := []) (w := ["C"; "C"]) (A := "C").
  - simpl.
    apply or_intror.
    apply or_introl.
    apply @eq_refl.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

(**

Consider using one of the lemmas you have just proved.
When your goal is `In ("C", ...) (grammar_rules g1)`, `simpl; auto`
should solve it.

 *)
Theorem g1_rule_3:
  Hw5Util.Yield g1 ["C"] [].
Proof.
  simpl.
  apply yield_def with (u := []) (v := []) (w := []) (A := "C").
  - simpl.
    apply or_intror.
    apply or_intror.
    apply or_introl.
    apply @eq_refl.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

(**

The proof should proceed by inversion and then case analysis on
string `u`.

 *)
Theorem yield_inv_start:
  forall G w, Hw5Util.Yield G [Hw5Util.grammar_start G] w -> In (Hw5Util.grammar_start G, w) (Hw5Util.grammar_rules G).
Proof.
  simpl.
  intros N.
  intros O.
  intros P.
  inversion P.
  induction u.
  - simpl.
    rewrite -> H1.
    simpl.
    simpl in H0.
    inversion H0.
    subst.
    rewrite -> app_nil_r.
    apply H.
  - simpl.
    induction u.
    + simpl.
      inversion H0.
    + simpl.
      inversion H0.
Qed.

(**

You will want to use `yield_inv_start`. Recall that that `List.In`
simplifies to a series of disjunctions.

 *)
Theorem g1_ex1:
  ~ Hw5Util.Yield g1 ["C"] ["{"].
Proof.
  simpl.
  unfold not.
  intros N.
  apply yield_inv_start in N.
  destruct N.
  - simpl.
    inversion H.
  - simpl.
    unfold In in H.
    inversion H.
    + simpl.
      inversion H0.
    + simpl.
      inversion H0.
      * simpl.
        inversion H1.
      * simpl.
        inversion H1.
Qed.

(**

The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.

 *)
Theorem g1_step_1:
  Hw5Util.Yield g1 ["C"; "C"] ["{"; "C"; "}"; "C"].
Proof.
  simpl.
  apply yield_def with (u := []) (v := ["C"]) (w := ["{"; "C"; "}"]) (A := "C").
(*  apply yield_right with (w1 := ["C"]) (w2 := ["{"; "C"; "}"]) (r := ["C"]).
  apply yield_left with (w1 := ["C"; "C"]) (w2 := ["{"; "C"; "}"; "C"]) (l := []). *)
  - simpl.
(*    apply yield_left with (w1 := ["C"; "C"]) (w2 := ["{"; "C"; "}"; "C"]) (l := []). *)
    apply or_introl.
    apply @eq_refl.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Theorem g1_steap_1: Hw5Util.Yield g1 ["C"; "C"] ["{"; "C"; "}"; "C"].
Proof.
  apply yield_def with (u:=[]) (v:=["C"]) (w:=["{";"C";"}"]) (A:="C").
  - simpl; auto.
  - reflexivity.
  - simpl. reflexivity.
Qed.

(**

The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.

 *)
Theorem g1_step_2:
  Hw5Util.Yield g1 ["{"; "C"; "}"; "C"] ["{"; "}"; "C"].
Proof.
  simpl.
(*  apply yield_right with (w1 := ["{"; "C"]) (w2 := ["{"]) (r := ["}"; "C"]).
  apply yield_left with (w1 := ["C"; "}"; "C"]) (w2 := ["}"; "C"]) (l := ["{"]).  *)
  apply yield_def with (u := ["{"]) (v := ["}"; "C"]) (w := []) (A := "C").
  - simpl.
    apply or_intror.
    apply or_intror.
    apply or_introl.
    apply @eq_refl.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

(**

The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.

 *)
Theorem g1_step_3:
  Hw5Util.Yield g1 ["{"; "}"; "C"] ["{"; "}"; "{"; "C"; "}"].
Proof.
  simpl.
  apply yield_def with (u := ["{"; "}"]) (v := []) (w := ["{"; "C"; "}"]) (A := "C").
  - simpl.
    apply or_introl.
    apply @eq_refl.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

(**

The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.

 *)
Theorem g1_step_4:
  Hw5Util.Yield g1 ["{"; "}"; "{"; "C"; "}"] ["{"; "}"; "{"; "}"].
Proof.
  - simpl.
(*    apply yield_def with (u := ["{"; "}"]) (v := ["}"]) (w := ["{"]) (A := "{"; "C").
    apply yield_right with (w1 := ["{"; "}"; "{"; "C"]) (w2 := ["{"; "}"; "{"]) (r := ["}"]). *)
    apply yield_left with (w1 := ["{"; "C"; "}"]) (w2 := ["{"; "}"]) (l := ["{"; "}"]).
    + simpl.
      apply yield_def with (u := ["{"]) (v := ["}"]) (w := []) (A := "C").
      * simpl.
        apply or_intror.
        apply or_intror.
        apply or_introl.
        apply @eq_refl.
      * simpl.
        reflexivity.
      * simpl.
        reflexivity.
    + simpl.
      reflexivity.
    + simpl.
      reflexivity.
Qed.

(**

Use either `derivation_nil` or `derivation_cons`.

 *)
Theorem g1_der_1:
  Hw5Util.Derivation g1 [["C"]].
Proof.
  simpl.
  apply derivation_nil.
Qed.

(**

Use either `derivation_nil` or `derivation_cons`.

 *)
Theorem g1_der_2:
  Hw5Util.Derivation g1 [["C"; "C"]; ["C"]].
Proof.
  simpl.
  apply derivation_cons.
  - simpl.
    apply derivation_nil.
  - simpl.
    apply yield_def with (u := []) (v := []) (w := ["C"; "C"]) (A := "C").
    + simpl.
      apply or_intror.
      apply or_introl.
      apply @eq_refl.
    + simpl.
      reflexivity.
    + simpl.
      reflexivity.
Qed.

(**

Use either `derivation_nil` or `derivation_cons`.

 *)
Theorem g1_der_3:
  Hw5Util.Derivation g1 [["{"; "C"; "}"; "C"]; ["C"; "C"]; ["C"]].
Proof.
  simpl.
  apply derivation_cons.
  - simpl.
    apply derivation_cons.
    + simpl.
      apply derivation_nil.
    + simpl.
      apply yield_def with (u := []) (v := []) (w := ["C"; "C"]) (A := "C").
      * simpl.
        apply or_intror.
        apply or_introl.
        apply @eq_refl.
      * simpl.
        reflexivity.
      * simpl.
        reflexivity.
  - simpl.
    apply yield_def with (u := []) (v := ["C"]) (w := ["{"; "C"; "}"]) (A := "C").
    + simpl.
      apply or_introl.
      apply @eq_refl.
    + simpl.
      reflexivity.
    + simpl.
      reflexivity.
Qed.

Theorem g1_der_4:
  Hw5Util.Derivation g1 [
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
].
Proof.
  simpl.
  apply derivation_cons.
  - simpl.
    apply derivation_cons.
    + simpl.
      apply derivation_cons.
      * simpl.
        apply derivation_nil.
      * simpl.
        apply yield_def with (u := []) (v := []) (w := ["C"; "C"]) (A := "C").
        -- simpl.
           apply or_intror.
           apply or_introl.
           apply @eq_refl.
        -- simpl.
           reflexivity.
        -- simpl.
           reflexivity.
    + simpl.
      apply yield_def with (u := []) (v := ["C"]) (w := ["{"; "C"; "}"]) (A := "C").
      * simpl.
        apply or_introl.
        apply @eq_refl.
      * simpl.
        reflexivity.
      * simpl.
        reflexivity.
  - simpl.
    apply yield_def with (u := ["{"]) (v := ["}"; "C"]) (w := []) (A := "C").
      + simpl.
      apply or_intror.
      apply or_intror.
      apply or_introl.
      apply @eq_refl.
      + simpl.
        reflexivity.
      + simpl.
        reflexivity.
Qed.

Theorem g1_der_5:
  Hw5Util.Derivation g1 [
    ["{"; "}"; "{"; "C"; "}"];
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
].
Proof.
  simpl.
  apply derivation_cons.
  - simpl.
    apply derivation_cons.
    + simpl.
      apply derivation_cons.
      * simpl.
        apply derivation_cons.
        -- simpl.
           apply derivation_nil.
        -- simpl.
           apply yield_def with (u := []) (v := []) (w := ["C"; "C"]) (A := "C").
           ++ simpl.
              apply or_intror.
              apply or_introl.
              apply @eq_refl.
           ++ simpl.
              reflexivity.
           ++ simpl.
              reflexivity.
      * simpl.
        apply yield_def with (u := []) (v := ["C"]) (w := ["{"; "C"; "}"]) (A := "C").
        -- simpl.
           apply or_introl.
           apply @eq_refl.
        -- simpl.
           reflexivity.
        -- simpl.
           reflexivity.
    + simpl.
      apply yield_def with (u := ["{"]) (v := ["}"; "C"]) (w := []) (A := "C").
      * simpl.
        apply or_intror.
        apply or_intror.
        apply or_introl.
        apply @eq_refl.
      * simpl.
        reflexivity.
      * simpl.
        reflexivity.
  - simpl.
    apply yield_def with (u := ["{"; "}"]) (v := []) (w := ["{"; "C"; "}"]) (A := "C").
    + simpl.
      apply or_introl.
      apply @eq_refl.
    + simpl.
      reflexivity.
    + simpl.
      reflexivity.
Qed.

Theorem g1_der_6:
  Hw5Util.Derivation g1 [
    ["{"; "}"; "{"; "}"];
    ["{"; "}"; "{"; "C"; "}"];
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
].
Proof.
  simpl.
  apply derivation_cons.
  - simpl.
    apply derivation_cons.
    + simpl.
      apply derivation_cons.
      * simpl.
        apply derivation_cons.
        -- simpl.
           apply derivation_cons.
           ++ simpl.
              apply derivation_nil.
           ++ simpl.
              apply yield_def with (u := []) (v := []) (w := ["C"; "C"]) (A := "C").
              ** simpl.
                 apply or_intror.
                 apply or_introl.
                 apply @eq_refl.
              ** simpl.
                 reflexivity.
              ** simpl.
                 reflexivity.
        -- simpl.
           apply yield_def with (u := []) (v := ["C"]) (w := ["{"; "C"; "}"]) (A := "C").
           ++ simpl.
               apply or_introl.
               apply @eq_refl.
           ++ simpl.
              reflexivity.
           ++ simpl.
              reflexivity.
      * simpl.
        apply yield_def with (u := ["{"]) (v := ["}"; "C"]) (w := []) (A := "C").
        -- simpl.
           apply or_intror.
           apply or_intror.
           apply or_introl.
           apply @eq_refl.
        -- simpl.
           reflexivity.
        -- simpl.
           reflexivity.
    + simpl.
      apply yield_def with (u := ["{"; "}"]) (v := []) (w := ["{"; "C"; "}"]) (A := "C").
      * simpl.
        apply or_introl.
        apply @eq_refl.
      * simpl.
        reflexivity.
      * simpl.
        reflexivity.
  - simpl.
     apply yield_def with (u := ["{"; "}"; "{"]) (v := ["}"]) (w := []) (A := "C").
    + simpl.
      apply or_intror.
      apply or_intror.
      apply or_introl.
      apply @eq_refl.
    + simpl.
      reflexivity.
    + simpl.
      reflexivity.
Qed.

(**

Use `g1_der_6`.

 *)
Theorem ex1:
  Accept g1 ["{"; "}"; "{"; "}"].
Proof.
  simpl.
  apply accept_def with (w := ["{"; "}"; "{"; "}"]) (ws := [["{"; "}"; "{"; "C"; "}"]; ["{"; "}"; "C"]; ["{"; "C"; "}"; "C"]; ["C"; "C"]; ["C"]]).
  - simpl.
    apply g1_der_6.
  - simpl.
    apply Forall_cons.
    + simpl.
      apply or_introl.
      apply @eq_refl.
    + simpl.
      apply Forall_cons.
      * simpl.
           apply or_intror.
           apply or_introl.
           apply @eq_refl.
      * simpl.
        apply Forall_cons.
        -- simpl.
           apply or_introl.
           apply @eq_refl.
        -- simpl.
           apply Forall_cons.
           ++ simpl.
              apply or_intror.
              apply or_introl.
              apply @eq_refl.
           ++ simpl.
              apply Forall_nil.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable r_ : Prop.
Variable q_ : Prop.
Variable p_ : Prop.
Variable goal_ : Prop.

Variable initial_model_1 : (p_ /\ (q_ /\ r_)).
Variable goal_ax_2 : ((r_ /\ (p_ /\ q_)) -> goal_).

Theorem and3_3 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(* Calculation for a language with interrupts and (local) state. *)
Require Import List.
Require Import Tactics.

Require Import ZArith.
Local Open Scope Z_scope.

Inductive Expr : Set := Val (n : Z) | Add (e1 e2 : Expr) | Throw | Catch (e h : Expr)
                      | Seqn (e1 e2 : Expr) | Block (e : Expr) | Unblock (e : Expr)
                      | Put (e : Expr) | Get.

Reserved Notation "x ⇓[ i , q ] y" (at level 70, no associativity).
Inductive Status : Set := B | U.

Definition State := Z.

Inductive eval : Expr -> State -> Status -> option (Z * State) -> Prop :=
| eval_val n i p : Val n ⇓[i,p] Some (n,p)
| eval_throw i p : Throw ⇓[i,p] None
| eval_add1 x y n m i q p r : x ⇓[i,p] Some (n,q) -> y ⇓[i,q] Some (m,r)
                              -> Add x y ⇓[i,p] Some (n + m,r)
| eval_add2 x y i p : x ⇓[i,p] None -> Add x y ⇓[i,p] None
| eval_add3 x y n i q p : x ⇓[i,p] Some (n, q) -> y ⇓[i,q] None -> Add x y ⇓[i,p] None
| eval_seq1 x y n v i q p : x ⇓[i,p] Some (n,q) -> y ⇓[i,q] v -> Seqn x y ⇓[i,p] v
| eval_seq2  x y i p : x ⇓[i,p] None -> Seqn x y ⇓[i,p] None
| eval_catch1 x y i p r: x ⇓[i,p] Some r -> Catch x y ⇓[i,p] Some r
| eval_catch2 x y v i p : x ⇓[i,p] None -> y ⇓[i,p] v -> Catch x y ⇓[i,p] v
| eval_block x v i p : x ⇓[B,p] v -> Block x ⇓[i,p] v
| eval_unblock x v i p : x ⇓[U,p] v -> Unblock x ⇓[i,p] v
| eval_int x p : x ⇓[U,p] None
| eval_put1 x n i q p  : x ⇓[i,p] Some (n,q) -> Put x ⇓[i,p] Some (n,n)
| eval_put2 x i p  : x ⇓[i,p] None -> Put x ⇓[i,p] None
| eval_get i p  : Get ⇓[i,p] Some (p,p)
where "x ⇓[ i , q ] y" := (eval x q i y).

Hint Constructors eval.

Inductive Instr : Set := PUSH (n : Z) | ADD | THROW | UNMARK | MARK (h : list Instr)
                       | POP | RESET | BLOCK | UNBLOCK | PUT | GET.

Definition Code := list Instr.

Import ListNotations.

Fixpoint comp' (e : Expr) (c : Code) : Code :=
  match e with
    | Val n => PUSH n :: c
    | Add x y => comp' x (comp' y (ADD :: c))
    | Throw => [THROW]
    | Catch e1 e2 => MARK (comp' e2 c) :: comp' e1 (UNMARK :: c)
    | Seqn e1 e2 => comp' e1 (POP :: comp' e2 c)
    | Block e => BLOCK :: comp' e (RESET :: c)
    | Unblock e => UNBLOCK :: comp' e (RESET :: c)
    | Put e => comp' e (PUT :: c)
    | Get => GET :: c
  end.

Definition comp (e : Expr) : Code := comp' e nil.

Inductive Elem : Set := VAL (n : Z) | HAN (q : State) (c : Code) | INT (s  : Status).

Definition Stack : Set := list Elem.

Inductive Conf : Set := conf (c : Code) (s : Stack) (q : State) (i : Status)
                      | fail (s : Stack) (i : Status).

Notation "⟨ c , s , q , i ⟩" := (conf c s q i).
Notation "⟪ s , i ⟫" := (fail s i ).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
 | vm_push n c s q i : ⟨PUSH n :: c, s, q, i⟩ ==> ⟨ c , VAL n :: s, q, i ⟩
 | vm_push_int n c s q: ⟨PUSH n :: c, s, q, U⟩ ==> ⟪s, U⟫
 | vm_add c s m n p i : ⟨ADD :: c, VAL m :: VAL n :: s,p, i⟩ ==> ⟨c, VAL (n + m) :: s, p, i⟩
 | vm_fail_val  m s i : ⟪VAL m :: s, i⟫ ==> ⟪s, i⟫
 | vm_throw c s p i : ⟨ THROW :: c, s, p, i⟩ ==> ⟪s, i⟫
 | vm_fail_han s h p i : ⟪HAN p h :: s, i⟫ ==> ⟨h,s,p,i⟩
 | vm_unmark c n h q p s i : ⟨UNMARK :: c, VAL n :: HAN q h :: s, p, i⟩ ==> ⟨c, VAL n :: s, p, i⟩
 | vm_mark h c p s i : ⟨MARK h :: c, s, p, i⟩ ==> ⟨c, HAN p h :: s, p, i⟩
 | vm_pop c n s p i : ⟨POP :: c, VAL n :: s, p, i⟩ ==> ⟨c, s, p, i⟩
 | vm_reset c s n p i j : ⟨RESET :: c, VAL n :: INT i :: s, p, j⟩ ==> ⟨c, VAL n :: s, p, i⟩
 | vm_block c s p i : ⟨BLOCK :: c, s, p, i⟩ ==> ⟨c, INT i :: s, p, B⟩
 | vm_block_int c s p : ⟨BLOCK :: c, s, p, U⟩ ==> ⟪s, U⟫
 | vm_unblock c s p i : ⟨UNBLOCK :: c, s, p, i⟩ ==> ⟨c, INT i :: s, p, U⟩
 | vm_fail_int i j s : ⟪INT i :: s, j⟫ ==> ⟪s, i⟫
 | vm_put c n s p i : ⟨PUT :: c, VAL n :: s, p, i⟩ ==> ⟨c, VAL n :: s, n, i⟩
 | vm_get c s p i : ⟨GET :: c, s, p, i⟩ ==> ⟨c, VAL p :: s, p, i⟩
 | vm_get_int c s p : ⟨GET :: c, s, p, U⟩ ==> ⟪s, U⟫
where "x ==> y" := (VM x y).

Hint Constructors VM.

(* Boilerplate to import calculation tactics *)
Module VM <: Machine.
Definition Conf := Conf.
Definition Rel := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

Ltac by_eval := eval_inv (eval).

Theorem spec e P c :  { s p i, ⟨comp' e c , s, p, i⟩ | P s p i} =|>
                        { s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[i,p] Some (n, q) /\ P s p i}
                        ∪ { s p i, ⟪s, i⟫ | e ⇓[i,p] None /\ P s p i}.
Proof.
  intros.
  generalize dependent c.
  generalize dependent P.
  induction e;intros.

   begin
    ({ s p q i n', ⟨c, VAL n' :: s, q, i⟩ | Val n ⇓[i,p] Some (n',q) /\ P s p i} ∪
     { s p i, ⟪s, i⟫ | Val n ⇓[i,p] None /\ P s p i }).
   = {by_eval}
    ({ s p i , ⟨c, VAL n :: s, p, i⟩ |  P s p i} ∪
     { s p , ⟪s, U⟫ | P s p U }).
  <== {apply vm_push}
    ({ s p i, ⟨ PUSH n :: c, s, p, i⟩ | P s p i } ∪
     { s p , ⟪s, U⟫ | P s p U }).
  <== {apply vm_push_int}
    ({ s p i, ⟨ PUSH n :: c, s, p, i⟩ | P s p i } ∪
     { s p, ⟨ PUSH n :: c, s, p, U⟩ | P s p U }).
  = {auto}
    ({ s p i, ⟨ PUSH n :: c, s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Add e1 e2 ⇓[i,p] Some (n,q) /\ P s p i }
    ∪ { s p i , ⟪s, i⟫ | Add e1 e2 ⇓[i,p] None /\ P s p i }) .
  = {by_eval}
    ({s p q r i n m, ⟨c, VAL (n+m) :: s, q, i⟩ | e1 ⇓[i,p] Some (n,r) /\ e2 ⇓[i,r] Some (m,q) /\ P s p i }
    ∪ { s p r n i , ⟪s, i⟫ | e1 ⇓[i,p] Some (n,r) /\ e2 ⇓[i,r] None /\ P s p i }
    ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <== {apply vm_add}
    ({s p q r i n m, ⟨ADD :: c, VAL m :: VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (n,r) /\ e2 ⇓[i,r] Some (m,q) /\ P s p i }
    ∪ { s p r n i , ⟪s, i⟫ | e1 ⇓[i,p] Some (n,r) /\ e2 ⇓[i,r] None /\ P s p i }
    ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <== {apply vm_fail_val}
    ({s p q r i n m, ⟨ADD :: c, VAL m :: VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (n,r) /\ e2 ⇓[i,r] Some (m,q) /\ P s p i }
    ∪ { s p r n i , ⟪VAL n :: s, i⟫ | e1 ⇓[i,p] Some (n,r) /\ e2 ⇓[i,r] None /\ P s p i }
    ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  = { eauto }
    ({s' r q i m, ⟨ADD :: c, VAL m :: s', q, i⟩ | e2 ⇓[i,r] Some (m,q) /\
             (exists s p n, s' = VAL n :: s /\ e1 ⇓[i,p] Some (n, r) /\ P s p i) }
    ∪ { s' r i , ⟪s', i⟫ | e2 ⇓[i,r] None /\
                        (exists s p n, s' = VAL n :: s /\ e1 ⇓[i,p] Some (n,r) /\ P s p i) }
    ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <|= {apply IHe2}
    ({s' r i, ⟨comp' e2 (ADD :: c), s', r, i⟩ | (exists s p n, s' = VAL n :: s /\ e1 ⇓[i,p] Some (n,r) /\ P s p i) }
    ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  = {eauto}
    ({s p r i n, ⟨comp' e2 (ADD :: c), VAL n :: s, r, i⟩ | e1 ⇓[i,p] Some (n,r) /\ P s p i }
    ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <|= { apply IHe1 }
  ({ s p i, ⟨comp' e1 (comp' e2 (ADD :: c)), s, p, i⟩ | P s p i}).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Throw ⇓[i,p] Some (n,q) /\ P s p i} ∪
    { s p i , ⟪s, i⟫ | Throw ⇓[i,p] None /\ P s p i}).
  = {by_eval}
    ({ s p i , ⟪s, i⟫ | P s p i}).
  <== {apply vm_throw}
    ({ s p i , ⟨[THROW], s, p, i⟩ | P s p i}).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Catch e1 e2 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    { s p i , ⟪s, i⟫ | Catch e1 e2 ⇓[i, p] None /\ P s p i }).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    {s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p] None /\ e2 ⇓[i,p] Some (n, q) /\ P s p i } ∪
    { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ e2 ⇓[i,p] None /\ P s p i }).
  = {eauto}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e2 ⇓[i,p] Some (n,q) /\ (e1 ⇓[i,p] None /\ P s p i) } ∪
    { s p i , ⟪s, i⟫ | e2 ⇓[i,p] None /\ (e1 ⇓[i,p] None /\ P s p i) })).
  <|= { apply IHe2 }
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    {s p i, ⟨comp' e2 c, s, p, i⟩ | e1 ⇓[i,p] None /\ P s p i }).
  <== { apply vm_fail_han }
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    {s p i, ⟪HAN p (comp' e2 c) :: s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <== { apply vm_unmark }
    ({s p q i n, ⟨UNMARK :: c, VAL n :: HAN p (comp' e2 c) :: s, q, i⟩ | e1 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    {s p i, ⟪HAN p (comp' e2 c) :: s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  = { eauto }
    ({s' p q i n, ⟨UNMARK :: c, VAL n :: s', q, i⟩ | e1 ⇓[i,p] Some (n,q)
                                                     /\ (exists s, s' = HAN p (comp' e2 c) :: s /\ P s p i )} ∪
    {s' p i, ⟪s', i⟫ | e1 ⇓[i,p] None /\ (exists s, s' = HAN p (comp' e2 c) :: s /\ P s p i) }).
  <|= {apply IHe1}
    ({s' p i, ⟨comp' e1 (UNMARK :: c), s', p, i⟩ | exists s, s' = HAN p (comp' e2 c) :: s /\ P s p i }).
  = {auto}
    ({s p i, ⟨comp' e1 (UNMARK :: c), HAN p (comp' e2 c) :: s, p, i⟩ | P s p i }).
  <== {apply vm_mark}
    ({s p i, ⟨MARK (comp' e2 c) :: comp' e1 (UNMARK :: c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Seqn e1 e2 ⇓[i,p] Some (n,q) /\ P s p i } ∪
    { s p i , ⟪s, i⟫ | Seqn e1 e2 ⇓[i,p] None /\ P s p i }).
  = {by_eval}
    ({s p q i n m r, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p] Some (m,r) /\ e2 ⇓[i,r] Some (n,q) /\ P s p i }
     ∪ { s p i m r , ⟪s,i⟫ | e1 ⇓[i,p] Some (m,r) /\ e2 ⇓[i,r] None /\ P s p i }
     ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  = {eauto}
    ({s r q i n, ⟨c, VAL n :: s, q, i⟩ | e2 ⇓[i,r] Some (n,q) /\ (exists p m, e1 ⇓[i,p] Some (m,r) /\ P s p i) }
     ∪ { s r i , ⟪s, i⟫ | e2 ⇓[i,r] None /\ (exists p m, e1 ⇓[i,p] Some (m, r) /\ P s p i) }
     ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <|= {apply IHe2}
    ({s r i, ⟨comp' e2 c, s, r, i⟩ | exists p m, e1 ⇓[i,p] Some (m,r) /\ P s p i }
     ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  = {eauto}
    ({s p r i m, ⟨comp' e2 c, s, r, i⟩ | e1 ⇓[i,p] Some (m,r) /\ P s p i }
     ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <== {apply vm_pop}
    ({s p r i m, ⟨POP :: comp' e2 c, VAL m :: s, r, i⟩ | e1 ⇓[i,p] Some (m,r) /\ P s p i }
     ∪ { s p i , ⟪s, i⟫ | e1 ⇓[i,p] None /\ P s p i }).
  <|= {apply IHe1}
    ({s p i, ⟨comp' e1 (POP :: comp' e2 c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Block e ⇓[i,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | Block e ⇓[i,p] None /\ P s p i }).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[B,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | e ⇓[B,p] None /\ P s p i } ∪
    { s p, ⟪s, U⟫ | P s p U }).
  <== {apply vm_reset}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, B⟩ | e ⇓[B,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | e ⇓[B,p] None /\ P s p i } ∪
    { s p, ⟪s, U⟫ | P s p U }).
  <== {apply vm_fail_int}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, B⟩ | e ⇓[B,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪INT i :: s, B⟫ | e ⇓[B,p] None /\ P s p i } ∪
    { s p, ⟪s, U⟫ | P s p U }).
  = {eauto}
    ({s' p q i' n, ⟨RESET :: c, VAL n :: s', q, i'⟩ | e ⇓[i',p] Some (n,q) /\
                    (exists s i, i' = B /\ s' = INT i :: s /\ P s p i) } ∪
    { s' p i', ⟪s', i'⟫ | e ⇓[i',p] None /\ (exists s i, i' = B /\ s' = INT i :: s /\ P s p i) } ∪
    { s p, ⟪s, U⟫ | P s p U }).
  <|= {apply IHe}
    ({s' p i', ⟨comp' e (RESET :: c), s', p, i'⟩ |  exists s i, i' = B /\ s' = INT i :: s /\ P s p i }
    ∪  { s p, ⟪s, U⟫ | P s p U }).
  = {auto}
    ({s p i, ⟨comp' e (RESET :: c), INT i :: s, p, B⟩ | P s p i }
    ∪  { s p, ⟪s, U⟫ | P s p U }).
  <== {apply vm_block}
    ({s p i, ⟨BLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i }
    ∪  { s p, ⟪s, U⟫ | P s p U }).
  <== {apply vm_block_int}
    ({s p i, ⟨BLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i } ∪
    {s p, ⟨BLOCK :: comp' e (RESET :: c), s, p, U⟩ | P s p U }).
  = {auto}
    ({s p i, ⟨BLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Unblock e ⇓[i,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | Unblock e ⇓[i,p] None /\ P s p i }).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[U,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | e ⇓[U,p] None /\ P s p i } ∪
    { s p, ⟪s, U⟫ | P s p U }).
  = {eauto}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[U,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | e ⇓[U,p] None /\ P s p i }).
  <== {apply vm_reset}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, U⟩ | e ⇓[U,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪s, i⟫ | e ⇓[U,p] None /\ P s p i }).
  <== {apply vm_fail_int}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, U⟩ | e ⇓[U,p] Some (n,q) /\ P s p i } ∪
    { s p i, ⟪INT i :: s, U⟫ | e ⇓[U,p] None /\ P s p i }).
  = {eauto}
    ({s' p q i' n, ⟨RESET :: c, VAL n :: s', q, i'⟩ | e ⇓[i',p] Some (n, q) /\
                    (exists s i, i' = U /\ s' = INT i :: s /\ P s p i) } ∪
    { s' p i', ⟪s', i'⟫ | e ⇓[i',p] None /\ (exists s i, i' = U /\ s' = INT i :: s /\ P s p i) }).
  <|= {apply IHe}
    ({s' p i', ⟨comp' e (RESET :: c), s', p, i'⟩ |  exists s i, i' = U /\ s' = INT i :: s /\ P s p i }).
  = {auto}
    ({s p i, ⟨comp' e (RESET :: c), INT i :: s, p, U⟩ | P s p i }).
  <== {apply vm_unblock}
    ({s p i, ⟨UNBLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i ⟩ | Put e ⇓[ i, p] Some (n,q) /\ P s p i}
    ∪ {s p i, ⟪s, i ⟫ | Put e ⇓[ i, p] None /\ P s p i}).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, n, i ⟩ | e ⇓[ i, p] Some (n,q) /\ P s p i}
    ∪ {s p i, ⟪s, i ⟫ | e ⇓[ i, p] None /\ P s p i}).
  <== {apply vm_put}
    ({s p q i n, ⟨PUT :: c, VAL n :: s, q, i ⟩ | e ⇓[ i, p] Some (n,q) /\ P s p i}
    ∪ {s p i, ⟪s, i ⟫ | e ⇓[ i, p] None /\ P s p i}).
  <|= {apply IHe}
    ({s p i, ⟨comp' e (PUT :: c), s, p, i ⟩ | P s p i}).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i ⟩ | Get ⇓[ i, p] Some (n,q) /\ P s p i}
     ∪ {s p i, ⟪s, i ⟫ | Get ⇓[ i, p] None /\ P s p i}).
  = {by_eval}
    ({s p i , ⟨c, VAL p :: s, p, i ⟩ | P s p i}
     ∪ {s p , ⟪s, U ⟫ |  P s p U}).
  <== {apply vm_get}
    ({s p i , ⟨GET :: c, s, p, i ⟩ | P s p i}
     ∪ {s p , ⟪s, U ⟫ |  P s p U}).
  <== {apply vm_get_int}
    ({s p i , ⟨GET :: c, s, p, i ⟩ | P s p i}
     ∪ {s p , ⟨GET :: c, s, p, U ⟩ |  P s p U}).
  = {auto}
    ({s p i , ⟨GET :: c, s, p, i ⟩ | P s p i}).
  [].
Qed.


Require Import String Omega List FunctionalExtensionality Ensembles
        Computation ADT ADTRefinement ADTNotation QueryStructureSchema
        BuildADTRefinements QueryQSSpecs InsertQSSpecs EmptyQSSpecs
        QueryStructure GeneralInsertRefinements
        GeneralQueryRefinements SetEq AdditionalLemmas EnsembleListEquivalence.

Lemma EnsembleIndexedListEquivalence_lift_property {heading} {P: @Tuple heading -> Prop} :
  forall (sequence: list (@Tuple heading)) (ensemble: @IndexedTuple heading -> Prop),
    EnsembleIndexedListEquivalence ensemble sequence ->
    ((forall item,
        List.In item sequence -> P item) <->
     (forall item,
        Ensembles.In _ ensemble item -> P (indexedTuple item))).
Proof.
  intros * equiv;
  destruct equiv as [_ [ l' (is_map & _ & equiv) ] ];
  subst.
  setoid_rewrite equiv.
  setoid_rewrite in_map_iff.
  split; intros; firstorder; subst; intuition.
Qed.

Lemma EnsembleIndexedListEquivalence_pick_new_index {heading} :
  forall (ens : Ensemble (@IndexedTuple heading)) seq,
    EnsembleIndexedListEquivalence ens seq ->
    exists bound,
      UnConstrFreshIdx ens bound.
Proof.
  intros * (indexes & equiv) ** .
  destruct_ex; eexists x; eauto.
Qed.

  Lemma EnsembleListEquivalence_Empty :
    forall qsSchema Ridx,
      EnsembleListEquivalence
        (GetUnConstrRelation (DropQSConstraints (QSEmptySpec qsSchema))
                             Ridx) [].
  Proof.
    intros; rewrite GetRelDropConstraints; simpl; split; simpl; intros;
    unfold GetRelation, In in *.
    + econstructor.
    + rewrite Build_EmptyRelation_IsEmpty in *; simpl in *; intuition.
  Qed.

  Lemma EnsembleIndexedListEquivalence_Empty :
    forall qsSchema Ridx,
      EnsembleIndexedListEquivalence
        (GetUnConstrRelation (DropQSConstraints (QSEmptySpec qsSchema))
                             Ridx) [].
  Proof.
    intros; rewrite GetRelDropConstraints; simpl; split; simpl; intros;
    unfold GetRelation, In in *.
    + rewrite Build_EmptyRelation_IsEmpty in *; simpl in *; intuition.
      exists 0; unfold UnConstrFreshIdx; intros; intuition.
    + eexists []; intuition; econstructor.
      - econstructor.
      - unfold In; split; intros.
        * rewrite Build_EmptyRelation_IsEmpty in *; simpl in *; intuition.
        * intuition.
  Qed.

Ltac implement_empty_list constrName RepAbsR :=
  hone constructor constrName;
  [ unfold RepAbsR, DropQSConstraints_AbsR;
    repeat setoid_rewrite refineEquiv_pick_ex_computes_to_and;
    repeat setoid_rewrite refineEquiv_pick_eq';
    simplify with monad laws;
    repeat rewrite refineEquiv_pick_pair;
    repeat (rewrite refine_pick_val;
            [simplify with monad laws
            | apply EnsembleIndexedListEquivalence_Empty]);
        subst_body; higher_order_1_reflexivity
  | ].

(*Tactic Notation "implement" "using" "lists" "under" constr(Rep_AbsR) :=
    let AbsR_Hyp := fresh in
    pose Rep_AbsR as AbsR_Hyp;
      unfold Rep_AbsR in AbsR_Hyp;
      hone representation using AbsR_Hyp;
      repeat match goal with
                 |- context[
                        (const ?R ( _ : _ ) : rep :=
                           { _ | exists _, _ })%consDef] =>
                 implement_empty_list R AbsR_Hyp
             end;
      repeat
        match goal with
            |- context [ (meth ?R ( _ : rep , _ : _ ) : _ :=
                            {nr' | forall or , _ } )%methDef] =>
            first [ implement insert in R with lists under AbsR_Hyp
                  | implement query in R with lists under AbsR_Hyp ]
        end.
*)


(*Theorem DivergesAt_Transfer:
		forall n lookahead against matched,
			MatchFrontAlign lookahead matched
			-> MatchFrontAlign against matched
			-> n < length lookahead
			-> ~(EqDivergesAt lookahead against n).
	Proof.
intros ?; induction n; intros ? ?.

intros ? HFAlm HFAam HL [HTA HD];
do 2 rewrite -> skipn_O in *; do 2 rewrite -> firstn_O in *;
inversion HD.

inversion HFAlm; inversion HFAam; solve_crush; subst.
clear HL.
injection H3; intros; subst; clear H3.

injection H8; injection H4; injection H9; intros; subst;
clear H8; clear H4; clear H9; rename t into t1; rename u into t2; rename u0 into u; rename lt into lt1; rename lu into lt2; rename lu0 into lu.

rewrite <- H0 in HL; simpl in HL; inversion HL.

specialize (match_requires_equivalance H6 H2) as HE.
apply H in HE; assumption.

intros ? HFAlm HFAam HL [HTA HD].
inversion HFAlm; inversion HFAam; solve_crush; subst.
try solve [inversion HD].
injection H6; intros; subst; clear H6.
simpl in *.
rename lt into lookahead.
rename lt0 into against.
rename lu into matched.
apply lt_S_n in HL.
apply (IHn lookahead against matched); solve_assumption.
unfold EqDivergesAt; unfold DivergesAt; split; solve_assumption.
inversion HTA; solve_assumption.
	Qed.*)

(*Theorem Equivalent_TotalAlign:
	forall lt1 lt2,
		EqTotalAlign lt1 lt2
		-> (forall lu, MatchTotalAlign lt1 lu <-> MatchTotalAlign lt2 lu).
Proof.
	intros ? ? HEA; split; generalize dependent lu;
	induction HEA as [| t1 t2]; intros [| u] HMA;
	inversion HMA; try solve [constructor];
	specialize (equivalence_implies_match t1 t2) as [HM _];
	specialize (HM H u) as [];
	match goal with
	| M: Match ?t1 u, H: Match ?t1 u -> Match ?t2 u
	|- MatchTotalAlign (?t2 :: _) _ =>
		specialize (H M) as ?; apply TotalAlign_cons; solve_assumption;
		apply IHHEA; assumption
	end.
Qed.
Theorem TotalAlign_Equivalent:
	forall lu lt1 lt2,
		MatchTotalAlign lt1 lu
		-> MatchTotalAlign lt2 lu
		-> EqTotalAlign lt1 lt2.
Proof.
	intros ?; induction lu as [| u]; intros ? ? HE1 HE2;
	inversion HE1; inversion HE2;
	try solve [constructor]; try solve [discriminate];
	subst; apply TotalAlign_cons;
	try match goal with
	| M1: Match ?t1 u, M2: Match ?t2 u |- _ =>
		apply (match_requires_equivalance M1 M2)
	end;
	apply IHlu; assumption.
Qed.*)

(*Theorem TotalAlign_transfer:
	forall T CA CB,
		(forall a b, CA a b <-> CB a b) ->
		forall lta ltb, @TotalAlign T T CA lta ltb <-> @TotalAlign T T CB lta ltb.
Proof.
split; generalize dependent ltb;
induction lta; intros ltb; induction ltb;
intros HCA; try apply TotalAlign_nil; try inversion HCA; subst;

apply TotalAlign_cons; crush.
apply H; crush.
Qed.

an interesting idea for matching: if a list extends a smaller one, then it is contradictory to say that the smaller one matches but the bigger one doesn't. this could be the crux of what it means for something to "lookahead".

Definition TokenDefinition := String.string.
Definition Token := String.string.

Definition TokenMatches (def: TokenDefinition) (token: Token): Prop := def = token.
Hint Unfold TokenMatches: core.
Definition TokenMatchesBool def token :=
	{TokenMatches def token} + {~(TokenMatches def token)}.
Obligation Tactic := crush.
Program Definition match_token def token: TokenMatchesBool def token :=
	Reduce (String.string_dec def token).

Definition TokenDefinitionsSame (a b: TokenDefinition): Prop := a = b.
Hint Unfold TokenDefinitionsSame: core.
Definition TokenDefinitionsEquivalent (a b: TokenDefinition): Prop :=
	forall token, TokenMatches a token <-> TokenMatches b token.
Hint Unfold TokenDefinitionsEquivalent: core.

Ltac token_unfold :=
	unfold TokenDefinitionsEquivalent in *;
	unfold TokenDefinitionsSame in *;
	unfold TokenMatches in *.

Theorem TokenDefinitionsSameEquivalent:
	forall a b, TokenDefinitionsSame a b <-> TokenDefinitionsEquivalent a b.
Proof. split; token_unfold; crush. Qed.
Hint Rewrite TokenDefinitionsSameEquivalent: core.

Definition TokenPath := list TokenDefinition.
Definition TokenStream := list Token.

Definition TokenPathsSame a b :=
	@TotalAlign TokenDefinition TokenDefinition TokenDefinitionsSame a b.
Hint Unfold TokenPathsSame: core.
Definition TokenPathsEquivalent a b :=
	@TotalAlign TokenDefinition TokenDefinition TokenDefinitionsEquivalent a b.
Hint Unfold TokenPathsEquivalent: core.

Ltac path_unfold :=
	unfold TokenPathsEquivalent in *;
	unfold TokenPathsSame in *;
	token_unfold.

Theorem TokenPathsSameEquivalent:
	forall a b, TokenPathsSame a b <-> TokenPathsEquivalent a b.
Proof.
	split; apply (@TotalAlign_transfer TokenDefinition TokenDefinitionsSame TokenDefinitionsEquivalent TokenDefinitionsSameEquivalent).
Qed.
Hint Rewrite TokenPathsSameEquivalent: core.

Definition PathMatchesStream path stream :=
	@TotalAlign TokenDefinition Token TokenMatches path stream /\ path <> [].
Hint Unfold PathMatchesStream: core.

		(*| [ H: TokenMatches _ _ |- _ ] =>*)
			(*token_unfold; crush*)
Ltac invert_PathMatchesStream :=
	crush; repeat match goal with
		| [ H: PathMatchesStream _ _ |- _ ] =>
			inversion H; clear H; crush
		| [ H: @TotalAlign _ _ _ _ _ |- _ ] =>
			inversion H; clear H; crush
	end.

Theorem PathMatchesStream_path_not_empty:
	forall stream, ~(PathMatchesStream [] stream).
Proof. invert_PathMatchesStream. Qed.
Hint Resolve PathMatchesStream_path_not_empty: core.

Theorem PathMatchesStream_stream_not_empty:
	forall path, ~(PathMatchesStream path []).
Proof. destruct path; invert_PathMatchesStream. Qed.
Hint Resolve PathMatchesStream_stream_not_empty: core.

Theorem PathMatchesStream_same_length:
	forall path stream, PathMatchesStream path stream -> length path = length stream.
Proof. intros ? ? [->%TotalAlign_same_length]; easy. Qed.

Theorem PathMatchesStream_length_non_zero:
	forall path stream, PathMatchesStream path stream -> 0 <> (length path) /\ 0 <> (length stream).
Proof. invert_PathMatchesStream. Qed.
Hint Resolve PathMatchesStream_length_non_zero: core.

Theorem PathMatchesStream_same_if_match_same_aux :
	forall path stream, PathMatchesStream path stream -> path = stream.
Proof. intros ? ? H. induction H; crush. Qed.

Theorem PathMatchesStream_same_if_match_same:
	forall a b stream,
		PathMatchesStream a stream
		-> PathMatchesStream b stream
		-> a = b.
Proof.
	intros ? ? ? ->%PathMatchesStream_same_if_match_same_aux ->%PathMatchesStream_same_if_match_same_aux.
Qed.

Definition PathSameStartAs (smaller bigger: TokenPath): Prop :=
	smaller <> [] -> bigger <> []
	-> forall stream, PathMatchesStream smaller stream -> PathMatchesStream bigger stream.
Hint Unfold PathSameStartAs: core.

Check PathSameStartAs.

Theorem PathSameStartAs_always_when_same:
	forall a b, a = b -> a <> [] -> PathSameStartAs a b.
Proof. crush. Qed.
Hint Resolve PathSameStartAs_always_when_same: core.

Theorem PathSameStartAs_if_not_then_not_same:
	forall smaller bigger, (~PathSameStartAs smaller bigger) -> smaller <> bigger.
Proof. crush. Qed.
Hint Resolve PathSameStartAs_if_not_then_not_same: core.

(*H: forall stream: TokenStream,
			PathMatchesStream
				(a :: smaller) stream ->
			PathMatchesStream [] stream*)

Theorem PathSameStartAs_B_longer_equal_A:
	forall smaller bigger,
		PathSameStartAs smaller bigger -> length smaller <= length bigger.
Proof.
	unfold PathSameStartAs in *. intros.
	induction smaller.
	- induction bigger; crush.
	- induction bigger.
		+ simpl in *.  apply (IHsmaller H).  rewrite (Nat.nle_succ_0 (length t0)).

			apply <- PathMatchesStream_path_not_empty in H.  apply Nat.nle_succ_0 in IHA.
		+
Qed.

Definition PathSubsumedBy (A B: TokenPath): Prop := PathSameStartAs A B /\ ~(PathSameStartAs B A).

Inductive BaseModifier: Set :=
	(*| Many*)
	| Maybe
	(*| MaybeMany*)
.
Definition Modifier := option BaseModifier.

Definition ModifierOptional (modifier: Modifier): Prop := modifier = Some Maybe.
Definition ModifierOptionalBool modifier :=
	{ModifierOptional modifier} + {~(ModifierOptional modifier)}.
Obligation Tactic := crush.
Program Definition Modifier_optional modifier: ModifierOptionalBool modifier :=
	match modifier with
	| Some m => match m with
		(*| Many => No*)
		| Maybe => Yes
		(*| MaybeMany => Yes*)
		end
	| None => No
	end.

Inductive Node: Type :=
	| consume (modifier: Modifier) (defs: NonEmpty TokenDefinition)
.
Definition Node_modifier (node: Node): Modifier :=
	match node with
	| consume modifier _ => modifier
	end.
Hint Unfold Node_modifier: core.

Inductive NodeMatchesStream: Node -> TokenStream -> Prop :=
	| NodeMatchesStream_consume_required: forall modifier defs stream,
		PathMatchesStream (listOf defs) stream
		-> NodeMatchesStream (consume modifier defs) stream
	| NodeMatchesStream_consume_optional: forall modifier defs,
		ModifierOptional modifier
		-> NodeMatchesStream (consume modifier defs) []
.
Hint Constructors NodeMatchesStream: core.

Theorem Node_non_optional_stream_not_empty:
	forall node stream,
		~(ModifierOptional (Node_modifier node))
		-> NodeMatchesStream node stream
		-> stream <> [].
Proof. intros n s r ma. inversion ma; crush; inversion H. Qed.
Hint Resolve Node_non_optional_stream_not_empty: core.

Theorem Node_non_optional_length_non_zero:
	forall node stream,
		~(ModifierOptional (Node_modifier node))
		-> NodeMatchesStream node stream
		-> 0 < (length stream).
Proof. intros n s r ma. inversion ma; inversion H; crush. Qed.
Hint Resolve Node_non_optional_stream_not_empty: core.

Inductive NodeListMatchesStream: list Node -> TokenStream -> Prop :=
	| NodeListMatchesStream_base: forall node stream,
		NodeMatchesStream node stream
		-> NodeListMatchesStream [node] stream
	| NodeListMatchesStream_append: forall node stream nodes streams,
		NodeMatchesStream node stream
		-> NodeListMatchesStream nodes streams
		-> NodeListMatchesStream (node :: nodes) (app stream streams)
.
Hint Constructors NodeListMatchesStream: core.

(*what's maybe more interesting here is that if you add a non-optional node to any list of nodes, the length of the match will only increase and not merely remain the same*)

Theorem Node_add_non_optional_increases_match_length:
	forall node stream nodes streams,
		~(ModifierOptional (Node_modifier node))
		-> NodeListMatchesStream (node :: nodes) (app stream streams)
		-> (length streams) < (length (stream ++ streams)).
Proof.
	intros n s ns ss r ma. inversion ma; crush. inversion H2; crush. inversion H; crush.
Qed.
*)

	(*
	Definition list_extends bigger smaller :=
		exists extension: list T, extension <> [] /\ bigger = smaller ++ extension.
	Hint Unfold list_extends: core.

	Theorem TotalAlign_extends_longer:
		forall bigger smaller, list_extends bigger smaller
			-> length smaller < length bigger.
	Proof.
		intros ? ? [extension []]; subst;
		induction smaller; destruct extension; crush.
	Qed.

	Theorem TotalAlign_extends_aligns_longer:
		forall bigger smaller smaller_align bigger_align,
			list_extends bigger smaller
			-> TotalAlign smaller smaller_align
			-> TotalAlign bigger bigger_align
			-> length smaller_align < length bigger_align.
	Proof.
		intros ? ? ? ? extends HS HB;
		rewrite <- (TotalAlign_same_length HS);
		rewrite <- (TotalAlign_same_length HB);
		apply TotalAlign_extends_longer; exact extends.
	Qed.

	Theorem FrontAlign_extends:
		forall bigger smaller aligned,
			list_extends bigger smaller
			-> FrontAlign bigger aligned
			-> FrontAlign smaller aligned.
	Proof.
		intros ? ? ? [extension [_ HB]] HM;
		apply (FrontAlign_shorter _ _ HB HM).
	Qed.

	Definition TotalAlign_contains bigger smaller :=
		(forall lu, TotalAlign smaller lu -> TotalAlign bigger lu)
		/\ exists lu, TotalAlign bigger lu /\ ~(TotalAlign smaller lu).
	Hint Unfold TotalAlign_contains: core.

	Theorem TotalAlign_extends_equivalent_contains:
		forall smaller bigger,
			list_extends smaller bigger <-> TotalAlign_contains smaller bigger.
	Proof.
		unfold list_extends in *; unfold TotalAlign_contains in *.
split.

-
intros [extension []].
subst.
split.
	Qed.*)

(*Theorem ListsMatch_portion_ListsCorrespond:
	forall lt lu,
		ListsMatch lt lu
		-> exists lu_corr lu_ext,
			lu = lu_corr ++ lu_ext /\ ListsCorrespond lt lu_corr.
Proof.
	intros ? ? HM;
	exists (firstn (length lt) lu); exists (skipn (length lt) lu); split;
	try solve [symmetry; apply (firstn_skipn (length lt) lu)];
	induction HM; crush.
Qed.*)

(*|
	HL: length ?lt_one = length ?lu_one,
	HC: ListsCorrespond (?lt_one ++ ?lt_two) (?lu_one ++ ?lu_two)
|- _ =>
	let F := fresh "F" in
	assert (F: length lt_two = length lu_two)
		by apply (ListsCorrespond_split_lengths lt_one lu_one lt_two lu_two HC), HL;
	solve [discriminate F]
|
	HL: length ?lt_two = length ?lu_two,
	HC: ListsCorrespond (?lt_one ++ ?lt_two) (?lu_one ++ ?lu_two)
|- _ =>
	let F := fresh "F" in
	assert (F: length lt_two = length lu_two)
		by apply (ListsCorrespond_split_lengths lt_one lu_one lt_two lu_two HC), HL;
	solve [discriminate F]*)

(*
Fixpoint ListsCorrespondComp {T U: Type} (C: T -> U -> Prop) (lt: list T) (lu: list U): Prop :=
	match lt, lu with
	| [], [] => True
	(*| [t], [u] => C t u*)
	| (t :: lt'), (u :: lu') => C t u /\ ListsCorrespondComp C lt' lu'
	| _, _ => False
	end.
Hint Unfold ListsCorrespondComp: core.

Theorem ListsCorrespond_equivalent:
	forall T U C lt lu, @ListsCorrespond T U C lt lu <-> @ListsCorrespondComp T U C lt lu.
Proof.
	split;
	generalize dependent lu;
	induction lt; intros lu H; induction lu; inversion H; crush.
Qed.
Hint Rewrite ListsCorrespond_equivalent: core.
*)

(*Theorem PathMatchesStream_hnmn:
	forall path stream, path <> [] -> ~(PathMatchesStream path stream -> PathMatchesStream [] stream).
Proof.
	intros . unfold not in *. intros. apply H.  invert_PathMatchesStream.
Qed.*)

(*Theorem PathSameStartAs_nothing_smaller_than_empty:
	forall smaller, ~(PathSameStartAs smaller []).
Proof.
	intros. unfold not, PathSameStartAs. intros. apply (PathMatchesStream_hnmn H). destruct smaller.
- crush.
-  intros.
Qed.*)

(*Theorem PathSameStartAs_path_not_empty:
	forall path, ~(PathSameStartAs [] path).
Proof.
	intros. unfold PathSameStartAs. unfold not. intros.
	destruct path.
- destruct stream.
	+
	+ apply PathMatchesStream_path_not_empty with (stream := stream). apply H.
-

	apply PathMatchesStream_path_not_empty with (stream := stream). apply H.

	destruct path.
- apply PathMatchesStream_path_not_empty with (stream := []). apply H. contradiction.
- apply PathMatchesStream_path_not_empty with (stream := stream). apply H0.

Qed.*)

(*Theorem matching_streams_never_match_against_empty:
	forall A stream, A <> [] -> ~(PathMatchesStream A stream -> PathMatchesStream [] stream).
Proof.
	intros. unfold not. intros. destruct A.
	- contradiction.
	- apply PathMatchesStream_path_not_empty in H0. contradiction.  crush.
	intros A. induction A.
	- intros. unfold not. intros. crush. rewrite <- PathMatchesStream_path_not_empty.
	-
Qed.*)

Definition ModifierMany (modifier: Modifier): Prop := modifier = Some Many /\ modifier = Some MaybeMany.
Definition ModifierManyBool :=
	{ModifierMany modifier} + {~(ModifierMany modifier)}.
Obligation Tactic := crush.
Program Definition Modifier_many modifier: ModifierManyBool modifier :=
	match modifier with
	| Some m => match m with
		| Many => Yes
		| Maybe => No
		| MaybeMany => Yes
		end
	| None => No
	end.

(*
| ConsumeMatchesStream_many_consume: forall modifier defs stream,
		ModifierMany modifier
		-> PathMatchesStream (listOf defs) stream
		-> ConsumeMatchesStream (consume modifier defs) (app stream stream)
*)

Inductive PathMatches: TokenPath -> TokenStream -> TokenStream -> Prop :=
	| PathMatches_base: forall def token,
		TokenMatchesProp def token
		-> forall remainder, PathMatches [def] (token :: remainder) [token]
	| PathMatches_append: forall def token,
		TokenMatchesProp def token
		-> forall path stream remainder, PathMatches path (stream ++ remainder)%list stream
		-> PathMatches (def :: path) (token :: (stream ++ remainder)%list) (token :: stream)
.
Hint Constructors PathMatches: core.

(*Inductive PathMatchesFront: TokenPath -> TokenStream -> TokenStream -> Prop :=
	| PathMatchesFront_all: forall path stream,
		PathMatches path stream
		-> forall remainder, PathMatchesFront path (stream ++ remainder) stream
.*)

Inductive Node: Type :=
	| Consume (modifier: Modifier) (defs: NonEmpty TokenDefinition)
	(*| Or (modifier: Modifier) (choices: NonLone (NonEmpty Node))*)
	(*| Subrule (modifier: Modifier) (rule_name: string)*)
	(*| MacroCall (modifier: Modifier) (macro_name: string) (args: NonEmpty (NonEmpty Node))*)
	(*| Var (modifier: Modifier) (arg_name: string)*)
	(*| LockingVar (modifier: Modifier) (locking_arg_name: string)*)
	(*| Paren (modifier: BaseModifier) (nodes: NonLone Node)*)
.

(*Inductive GrammarItem: Type :=
	| TokenDef (name: string)
	| Rule (name: string) (definition: NonEmpty Node) (locking_args: list LockingArg)
	| Macro (name: string) (args: NonEmpty Arg) (definition: NonEmpty Node) (locking_args: list LockingArg)
	| VirtualLexerUsage (name path: string) (args: Regex?) (exposed_tokens: list string)
.*)

(*Fixpoint compute_lookahead (target against: TokenPath): Lookahead target against := .*)

(*
Inductive TokensMatchProp: list TokenDefinition -> list Token -> Prop :=
	| TokensMatchProp_base:
		forall def token, TokenMatchesProp def token
			-> TokensMatchProp [def] [token]
	| TokensMatchProp_append: forall defs tokens def token,
		TokensMatchProp defs tokens
		-> TokenMatchesProp def token
			-> TokensMatchProp (def :: defs) (token :: tokens)
.
Hint Constructors TokensMatchProp: core.
Definition TokensMatch defs tokens :=
	{TokensMatchProp defs tokens} + {~(TokensMatchProp defs tokens)}.
*)

(*
Theorem TokensMatchProp_same_not_empty:
	forall defs tokens, TokensMatchProp defs tokens -> defs <> [] /\ tokens <> [].
Proof.
	intros d t m. induction m; crush.
Qed.
Hint Resolve TokensMatchProp_same_not_empty: core.
Theorem TokenMatchesProp_not_if_empty:
	forall defs tokens, defs = [] \/ tokens = [] -> ~(TokensMatchProp defs tokens).
Proof.
	intros d t [dn|tn] m; induction m; crush.
Qed.
Hint Resolve TokenMatchesProp_not_if_empty: core.
*)

(*
Definition match_tokens: forall defs tokens, TokensMatch defs tokens.
	refine (fix match_tokens_recursive defs tokens: TokensMatch defs tokens :=
		match defs, tokens with
		| [def], [token] => Reduce (match_token def token)
		| def :: defs', token :: tokens' => if match_token def token
			then Reduce (match_tokens_recursive defs' tokens')
			else No
		| _, _ => No
		end
	); try (apply TokensMatchProp_base; crush); try (intros m; inversion m; crush).
	-
Defined.

Record Consume: Type := consume {
	tokens: NonEmpty TokenDefinition,
}.
*)


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 O E Eprime X Y XY XMY : Universe, ((wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E X /\ (col_ O E Y /\ (col_ O E XMY /\ col_ O E XY)))))) -> col_ XY O XMY)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus lv0 lv1)) (plus lv0 (Succ lv1))).
Admitted.
QuickChick conj12synthconj4.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Monad.

Context `{M : C ⟶ C}.

Class Monad := {
  ret {x}  : x ~> M x;          (* Id    ⟹ M *)
  join {x} : M (M x) ~> M x;    (* M ○ M ⟹ M *)

  fmap_ret {x y} (f : x ~> y) : ret ∘ f ≈ fmap f ∘ ret;

  join_fmap_join {x} : join ∘ fmap (@join x) ≈ join ∘ join;
  join_fmap_ret  {x} : join ∘ fmap (@ret x) ≈ id;
  join_ret       {x} : join ∘ @ret (M x) ≈ id;

  (* This law states that join is a natural transformation from [fmap . fmap]
     to [fmap]. *)
  join_fmap_fmap {x y} (f : x ~> y) :
    join ∘ fmap (fmap f) ≈ fmap f ∘ join
}.

End Monad.

Notation "ret[ M ]" := (@ret _ M _ _)
  (at level 9, format "ret[ M ]") : category_scope.
Notation "join[ M ]" := (@join _ M _ _)
  (at level 9, format "join[ M ]") : category_scope.

Section MonadLib.

Context `{@Monad C M}.

Definition bind {x y : C} (f : x ~> M y) : M x ~> M y :=
  join ∘ fmap[M] f.

End MonadLib.

Notation "m >>= f" := (bind f m) (at level 42, right associativity) : morphism_scope.
Notation "f >> g" := (f >>= fun _ => g)%morphism
  (at level 81, right associativity) : morphism_scope.

Require Import Category.Construction.Opposite.
Require Import Category.Functor.Opposite.

Definition Comonad `{M : C ⟶ C} := @Monad (C^op) (M^op).


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Export Coq.Classes.RelationPairs.
Require Import Coq.Setoids.Setoid.

(** * Interface *)

(** Lenses are identified by the corresponding projection, which is
  also used to define the [get] operation. Note that because we use
  the letter [S] to denote the source type, which conflicts with the
  successor function on [nat] from the standard library, we need to
  use a verbose style below to avoid arguments being named [S0] or
  something such. (This is an obvious software engineering quirk
  with the way Coq generates identifier.) *)

Class LensOps {S V: Type} (π: S -> V) := {
  set: V -> S -> S
}.

Arguments set {S V} π {_} _ _ : simpl never.

Class LensSetGet {S V} π
  `{lens_ops: LensOps S V π} :=
{
  lens_set_get s:
    set π (π s) s = s
}.

Class LensGetSet {S V} π
  `{lens_ops: LensOps S V π} :=
{
  lens_get_set v s:
    π (set π v s) = v
}.

Class LensSetSet {S V} π
  `{lens_set: LensOps S V π} :=
{
  lens_set_set u v s:
    set π u (set π v s) = set π u s
}.

Class Lens {S V} π `{lens_ops: LensOps S V π} := {
  lens_lens_set_get :> LensSetGet π;
  lens_lens_get_set :> LensGetSet π;
  lens_lens_set_set :> LensSetSet π
}.

(** * Theory *)

(** ** Getters are measures, cf. [Coq.Classes.RelationPairs] *)

Instance lens_get_measure {S V} `{LensOps S V}:
  Measure (π).

(** ** The [modify] operation *)

Section MODIFY.
  Context {S V π} `{HSV: Lens S V π}.

  Definition modify (f: V -> V) (s: S) :=
    set π (f (π s)) s.

  Lemma lens_unfold_modify f s:
    modify f s = set π (f (π s)) s.
  Proof.
    reflexivity.
  Qed.
End MODIFY.

Arguments modify {S V} π {_} _ _.

(** ** The [same_context] relation *)

Section SAMECONTEXT.
  Context {S V π} `{lens_ops: LensOps S V π} `{HSV: LensSetSet S V π}.

  Definition same_context: relation S :=
    fun s t => forall v, set π v s = set π v t.

  Lemma lens_set_same_context v s:
    same_context (set π v s) s.
  Proof.
    intro u.
    apply lens_set_set.
  Qed.

  Lemma lens_modify_same_context f s:
    same_context (modify π f s) s.
  Proof.
    intro u.
    unfold modify.
    apply lens_set_set.
  Qed.

  Global Instance same_context_equiv: Equivalence same_context.
  Proof.
    split.
    * intros s v.
      reflexivity.
    * intros s t Hst u.
      symmetry; now auto.
    * intros s1 s2 s3 H12 H23 u.
      transitivity (set π u s2); now auto.
  Qed.

  Global Instance same_context_set_mor:
    Proper (eq ==> same_context ==> eq) (set π).
  Proof.
    intros u v Huv s t Hst.
    subst.
    apply Hst.
  Qed.

  Global Instance same_context_modify_mor f:
    Proper (same_context ==> same_context) (modify π f).
  Proof.
    intros s t Hst u.
    unfold modify.
    rewrite !lens_set_set.
    apply Hst.
  Qed.
End SAMECONTEXT.

Arguments same_context {S V} π {_} _ _.

(** ** Consequences of [LensGetSet] *)

Section GETSET.
  Context {S V} `{Hgs: LensGetSet S V}.

  Lemma lens_get_modify f s:
    π (modify π f s) = f (π s).
  Proof.
    apply lens_get_set.
  Qed.

  Theorem lens_eq_set (s: S) (u v: V):
    set π u s = set π v s <-> u = v.
  Proof.
    split; intros.
    * rewrite <- (lens_get_set u s).
      rewrite <- (lens_get_set v s).
      apply f_equal.
      assumption.
    * apply (f_equal (fun x => set π x s)).
      assumption.
  Qed.
End GETSET.

(** ** Consequences of [LensSetGet] *)

Section SETGET.
  Context {S V} `{HSV: LensSetGet S V}.

  (* same_context ∧ (eq @@ π) ⇔ eq *)
  Lemma lens_same_context_eq s1 s2:
    same_context π s1 s2 ->
    π s1 = π s2 ->
    s1 = s2.
  Proof.
    intros Hc Hv.
    rewrite <- (lens_set_get s1).
    rewrite <- (lens_set_get s2).
    rewrite Hv.
    apply Hc.
  Qed.
End SETGET.

(** ** Orthogonal lenses *)

(** We say that two lenses on [S] are orthogonal when they give us
  access to two independent parts of the larger structure [S],
  ie. modifying one will not affect the other. The property
  [lens_ortho_setr_setl] below is sufficient to express this.

  Note that for any two orthogonal lenses [π] and [ρ], you should
  never declare instances of both [OrthogonalLenses π ρ] and
  [OrthogonalLenses ρ π], since that would produce a loop in the
  [autorewrite] rules, which use [ortho_lenses_set_set]. *)

Class Orthogonal {S U V} (π: S -> U) (ρ: S -> V)
  `{πs: !LensOps π}
  `{ρs: !LensOps ρ}: Prop :=
{
  lens_ortho_setr_setl u v s:
    set ρ v (set π u s) = set π u (set ρ v s)
}.

Section ORTHOGONAL_LENSES.
  Context {S U V} (π: S -> U) (ρ: S -> V).
  Context `{πops: !LensOps π}.
  Context `{ρops: !LensOps ρ}.
  Context `{Hπρ: !Orthogonal π ρ}.

  Lemma lens_ortho_getl_setr `{Hπgs: !LensGetSet π} `{Hπsg: !LensSetGet π} s v:
    π (set ρ v s) = π s.
  Proof.
    rewrite <- (lens_set_get (π := π) s) at 1.
    rewrite lens_ortho_setr_setl.
    rewrite lens_get_set.
    reflexivity.
  Qed.

  Lemma lens_ortho_getr_setl `{Hρgs: !LensGetSet ρ} `{Hρsg: !LensSetGet ρ} s u:
    ρ (set π u s) = ρ s.
  Proof.
    rewrite <- (lens_set_get (π := ρ) s) at 1.
    rewrite <- lens_ortho_setr_setl.
    rewrite lens_get_set.
    reflexivity.
  Qed.
End ORTHOGONAL_LENSES.

Hint Rewrite
    @lens_get_set
    @lens_set_get
    @lens_set_set
    @lens_unfold_modify
    @lens_eq_set
    @lens_set_same_context
    @lens_modify_same_context
  using typeclasses eauto : lens.

(** * Tactics *)

(** The [autorewrite] base above can be used for normalization,
  however it is unable to handle some of the theorems related to
  orthogonal lenses.

  For example, we want to use [lens_ortho_getl_setr] to rewrite
  occurences of [α (set β v s)], where [α] and [β] are orthogonal
  lenses, into simply [α s]. However, our usual trick for combining
  [autorewrite] and typeclass resolution does not work, because the
  instance of [LensOps α] cannot be obtained by unification when using
  [@lens_ortho_getl_setr], which means the premises contain
  existentials and we would need [erewrite].

  Furthermore, we wish to normalize series of nested [set] so that
  their order matches the declared instances of [Orthogonal]. However,
  rewriting with [@lens_ortho_setr_setl] will only match the first
  pair, and fail if they are already in the right order (because a
  corresponding instance of [Orthogonal] won't be found).

  So we use the tactic below to apply those explicitely in addition
  to using [autorewrite]. *)

Ltac lens_norm_ortho :=
  repeat progress
    match goal with
      | H: context [set ?β ?v (set ?α ?u ?s)] |- _ =>
        rewrite (lens_ortho_setr_setl u v s) in H
      | |- context [set ?β ?v (set ?α ?u ?s)] =>
        rewrite (lens_ortho_setr_setl u v s)
      | H: context [?α (set ?β ?v ?s)] |- _ =>
        rewrite (lens_ortho_getl_setr α β s v) in H
      | |- context [?α (set ?β ?v ?s)] =>
        rewrite (lens_ortho_getl_setr α β s v)
      | H: context [?β (set ?α ?u ?s)] |- _ =>
        rewrite (lens_ortho_getr_setl α β s u) in H
      | |- context [?β (set ?α ?u ?s)] =>
        rewrite (lens_ortho_getr_setl α β s u)
    end.

Ltac lens_norm :=
  repeat progress (simpl in *;
                   lens_norm_ortho;
                   autorewrite with lens in *).

Ltac lens_simpl :=
  repeat progress (lens_norm; autorewrite with lens_simpl in *).

Ltac lens_unfold :=
  repeat progress (lens_simpl; unfold set in *).

(** * Instances *)

(** ** Pairs *)

Section PAIR.
  Global Instance fst_lensops A B: LensOps (@fst A B) := {
    set a x := (a, snd x)
  }.

  Global Instance fst_lens A B: Lens (@fst A B).
  Proof.
    split; split; intuition.
  Qed.

  Global Instance snd_lensops A B: LensOps (@snd A B) := {
    set b x := (fst x, b)
  }.

  Global Instance snd_lens A B: Lens (@snd A B).
  Proof.
    split; split; intuition.
  Qed.

  (** Here are some product-specific theorems. *)

  Lemma fst_same_context_eq_snd {A B} (x y: A * B):
    same_context (@fst A B) x y <-> snd x = snd y.
  Proof.
    destruct x as [a1 b1].
    destruct y as [a2 b2].
    split; intro H.
    * specialize (H a1).
      inversion H.
      reflexivity.
    * intro a.
      compute in *.
      congruence.
  Qed.

  Lemma snd_same_context_eq_fst {A B} (x y: A * B):
    same_context (@snd A B) x y <-> fst x = fst y.
  Proof.
    destruct x as [a1 b1].
    destruct y as [a2 b2].
    split; intro H.
    * specialize (H b1).
      inversion H.
      reflexivity.
    * intro b.
      compute in *.
      congruence.
  Qed.
End PAIR.

Hint Rewrite
  @fst_same_context_eq_snd
  @snd_same_context_eq_fst
  : lens_simpl.

(** ** Composing lens *)

Section COMPOSE.
  Context {A B C} (π: A -> B) (ρ: B -> C) `{Hπ: Lens _ _ π} `{Hρ: Lens _ _ ρ}.

  Instance compose_lensops: LensOps (compose ρ π) := {
    set c a := modify π (set ρ c) a
  }.

  Lemma lens_compose_get_simpl a:
    compose ρ π a = ρ (π a).
  Proof.
    reflexivity.
  Qed.

  Lemma lens_compose_set_simpl c a:
    set (compose ρ π) c a = modify π (set ρ c) a.
  Proof.
    reflexivity.
  Qed.

  Instance lens_compose_get_set: LensGetSet (compose ρ π).
  Proof.
    constructor; simpl; intros.
    rewrite lens_compose_get_simpl.
    rewrite lens_compose_set_simpl.
    autorewrite with lens.
    reflexivity.
  Qed.

  Instance lens_compose_set_get: LensSetGet (compose ρ π).
  Proof.
    constructor; simpl; intros.
    rewrite lens_compose_get_simpl.
    rewrite lens_compose_set_simpl.
    autorewrite with lens.
    reflexivity.
  Qed.

  Instance lens_compose_set_set: LensSetSet (compose ρ π).
  Proof.
    constructor; simpl; intros.
    rewrite !lens_compose_set_simpl.
    autorewrite with lens.
    reflexivity.
  Qed.

  Instance lens_compose: Lens (compose ρ π) := {}.
End COMPOSE.

Hint Rewrite
    @lens_compose_get_simpl
    @lens_compose_set_simpl
  using typeclasses eauto : lens_simpl.

(** ** Initial and terminal objects *)

Section INITIAL.
  Context {V: Type} (π: Empty_set -> V).

  Global Instance lens_empty_ops: LensOps π := {
    set a := Empty_set_rect _
  }.

  Global Instance lens_empty: Lens π.
  Proof.
    split; split; tauto.
  Qed.
End INITIAL.

Section COPRODUCT.
  Context {A B V} {α: A -> V} {β: B -> V}.
  Context `{αops: LensOps A V α}.
  Context `{βops: LensOps B V β}.

  Definition fcoprod (f: A -> V) (g: B -> V): A + B -> V :=
    fun s => match s with
               | inl a => f a
               | inr b => g b
             end.

  Notation "[ f , g ]" := (fcoprod f g).

  Instance lens_coprod_ops: LensOps [α, β] := {
    set v ab :=
      match ab with
        | inl a => inl (set α v a)
        | inr b => inr (set β v b)
      end
  }.

  Instance lens_coprod_get_set:
    LensGetSet α ->
    LensGetSet β ->
    LensGetSet [α,β].
  Proof.
    constructor.
    intros v [a|b];
    unfold set; simpl.
    * lens_norm; reflexivity.
    * lens_norm; reflexivity.
  Qed.

  Instance lens_coprod_set_get:
    LensSetGet α ->
    LensSetGet β ->
    LensSetGet [α,β].
  Proof.
    constructor.
    intros [a|b];
    unfold set; simpl.
    * lens_norm; reflexivity.
    * lens_norm; reflexivity.
  Qed.

  Instance lens_coprod_set_set:
    LensSetSet α ->
    LensSetSet β ->
    LensSetSet [α,β].
  Proof.
    constructor.
    intros u v [a|b];
    unfold set; simpl;
    f_equal.
    * lens_norm; reflexivity.
    * lens_norm; reflexivity.
  Qed.

  Global Instance lens_coprod:
    Lens α ->
    Lens β ->
    Lens [α,β].
  Proof.
    constructor;
    typeclasses eauto.
  Qed.
End COPRODUCT.

Section TERMINAL.
  Context {S: Type} (π: S -> unit).

  Instance lens_unit_ops: LensOps (S := S) π := {
    set u s := s
  }.

  Instance lens_unit: Lens π.
  Proof.
    assert (forall u v: unit, u = v) by (intros [] []; reflexivity).
    firstorder.
  Qed.
End TERMINAL.

(** Interestingly, the product only works for orthogonal lenses. *)

Section PRODUCT.
  Context {S A B} {α: S -> A} {β: S -> B}.
  Context `{αops: LensOps S A α}.
  Context `{βops: LensOps S B β}.

  Definition fprod (f: S -> A) (g: S -> B): S -> A * B :=
    fun s => (f s, g s).

  Notation "〈  f , g 〉" := (fprod f g).

  Instance lens_prod_ops: LensOps 〈α, β〉 := {
    set ab s := set α (fst ab) (set β (snd ab) s)
  }.

  Ltac go :=
    unfold set, fprod;
    simpl;
    lens_norm;
    try reflexivity.

  Instance lens_prod_get_set:
    Orthogonal α β ->
    LensSetGet β ->
    LensGetSet α ->
    LensGetSet β ->
    LensGetSet 〈α,β〉.
  Proof.
    constructor.
    intros [a b] s.
    go.
  Qed.

  Instance lens_prod_set_get:
    LensSetGet α ->
    LensSetGet β ->
    LensSetGet 〈α,β〉.
  Proof.
    constructor.
    intros s.
    go.
  Qed.

  Instance lens_prod_set_set:
    Orthogonal α β ->
    LensSetSet α ->
    LensSetSet β ->
    LensSetSet 〈α,β〉.
  Proof.
    constructor.
    intros [a1 b1] [a2 b2] s.
    go.
  Qed.

  Global Instance lens_prod:
    Orthogonal α β ->
    Lens α ->
    Lens β ->
    Lens 〈α,β〉.
  Proof.
    constructor;
    typeclasses eauto.
  Qed.
End PRODUCT.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.

Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.

Implicit Arguments old.

Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Definition key  := Z.

Definition value  := Z.

Inductive color  :=
  | Red : color
  | Black : color .

Inductive tree  :=
  | Leaf : tree
  | Node : color -> tree -> Z -> Z -> tree -> tree .

Set Implicit Arguments.
Fixpoint memt(t:tree) (k:Z) (v:Z) {struct t}: Prop :=
  match t with
  | Leaf => False
  | (Node _ l kqt vqt r) => ((k = kqt) /\ (v = vqt)) \/ ((memt l k v) \/
      (memt r k v))
  end.
Unset Implicit Arguments.

Axiom memt_color : forall (l:tree) (r:tree) (k:Z) (kqt:Z) (v:Z) (vqt:Z)
  (c:color) (cqt:color), (memt (Node c l k v r) kqt vqt) -> (memt (Node cqt l
  k v r) kqt vqt).

Definition lt_tree(x:Z) (t:tree): Prop := forall (k:Z), forall (v:Z), (memt t
  k v) -> (k <  x)%Z.

Definition gt_tree(x:Z) (t:tree): Prop := forall (k:Z), forall (v:Z), (memt t
  k v) -> (x <  k)%Z.

Axiom lt_leaf : forall (x:Z), (lt_tree x Leaf).

Axiom gt_leaf : forall (x:Z), (gt_tree x Leaf).

Axiom lt_tree_node : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x l) -> ((lt_tree x r) -> ((y <  x)%Z -> (lt_tree x (Node c l y v
  r)))).

Axiom gt_tree_node : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x l) -> ((gt_tree x r) -> ((x <  y)%Z -> (gt_tree x (Node c l y v
  r)))).

Axiom lt_node_lt : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x (Node c l y v r)) -> (y <  x)%Z.

Axiom gt_node_gt : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x (Node c l y v r)) -> (x <  y)%Z.

Axiom lt_left : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x (Node c l y v r)) -> (lt_tree x l).

Axiom lt_right : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x (Node c l y v r)) -> (lt_tree x r).

Axiom gt_left : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x (Node c l y v r)) -> (gt_tree x l).

Axiom gt_right : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x (Node c l y v r)) -> (gt_tree x r).

Axiom lt_tree_not_in : forall (x:Z) (t:tree), (lt_tree x t) -> forall (v:Z),
  ~ (memt t x v).

Axiom lt_tree_trans : forall (x:Z) (y:Z), (x <  y)%Z -> forall (t:tree),
  (lt_tree x t) -> (lt_tree y t).

Axiom gt_tree_not_in : forall (x:Z) (t:tree), (gt_tree x t) -> forall (v:Z),
  ~ (memt t x v).

Axiom gt_tree_trans : forall (x:Z) (y:Z), (y <  x)%Z -> forall (t:tree),
  (gt_tree x t) -> (gt_tree y t).

Set Implicit Arguments.
Fixpoint bst(t:tree) {struct t}: Prop :=
  match t with
  | Leaf => True
  | (Node _ l k v r) => (bst l) /\ ((bst r) /\ ((lt_tree k l) /\ (gt_tree k
      r)))
  end.
Unset Implicit Arguments.

Axiom bst_Leaf : (bst Leaf).

Axiom bst_left : forall (k:Z) (v:Z) (l:tree) (r:tree) (c:color), (bst (Node c
  l k v r)) -> (bst l).

Axiom bst_right : forall (k:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (bst (Node c l k v r)) -> (bst r).

Axiom bst_color : forall (c:color) (cqt:color) (k:Z) (v:Z) (l:tree) (r:tree),
  (bst (Node c l k v r)) -> (bst (Node cqt l k v r)).

Axiom rotate_left : forall (kx:Z) (ky:Z) (vx:Z) (vy:Z) (a:tree) (b:tree)
  (c:tree) (c1:color) (c2:color) (c3:color) (c4:color), (bst (Node c1 a kx vx
  (Node c2 b ky vy c))) -> (bst (Node c3 (Node c4 a kx vx b) ky vy c)).

Axiom rotate_right : forall (kx:Z) (ky:Z) (vx:Z) (vy:Z) (a:tree) (b:tree)
  (c:tree) (c1:color) (c2:color) (c3:color) (c4:color), (bst (Node c3
  (Node c4 a kx vx b) ky vy c)) -> (bst (Node c1 a kx vx (Node c2 b ky vy
  c))).

Definition is_not_red(t:tree): Prop :=
  match t with
  | (Node Red _ _ _ _) => False
  | (Leaf|(Node Black _ _ _ _)) => True
  end.

Set Implicit Arguments.
Fixpoint rbtree(n:Z) (t:tree) {struct t}: Prop :=
  match t with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ ((rbtree n r) /\ ((is_not_red l) /\
      (is_not_red r)))
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end.
Unset Implicit Arguments.

Axiom rbtree_Leaf : (rbtree 0%Z Leaf).

Axiom rbtree_Node1 : forall (k:Z) (v:Z), (rbtree 0%Z (Node Red Leaf k v
  Leaf)).

Axiom rbtree_left : forall (x:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (exists n:Z, (rbtree n (Node c l x v r))) -> exists n:Z, (rbtree n l).

Axiom rbtree_right : forall (x:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (exists n:Z, (rbtree n (Node c l x v r))) -> exists n:Z, (rbtree n r).

Definition almost_rbtree(n:Z) (t:tree): Prop :=
  match t with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ (rbtree n r)
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end.

Axiom rbtree_almost_rbtree : forall (n:Z) (t:tree), (rbtree n t) ->
  (almost_rbtree n t).

Axiom rbtree_almost_rbtree_ex : forall (s:tree), (exists n:Z, (rbtree n
  s)) -> exists n:Z, (almost_rbtree n s).

Axiom almost_rbtree_rbtree_black : forall (x:Z) (v:Z) (l:tree) (r:tree)
  (n:Z), (almost_rbtree n (Node Black l x v r)) -> (rbtree n (Node Black l x
  v r)).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem WP_parameter_rbalance : forall (l:tree), forall (k:Z), forall (v:Z),
  forall (r:tree), ((lt_tree k l) /\ ((gt_tree k r) /\ ((bst l) /\
  (bst r)))) ->
  match r with
  | ((Node Red (Node Red b ky vy c) kz vz d)|(Node Red b ky vy (Node Red c kz
      vz d))) => forall (n:Z), (almost_rbtree n r) -> ((rbtree n l) ->
      (rbtree (n + 1%Z)%Z (Node Red (Node Black l k v b) ky vy (Node Black c
      kz vz d))))
  | _ => True
  end.
(* YOU MAY EDIT THE PROOF BELOW *)
intuition.

destruct r; intuition.
destruct c; intuition.
destruct r1; intuition.
destruct r2; intuition.
destruct c; intuition.
inversion H2.
inversion H5.
simpl in H6.
subst.
simpl rbtree; intuition.

destruct c; intuition.
inversion H2.
simpl in H5.
simpl rbtree.
replace (n+1-1)%Z with n by omega; intuition.

destruct r2; intuition.
destruct c; intuition.
inversion H2.
simpl in H5.
simpl in H6.
simpl rbtree.
replace (n+1-1)%Z with n by omega; intuition.
Qed.
(* DO NOT EDIT BELOW *)


Require Export Iron.Language.SystemF2Effect.Kind.
Require Export Iron.Language.SystemF2Effect.Type.Exp.TyCon.
Require Export Iron.Language.SystemF2Effect.Type.Exp.TyCap.

(********************************************************************)
(* Type Expressions. *)
Inductive ty  : Type  :=
 | TVar      : nat    -> ty
 | TForall   : ki     -> ty -> ty
 | TApp      : ty     -> ty -> ty
 | TSum      : ty     -> ty -> ty
 | TBot      : ki     -> ty

 (* Primitive constructed types. *)
 | TCon0     : tycon0 -> ty
 | TCon1     : tycon1 -> ty -> ty
 | TCon2     : tycon2 -> ty -> ty -> ty

 (* Primitive capabilities. *)
 | TCap      : tycap  -> ty.
Hint Constructors ty.

(********************************************************************)
(* Notations for baked in types *)
(* Region handles *)
Notation TRgn   P    := (TCap (TyCapRegion P)).

(* Effect types *)
Notation TRead  R    := (TCon1 TyConRead  R).
Notation TWrite R    := (TCon1 TyConWrite R).
Notation TAlloc R    := (TCon1 TyConAlloc R).

(* Function type. *)
Notation TFun A E B  := (TApp (TApp (TApp (TCon0 TyConFun) A) E) B).

(* Primitive data types. *)
Notation TUnit       := (TCon0 TyConUnit).
Notation TBool       := (TCon0 TyConBool).
Notation TNat        := (TCon0 TyConNat).

(* Reference to a value in some region. *)
Notation TRef R T    := (TCon2 TyConRef R T).

(********************************************************************)
(* Predicates to test whether types have specific forms. *)

(* Check whether a type is a variable with the given index. *)
Definition isTVar   (n : nat) (t : ty) :=
 match t with
 | TVar n' => beq_nat n n'
 | _       => false
 end.

Definition IsTVar  (n : nat) (t : ty)
 := isTVar n t = true.

(* If we know a type is a variable, then it is one.. *)
Lemma isTVar_form
 :  forall i t
 ,  IsTVar i t
 -> t    = TVar i.
Proof.
 intros.
 destruct t; snorm; try nope.
 unfold IsTVar in *. snorm.
Qed.
Hint Resolve isTVar_form.

(* Check whether a type is a region handle with the given index. *)
Definition isTRgn (p : nat) (t : ty) :=
 match t with
 | TRgn p' => beq_nat p p'
 | _       => false
 end.

Definition IsTRgn   (p : nat) (t : ty)
 := isTRgn p t = true.
Hint Unfold IsTRgn.

(* If we know a tpye is a region handle, then it is one.. *)
Lemma isTRgn_form
 :  forall p t
 ,  IsTRgn p t
 -> t    = TRgn p.
Proof.
 intros.
 destruct t; snorm; try nope.
 destruct t. unfold IsTRgn in *. snorm. subst. auto.
Qed.
Hint Resolve isTRgn_form.

(* Check whether a type is an effect on the given region variable. *)
Definition isEffectOnVar (n : nat) (t : ty) :=
 match t with
 | TCon1 tc t1 => andb (isEffectTyCon_b tc) (isTVar n t1)
 | _           => false
 end.

(* Check whether a type is an effect on the given region handle. *)
Definition isEffectOnCap (p : nat) (t : ty) :=
 match t with
 | TCon1 tc t1 => andb (isEffectTyCon_b tc) (isTRgn p t1)
 | _           => false
 end.