Require Import Coq.Classes.Morphisms.
Require Import Coq.Lists.List.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.List_Func_ext.
Require Export CertiGraph.lib.Relation_ext.

(* TODO: define a general pointwise relation on list *)
Inductive same_relation_list {A: Type}: list (relation A) -> list (relation A) -> Prop :=
  | same_relation_list_nil :
      same_relation_list nil nil
  | same_relation_list_cons :
      forall x xs y ys,
      same_relation A x y ->
      same_relation_list xs ys ->
      same_relation_list (x :: xs) (y :: ys).

Lemma same_relation_list_refl: forall {A} (rs: list (relation A)), same_relation_list rs rs.
Proof.
  intros.
  induction rs; constructor; auto.
  reflexivity.
Qed.

Lemma same_relation_list_symm: forall {A} (rs1 rs2: list (relation A)),
  same_relation_list rs1 rs2 -> same_relation_list rs2 rs1.
Proof.
  intros.
  induction H; constructor.
  + symmetry; auto.
  + auto.
Qed.

Lemma same_relation_list_trans: forall {A} (rs1 rs2 rs3: list (relation A)),
  same_relation_list rs1 rs2 ->
  same_relation_list rs2 rs3 ->
  same_relation_list rs1 rs3.
Proof.
  intros.
  rename H0 into HH.
  revert rs3 HH; induction H; intros;
  inversion HH; subst; constructor.
  + rewrite H; auto.
  + auto.
Qed.

Instance Equivalence_same_relation_list {A}: Equivalence (@same_relation_list A).
Proof.
  split.
  + exact same_relation_list_refl.
  + exact same_relation_list_symm.
  + exact same_relation_list_trans.
Defined.

Instance cons_relation_proper {A}: Proper (same_relation A ==> same_relation_list ==> same_relation_list) (@cons (relation A)).
Proof.
  do 2 (hnf; intros).
  apply same_relation_list_cons; auto.
Defined.

Definition relation_list {A: Type} (R: list (relation A)) : relation A := fold_left compond_relation R eq.

Lemma relation_list_app: forall {A: Type} (R R': list (relation A)),
  same_relation _ (relation_list (R ++ R')) (compond_relation (relation_list R) (relation_list R')).
Proof.
  intros.
  apply monoid_fold_left_app.
  + apply compond_eq_left.
  + apply compond_eq_right.
  + apply compond_assoc.
Qed.

Lemma relation_list_head: forall {A: Type} a (l: list (relation A)),
  same_relation _ (relation_list (a :: l)) (compond_relation a (relation_list l)).
Proof.
  intros.
  apply monoid_fold_left_head.
  + apply compond_eq_left.
  + apply compond_eq_right.
  + apply compond_assoc.
Qed.

Lemma relation_list_tail: forall {A: Type} (l: list (relation A)) a,
  same_relation _ (relation_list (l ++ a :: nil)) (compond_relation (relation_list l) a).
Proof.
  intros.
  apply monoid_fold_left_tail.
Qed.

Lemma relation_list_nil: forall {A}, same_relation A (relation_list nil) eq.
Proof.
  intros.
  reflexivity.
Qed.

Lemma eq_relation_list: forall {A B} {R: relation A} {EqRA: Equivalence R} (l: list B),
  inclusion _ (relation_list (map (fun _ => R) l)) R.
Proof.
  intros.
  induction l.
  + simpl; rewrite relation_list_nil.
    hnf; intros.
    subst; reflexivity.
  + simpl map.
    rewrite relation_list_head.
    hnf; intros.
    inversion H; subst.
    transitivity y0.
    - auto.
    - apply IHl; auto.
Qed.

Lemma relation_list_weaken_ind: forall {A B} (R R': B -> relation A) l a1 a2,
  (forall bs_done b0 a2 a3,
     In (bs_done, b0) (cprefix l) ->
     relation_list (map R bs_done) a1 a2 ->
     R b0 a2 a3 ->
     R' b0 a2 a3) ->
  relation_list (map R l) a1 a2 ->
  relation_list (map R' l) a1 a2.
Proof.
  intros.
  revert a2 H0; rev_induction l; intros.
  + simpl in H0 |- *; auto.
  + revert H1.
    rewrite !map_app; simpl.
    erewrite !(app_same_relation (relation_list _)) by apply relation_list_tail.
    intro.
    destruct H1.
    apply compond_intro with y.
    - apply H; auto.
      clear - H0.
      intros; apply (H0 bs_done); auto.
      rewrite combine_prefixes_app_1.
      apply in_app_iff.
      left; auto.
    - apply (H0 l); auto.
      rewrite combine_prefixes_app_1.
      apply in_app_iff.
      right; simpl; auto.
Qed.

Lemma relation_list_weaken_ind': forall {A B} (R R': B -> relation A) l a1 a2,
  (forall bs_done b0 a2 a3,
     In (bs_done, b0) (cprefix l) ->
     relation_list (map R bs_done) a1 a2 ->
     relation_list (map R' bs_done) a1 a2 ->
     R b0 a2 a3 ->
     R' b0 a2 a3) ->
  relation_list (map R l) a1 a2 ->
  relation_list (map R' l) a1 a2.
Proof.
  intros.
  revert a2 H0; rev_induction l; intros.
  + simpl in H0 |- *; auto.
  + revert H1.
    rewrite !map_app; simpl.
    erewrite !(app_same_relation (relation_list _)) by apply relation_list_tail.
    intro.
    destruct H1.
    assert (relation_list (map R' l) x0 y).
    - apply H; auto.
      clear - H0.
      intros; apply (H0 bs_done); auto.
      rewrite combine_prefixes_app_1.
      apply in_app_iff.
      left; auto.
    - apply compond_intro with y; auto.
      apply (H0 l); auto.
      rewrite combine_prefixes_app_1.
      apply in_app_iff.
      right; simpl; auto.
Qed.

Lemma relation_list_inclusion: forall {A B} (R R': B -> relation A) l,
  (forall b, In b l -> inclusion _ (R b) (R' b)) ->
  inclusion _ (relation_list (map R l)) (relation_list (map R' l)).
Proof.
  intros.
  induction l.
  + simpl.
    hnf; auto.
  + simpl map.
    rewrite relation_list_head.
    rewrite relation_list_head.
    apply compond_relation_inclusion.
    - apply H; simpl; auto.
    - apply IHl; intros.
      apply H; simpl; auto.
Qed.

Lemma relation_list_conjunction: forall {A B} (R R': B -> relation A) l,
  inclusion _ (relation_list (map (fun b => relation_conjunction (R b) (R' b)) l)) (relation_conjunction (relation_list (map R l)) (relation_list (map R' l))).
Proof.
  intros.
  simpl.
  induction l.
  - simpl.
    rewrite relation_list_nil.
    hnf; intros.
    rewrite relation_conjunction_iff.
    auto.
  - simpl map.
    rewrite !relation_list_head.
    hnf; intros.
    inv H.
    apply IHl in H1.
    rewrite relation_conjunction_iff.
    destruct H0, H1.
    split; apply compond_intro with y0; auto.
Qed.

Lemma respectful_relation_list: forall {B A} (f: B -> A) (l: list (relation A)),
  inclusion _
   (relation_list (map (respectful_relation f) l))
   (respectful_relation f (relation_list l)).
Proof.
  intros; hnf; intros.
  revert x y H; induction l; intros.
  + unfold relation_list in H.
    simpl in *.
    subst.
    reflexivity.
  + simpl.
    erewrite app_same_relation by (rewrite relation_list_head; reflexivity).
    apply respectful_compond_relation.
    simpl in H.
    erewrite app_same_relation in H by (rewrite relation_list_head; reflexivity).
    inversion H; subst.
    apply compond_intro with y0; auto.
Qed.

Lemma relation_list_singleton: forall {A} (R: relation A), same_relation _ (relation_list (R :: nil)) R.
Proof.
  intros.
  unfold relation_list; simpl.
  apply compond_eq_left.
Qed.

Instance relation_list_proper {A: Type}: Proper (same_relation_list ==> same_relation A) relation_list.
Proof.
  hnf; intros.
  induction H.
  + reflexivity.
  + rewrite !relation_list_head.
    rewrite H.
    rewrite IHsame_relation_list.
    reflexivity.
Qed.

Ltac split_relation_list L :=
  match goal with
  | |- relation_list _ ?x ?z =>
         match L with
         | nil =>
            try rewrite ((proj1 (same_relation_spec _ _) (relation_list_singleton _)) x z)
         | ?y :: ?L0 =>
            rewrite ((proj1 (same_relation_spec _ _) (relation_list_head _ _)) x z);
            apply compond_intro with y; [| split_relation_list L0]
         end
  end.

Ltac destruct_relation_list_aux cont H x z L :=
  match L with
  | ?A :: ?L0 =>
     match L0 with
     | _ :: _ =>
         fun y =>
         destruct_relation_list_aux ltac:(cont;
           rewrite ((proj1 (same_relation_spec _ _) (relation_list_head _ _)) x z) in H;
           let HH := fresh "H" in
           apply compond_relation_spec in H; destruct H as [y [HH H]]) H y z L0
     | _ => cont;
         try rewrite ((proj1 (same_relation_spec _ _) (relation_list_singleton _)) x z) in H
     end
  | _ => cont
  end.

Ltac destruct_relation_list' H :=
  match type of H with
  | relation_list ?L ?x ?z => destruct_relation_list_aux idtac H x z L
  end.

Tactic Notation "destruct_relation_list" ident(x0) "in" hyp(H) := destruct_relation_list' H x0.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) "in" hyp(H) := destruct_relation_list' H x0 x1.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) "in" hyp(H) := destruct_relation_list' H x0 x1 x2.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) ident(x4) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3 x4.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3 x4 x5.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) ident(x6) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3 x4 x5 x6.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) ident(x6) ident(x7) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3 x4 x5 x6 x7.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) ident(x6) ident(x7) ident(x8) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3 x4 x5 x6 x7 x8.
Tactic Notation "destruct_relation_list" ident(x0) ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) ident(x6) ident(x7) ident(x8) ident(x9) "in" hyp(H) := destruct_relation_list' H x0 x1 x2 x3 x4 x5 x6 x7 x8 x9.


Open Scope type_scope.
Section Iso_axioms.
Variables A B C : Set.
Axiom Com : A * B = B * A.
Axiom Ass : A * (B * C) = A * B * C.
Axiom Cur : (A * B -> C) = (A -> B -> C).
Axiom Dis : (A -> B * C) = (A -> B) * (A -> C).
Axiom P_unit : A * unit = A.
Axiom AR_unit : (A -> unit) = unit.
Axiom AL_unit : (unit -> A) = A.
End Iso_axioms.

Lemma P_unit_bis : forall A : Set,
unit * A = A.
intros.
rewrite Com.
rewrite P_unit.
reflexivity.
Qed.

Lemma isos_ex1 : forall A B:Set,
A * unit * B = B * (unit * A).
intros.
rewrite Ass.
rewrite P_unit.
rewrite P_unit.
rewrite Com.
reflexivity.

Lemma isos_ex2 : forall A B C:Set,
(A * unit -> B * (C * unit)) =
(A * unit -> (C -> unit) * C) * (unit -> A -> B).

intros.
rewrite P_unit.
rewrite P_unit.
rewrite AR_unit.
rewrite AL_unit.
rewrite Dis.
rewrite Dis.
rewrite AR_unit.
rewrite (Com unit (A->C)).
rewrite P_unit.
rewrite Com.
reflexivity.

Ltac all_but_com :=
  repeat
    match goal with
    | |- context[?A * (?B * ?C)] => rewrite Ass
    | |- context[?A * ?B -> ?C] => rewrite Cur
    | |- context[?A -> ?B * ?C] => rewrite Dis
    | |- context[?A * unit] => rewrite P_unit
    | |- context[unit * ?A] =>rewrite P_unit_bis
    | |- context[?A -> unit] => rewrite AR_unit
    | |- context[unit -> ?A] => rewrite AL_unit
    end.

Lemma isos_ex1_1 : forall A B:Set,
A * unit * B = B * (unit * A).
intros.
all_but_com.
rewrite Com.
reflexivity.

Lemma isos_ex2_1 : forall A B C:Set,
(A * unit -> B * (C * unit)) =
(A * unit -> (C -> unit) * C) * (unit -> A -> B).
intros.
all_but_com.
rewrite Com.
reflexivity.


Require BigO.Util.Admitted.
Require Import BigO.Facts. (* f ∈ O(g) ↔ g ∈ Ω(f) *)
Require Import BigO.Notation.
Require Import Util.DecField.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.interfaces.vectorspace.
Require Import MathClasses.orders.dec_fields.

Section BigThetaSymmetry.
  Context `{SemiNormedSpace K V}.
  Context `{@SemiNormedSpace
              K W1
              Ke Kle Kzero Knegate Kabs Wnorm1 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We1 Wop1 Wunit1 Wnegate1 smkw1
           }.
  Context `{@SemiNormedSpace
              K W2
              Ke Kle Kzero Knegate Kabs Wnorm2 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We2 Wop2 Wunit2 Wnegate2 smkw2
           }.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Context `{forall x y : K, Decision (x = y)}.

  Lemma big_Theta_sym : ∀ (f : V → W1) (g : V → W2), f ∈ Θ(g) → g ∈ Θ(f).
    intros f g.
    unfold big_Theta in *.
    intros f_Theta_g.
    destruct f_Theta_g as [HO HΩ].
    split; now apply O_and_Omega.
  Qed.

End BigThetaSymmetry.

(* The iff version. Has to be in another section for big_Theta_sym to generalize *)

Section BigThetaSymmetry'.
  Context `{SemiNormedSpace K V}.
  Context `{@SemiNormedSpace
              K W1
              Ke Kle Kzero Knegate Kabs Wnorm1 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We1 Wop1 Wunit1 Wnegate1 smkw1
           }.
  Context `{@SemiNormedSpace
              K W2
              Ke Kle Kzero Knegate Kabs Wnorm2 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We2 Wop2 Wunit2 Wnegate2 smkw2
           }.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Context `{forall x y : K, Decision (x = y)}.
  Lemma big_Theta_sym' : ∀ (f : V → W1) (g : V → W2), f ∈ Θ(g) ↔ g ∈ Θ(f).
    split; apply big_Theta_sym.
  Qed.
End BigThetaSymmetry'.


(** * QC: Core QuickChick *)

Require Import Arith Bool List ZArith. Import ListNotations.
From QuickChick Require Import QuickChick. Import QcNotation.

(* Suppress some annoying warnings: *)
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Export ExtLib.Structures.Monads.
Export MonadNotation. Open Scope monad_scope.

Require Import String. Local Open Scope string.

(* ################################################################# *)
(** * Generators *)

(** The heart of property-based random testing is generation of random
    inputs.  *)

(* ================================================================= *)
(** ** The [G] Monad *)

(** In QuickChick, a generator for elements of some type [A] belongs
    to the type [G A].  Intuitively, this type describes functions
    that take a random seed to an element of [A].  We will see below
    that [G] is actually a bit more than this, but this intuition will
    do for now. *)

(** QuickChick provides a number of primitives for building
    generators.  First, [returnGen] takes a constant value and yields
    a generator that always returns this value. *)

Check returnGen.
(**

     ===> returnGen : ?A -> G ?A
*)

(** We can see how it behaves by using the [Sample] command, which
    supplies its generator argument with several different random
    seeds: *)

(* Sample (returnGen 42).

     ===> [42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42]
*)

(** Next, given a random generator for [A] and a _function_ [f] taking
    an [A] and yielding a random generator for [B], we can plumb the
    two together into a generator for [B] that works by internally
    generating a random [A] and applying [f] to it. *)

Check bindGen.
(**

     ===> bindGen : G ?A -> (?A -> G ?B) -> G ?B
*)

(** Naturally, the implementation of [bindGen] must take care
    to pass different random seeds to the two sub-generators! *)

(** With these two primitives in hand, we can make [G] an instance of
    the [Monad] typeclass. *)

Section GMonadDef.

Instance GMonad : `{Monad G} | 3 :=
  {
    ret := @returnGen;
    bind := @bindGen
  }.

End GMonadDef.

(* ================================================================= *)
(** ** Primitive generators *)

(** QuickChick provides several primitive generators for "ordered
    types," accessed via the [choose] combinator. *)

Check @choose.
(**

     ===>
     @choose
     : forall A : Type, ChoosableFromInterval A -> A * A -> G A
*)

(** The [ChoosableFromInterval] typeclass describes primitive types
    [A], like natural numbers and integers ([Z]), for which it makes
    sense to randomly generate elements from a given interval. *)

Print ChoosableFromInterval.
(**

     ===>
     Record ChoosableFromInterval (A : Type) : Type :=
       Build_ChoosableFromInterval
       { super : Ord A;
         randomR : A * A -> RandomSeed -> A * RandomSeed;
         ...
       }.
*)

(* Sample (choose (0,10)).

     ===> [ 1, 2, 1, 9, 8, 10, 3, 6, 0, 1, 8 ]
*)

(** **** Exercise: 1 star, standard, optional (cfi)

    Print out the full definition of [ChoosableFromInterval].  Can you
    understand what it means?

    [] *)

(* ================================================================= *)
(** ** Lists *)

(** Since they are a very commonly used compound datatype, lists have
    special combinators in QuickChick: [listOf] and [vectorOf]. *)

(** The [listOf] combinator takes as input a generator for elements of
    type [A] and returns a generator for lists of [A]s. *)

Check listOf.
(**

     ===> listOf : G ?A -> G (list ?A)
*)

(* Sample (listOf (choose (0,4))).

     ===>
      [ [ 0, 3, 2, 0 ],
        [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ],
        [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ],
        [ 0 ],
        [ 4, 2, 3 ],
        [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ],
        [ 0, 4 ],
        [  ],
        [ 1, 0, 1, 3, 1 ],
        [ 0, 0 ],
        [ 1, 4 ],
        [ 4, 3, 2, 0, 2, 2, 4, 0 ],
        [ 1, 1, 0, 0, 1, 4 ],
        [ 2, 0, 2, 1, 3, 3 ],
        [ 4, 3, 3, 0, 1 ],
        [ 3, 3, 3 ],
        [ 3, 2, 4 ],
        [ 1, 2 ],
        [  ],
        [  ] ]
*)

(** The second combinator, [vectorOf], receives an additional numeric
    argument [n], the length of the list to be generated. *)

Check vectorOf.
(**

     ===> vectorOf : nat -> G ?A -> G (list ?A)
*)

(* Sample (vectorOf 3 (choose (0,4))).

     ===>
      [ [0, 1, 4],
        [1, 1, 0],
        [3, 3, 3],
        [0, 2, 1],
        [1, 3, 2],
        [3, 3, 0],
        [3, 0, 4],
        [2, 3, 3],
        [3, 2, 4],
        [1, 2, 3],
        [2, 0, 4]  ]
*)

(** This raises a question.  It's clear how [vectorOf] decides how big
    to make its lists (we tell it!), but how does [listOf] do it?  The
    answer is hidden inside [G].

    In addition to handling random-seed plumbing, the [G] monad also
    maintains a "current maximum size" (in the style of a "reader
    monad", if you like that terminology): a natural number that
    can be used as an upper bound on the depth of generated objects. *)

(** Internally, [G A] is just a synonym for [nat -> RandomSeed -> A]. *)

Module DefineG.

Inductive G (A:Type) : Type :=
| MkG : (nat -> RandomSeed -> A) -> G A.
Arguments MkG {A}.

End DefineG.

(** When it is searching for counterexamples, QuickChick progressively
    tries larger and larger values for the size bound [n], to
    gradually explore deeper into the search space.

    Each generator can choose to interpret the size bound however it
    wants, and there is no _enforced_ guarantee that generators pay
    any attention to it at all; however, it is good practice to
    respect this bound when programming generators. *)

(* ================================================================= *)
(** ** Custom Generators *)

(** Naturally, we also need generators for user-defined datatypes.
    Here's a simple one to play with: *)

Inductive color := Red | Green | Blue | Yellow.

(** In order for commands like [Sample] to display colors, we should
    make [color] an instance of the [Show] typeclass: *)

Instance show_color : Show color :=
  {| show c :=
       match c with
         | Red    => "Red"
         | Green  => "Green"
         | Blue   => "Blue"
         | Yellow => "Yellow"
       end
  |}.

(** To generate a random color, we just need to pick one of the
    constructors [Red], [Green], [Blue], or [Yellow]. This is done
    using [elems_]. *)

Check elems_.
(**

     ===> elems_ : ?A -> list ?A -> G ?A
*)

Definition genColor' : G color :=
  elems_ Red [ Red ; Green ; Blue ; Yellow ].

(* Sample genColor'.

     ===>
   [Red, Green, Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red]
*)

(** The first argument to [elems_] serves as a default result.  If
    its list argument is not empty, [elems_] returns a generator
    that always picks an element of that list; otherwise the generator
    always returns the default object.  This makes Coq's totality
    checker happy, but makes [elem_] a little awkward to use, since
    typically its second argument will be a non-empty constant list. *)

(** To make the common case smoother, QuickChick provides convenient
    notations that automatically extract the default element. *)

(**

     " 'elems' [ x ] "
         := elems_ x (cons x nil)
     " 'elems' [ x ; y ] "
         := elems_ x (cons x (cons y nil))
     " 'elems' [ x ; y ; .. ; z ] "
         := elems_ x (cons x (cons y (.. (cons z nil))))
     " 'elems' ( x ;; l ) "
         := elems_ x (cons x l)
*)

(** Armed with [elems], we can write a [color] generator the way we'd
    hope. *)

Definition genColor : G color :=
  elems [ Red ; Green ; Blue ; Yellow ].

(* Sample genColor.

     ===> [Red, Green, Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red]
*)

(** For more complicated ADTs, QuickChick provides more combinators.

    We showcase these using everyone's favorite datatype: trees! *)

(** Our trees are standard polymorphic binary trees; either [Leaf]s or
    [Node]s containing some payload of type [A] and two subtrees. *)

Inductive Tree A :=
| Leaf : Tree A
| Node : A -> Tree A -> Tree A -> Tree A.

Arguments Leaf {A}.
Arguments Node {A} _ _ _.

(** Before getting to generators for trees, we again give a
    straightforward [Show] instance.  (The need for a local [let fix]
    declaration stems from the fact that Coq's typeclasses, unlike
    Haskell's, are not automatically recursive.  We could
    alternatively define [aux] with a separate top-level
    [Fixpoint].) *)

Instance showTree {A} `{_ : Show A} : Show (Tree A) :=
  {| show := let fix aux t :=
       match t with
         | Leaf => "Leaf"
         | Node x l r =>
             "Node (" ++ show x ++ ") ("
                      ++ aux l ++ ") ("
                      ++ aux r ++ ")"
       end
     in aux
  |}.

(** This brings us to our first generator _combinator_, called [oneOf_]. *)

Check oneOf_.
(**

     ===> oneOf_ : G ?A -> list (G ?A) -> G ?A
*)

(** This combinator takes a default generator and a list of
    generators, and it picks one of the generators from the list
    uniformly at random (unless the list is empty, in which case it
    picks from the default generator).  As with [elems_], QuickChick
    introduces a more convenient notation [oneOf] to hide this default
    element. *)

(** Next, Coq's termination checker will save us from shooting
    ourselves in the foot!

    The "obvious" first attempt at a generator is the following
    function [genTree], which generates either a [Leaf] or else a
    [Node] whose subtrees are generated recursively (and whose payload
    is produced by a generator [g] for elements of type [A]).*)

(**

     Fixpoint genTree {A} (g : G A) : G (Tree A) :=
        oneOf [ ret Leaf ;;
                liftM3 Node g (genTree g) (genTree g) ].
*)

(** Of course, this fixpoint will not pass Coq's termination
    checker. Attempting to justify this fixpoint informally, one might
    first say that at some point the random generation will pick a
    [Leaf] so it will eventually terminate.  But the termination
    checker cannot understand this kind of probabilistic reasoning.
    Moreover, even informally, the reasoning is wrong: Every time we
    choose to generate a [Node], we create two separate branches that
    must both be terminated with leaves.  It is not hard to show that
    the _expected_ size of the generated trees is actually
    infinite! *)

(** The solution is to use the standard "fuel" idiom that Coq users
    are familiar with.  We add a natural number [sz] as a parameter.  We
    decrease this size in each recursive call, and when it reaches
    [O], we always generate [Leaf].  Thus, the initial [sz] parameter
    serves as a bound on the depth of the tree. *)

Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => ret Leaf
    | S sz' =>
        oneOf [
          ret Leaf ;
          liftM3 Node g (genTreeSized sz' g) (genTreeSized sz' g)
        ]
  end.

(* Sample (genTreeSized 3 (choose(0,3))).

     ===>
       [ Leaf,
         Leaf,
         Node (3) (Node (0) (Leaf) (Leaf))
                  (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Leaf,
         Leaf,
         Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Leaf) (Leaf),
         Node (1) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Node (0) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Leaf,
         Leaf,
         Leaf ]
*)

(** While this generator succeeds in avoiding nontermination, we can
    see just by observing the result of [Sample] that there is a
    problem: it produces way too many [Leaf]s!  This is actually not
    surprising, since half the time we generate a [Leaf] right at the
    outset.  *)

(** We can obtain bigger trees more often if we skew the distribution
    towards [Node]s using a more expressive QuickChick combinator,
    [freq_]. *)

Check freq_.
(**

     ===> freq_ : G ?A -> seq (nat * G ?A) -> G ?A
*)

(** As with [oneOf], we usually use a convenient derived notation,
    called [freq], that takes a list of generators, each tagged with a
    natural number that serves as the weight of that generator.  For
    example, in the following generator, a [Leaf] will be generated 1
    / (sz + 1) of the time and a [Node] the remaining sz / (sz + 1) of
    the time. *)

Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => ret Leaf
    | S sz' =>
        freq [ (1,  ret Leaf) ;
               (sz, liftM3 Node g (genTreeSized' sz' g)
                                  (genTreeSized' sz' g))
             ]
  end.

(* Sample (genTreeSized' 3 (choose(0,3))).

     ===>
         [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf))
                    (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))),
           Leaf,
           Node (2) (Node (1) (Leaf) (Leaf)) (Leaf),
           Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf))
                                     (Node (0) (Leaf) (Leaf))),
           Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf),
           Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf)))
                    (Node (2) (Leaf) (Leaf)),
           Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf)))
                    (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
           Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf)))
                    (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
           Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf))
                                                       (Node (2) (Leaf) (Leaf))),
           Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf))
                    (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)),
           Leaf,
           Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
           Leaf,
           Node (1) (Leaf) (Leaf),
           Leaf,
           Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf)))
                    (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))),
           Leaf,
           Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf))
                    (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
           Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf))
                    (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
           Leaf ]
*)

(** This looks better. *)

(** **** Exercise: 2 stars, standard (genListSized)

    Write a sized generator for lists, following [genTreeSized']. *)

(* FILL IN HERE

    [] *)

(** **** Exercise: 3 stars, standard (genColorOption)

    Write a custom generator for values of type [option color].  Make
    it generate [None] about 1/10th of the time, and make it generate
    [Some Red] three times as often as the other colors. *)

(* FILL IN HERE

    [] *)

(* ================================================================= *)
(** ** Checkers *)

(** To showcase how such generators can be used to find
    counterexamples, suppose we define a function for "mirroring" a
    tree -- swapping its left and right subtrees recursively. *)

Fixpoint mirror {A : Type} (t : Tree A) : Tree A :=
  match t with
    | Leaf => Leaf
    | Node x l r => Node x (mirror r) (mirror l)
  end.

(** To formulate a property about [mirror], we need a structural
    equality test on trees.  We can obtain that with minimal effort
    using the [Dec] typeclass and the [dec_eq] tactic. *)

Instance eq_dec_tree (t1 t2 : Tree nat) : Dec (t1 = t2).
Proof. constructor; dec_eq. Defined.

(** We expect that mirroring a tree twice should yield the original
    tree.  *)

Definition mirrorP (t : Tree nat) := (mirror (mirror t)) = t?.

(** Now we want to use our generator to create a lot of random trees
    and, for each one, check whether [mirrorP] returns [true] or
    [false].

    Another way to say this is that we want to use [mirrorP] to build
    a _generator for test results_.

    Let's see how this works. *)

(** (Let's open a playground module so we can show simplified
    versions of the actual QuickChick definitions.) *)

Module CheckerPlayground1.

(** First, we need a type of test results -- let's call it [Result].
    For the moment, think of [Result] as just an enumerated type with
    constructors [Success] and [Failure].  *)

Inductive Result := Success | Failure.

Instance showResult : Show Result :=
  {
    show r := match r with Success => "Success" | Failure => "Failure" end
  }.

(** Then we can define the type [Checker] to be [G Result]. *)

Definition Checker := G Result.

(** That is, a [Checker] embodies some way of performing a randomized
    test of the truth of some proposition, which, when applied to a
    random seed, will yield either [Success] (meaning that the
    proposition survived this test) or [Failure] (meaning that this
    test demonstrates that the proposition was false).

    Sampling a [Checker] many times with different seeds will cause
    many different tests to be performed. *)

(** To check [mirrorP], we'll need a way to build a [Checker] out of a
    function from trees to booleans.

    Actually, we will be wanting to build [Checker]s based on many
    different types.  So let's begin by defining a typeclass
    [Checkable], where an instance for [Checkable A] will provide a
    way of converting an [A] into a [Checker]. *)

Class Checkable A :=
  {
    checker : A -> Checker
  }.

(** It is easy to give a [bool] instance for [Checkable]. *)

Instance checkableBool : Checkable bool :=
  {
    checker b := if b then ret Success else ret Failure
  }.

(** That is, the boolean value [true] passes every test we might
    subject it to (i.e., the result of [checker] is a [G] that returns
    [true] for every seed), while [false] fails all tests. *)

(** Let's see what happens if we sample checkers for our favorite
    booleans, [true] and [false].  *)

(** (We need to exit the playground so that we can do [Sample]:
    because [Sample] is implemented internally via extraction to
    OCaml, which usually does not work from inside a [Module].) *)

End CheckerPlayground1.

(* Sample (CheckerPlayground1.checker true).

     ===>
      [Success, Success, Success, Success, Success, Success, Success,
       Success, Success, Success, Success]
*)

(* Sample (CheckerPlayground1.checker false).

     ===>
      [Failure, Failure, Failure, Failure, Failure, Failure, Failure,
       Failure, Failure, Failure, Failure]
*)

(** What we've done so far may look a a bit strange, since these
    checkers always generate the same results.  We'll make things more
    interesting in a bit, but first let's pause to define one more
    basic instance of [Checkable]. *)

(** A decidable [Prop] is not too different from a boolean, so we
    should be able to build a checker from that too. *)

Module CheckerPlayground2.
Export CheckerPlayground1.

Instance checkableDec `{P : Prop} `{Dec P} : Checkable P :=
  {
    checker p := if P? then ret Success else ret Failure
  }.

(** (The definition looks a bit strange since it doesn't use its
    argument [p].  The intuition is that all the information in [p] is
    already encoded in [P]!) *)

(** Now suppose we pose a couple of (decidable) conjectures: *)

Conjecture c1 : 0 = 42.
Conjecture c2 : 41 + 1 = 42.

End CheckerPlayground2.

(** The somewhat astononishing thing about the [Checkable] instance
    for decidable [Prop]s is that, even though these are
    _conjectures_ (we haven't proved them, so the "evidence" that Coq
    has for them internally is just an uninstantiated "evar"), we can
    still build checkers from them and sample from these
    checkers! (Why?  Technically, it is because the [Checkable]
    instance for decidable properties does not look at its
    argument.) *)

(*  Sample (CheckerPlayground1.checker CheckerPlayground2.c1).

     ===>
      [Failure, Failure, Failure, Failure, Failure, Failure, Failure,
       Failure, Failure, Failure, Failure]
*)

(* Sample (CheckerPlayground1.checker CheckerPlayground2.c2).

     ===>
      [Success, Success, Success, Success, Success, Success, Success,
       Success, Success, Success, Success]
*)

(** Again, the intuition is that, although we didn't present
    proofs (and could not have, in the first case!), Coq already
    "knows" either a proof or a disproof of each of these conjectures
    because they are decidable. *)

Module CheckerPlayground3.
Import CheckerPlayground2.

(** Now let's go back to [mirrorP].

    We have seen that the result of [mirrorP] is [Checkable].  What we
    need is a way to take a function returning a checkable thing and
    make the function itself checkable.

    We can easily do this, as long as the argument type of the
    function is something we know how to generate! *)

Definition forAll {A B : Type} `{Checkable B}
             (g : G A) (f : A -> B)
           : Checker :=
  a <- g ;;
  checker (f a).

End CheckerPlayground3.

(** Let's try this out!

    First, let's revisit our color example to execute a simple check.
    We can define a boolean test that returns [true] for [Red] and
    [false] for other colors. *)

Definition isRed c :=
  match c with
    Red => true
  | _ => false
  end.

(** Since we can generate elements of [color] and we have a
    [Checkable] instance for [bool], we can apply [forAll] to [isRed]
    and sample from the resulting [Checker] to run some tests. *)

(* Sample (CheckerPlayground3.forAll genColor isRed).

     ===>
      [Success, Failure, Failure, Failure, Success, Failure,
       Failure, Success, Failure, Failure, Success]
*)

(** Looks like not all colors are [Red].

    Good to know. *)

(** Now back to a more realistic example. What about [mirrorP]? *)

(*
Sample (CheckerPlayground3.forAll
          (genTreeSized' 3 (choose(0,3)))
          mirrorP).
*)
(**

     ===>
      [Success, Success, Success, Success, Success, Success, Success,
       Success, Success, Success, Success]
*)

(** Excellent: It looks like many tests are succeeding -- maybe the
    property is true. *)

(** Let's instead try defining a bad property and see if we can detect
    that it's bad... *)

Definition faultyMirrorP (t : Tree nat) := (mirror t) = t ?.

(*
Sample (CheckerPlayground3.forAll
          (genTreeSized' 3 (choose(0,3)))
          faultyMirrorP).
*)
(**

     ===>
      [Failure, Success, Failure, Success, Success, Success, Failure,
       Success, Failure, Failure, Success]
*)

(** Great -- looks like a good number of tests are failing now, as
    expected. *)

(** There's only one little issue: What _are_ the tests that are
    failing?  We can tell by looking at the samples that the property
    is bad, but we can't see the counterexamples!

    We can fix this by going back to the beginning and enriching the
    [Result] type to keep track of failing counterexamples. *)

Module CheckerPlayground4.

Inductive Result :=
  | Success : Result
  | Failure : forall {A} `{Show A}, A -> Result.

Instance showResult : Show Result :=
  {
    show r := match r with
                Success => "Success"
              | Failure a => "Failure: " ++ show a
              end
  }.

Definition Checker := G Result.

Class Checkable A :=
  {
    checker : A -> Checker
  }.

Instance showUnit : Show unit :=
  {
    show u := "tt"
  }.

(** The failure cases in the [bool] and [Dec] checkers don't need to
    record anything except the [Failure], so we put [tt] (the sole
    value of type [unit]) as the "failure reason." *)

Instance checkableBool : Checkable bool :=
  {
    checker b := if b then ret Success else ret (Failure tt)
  }.

Instance checkableDec `{P : Prop} `{Dec P} : Checkable P :=
  {
    checker p := if P? then ret Success else ret (Failure tt)
  }.

(** The interesting case is the [forAll] combinator.  Here, we _do_
    have some useful information to record in the failure case --
    namely, the argument that caused the failure. *)

Definition forAll {A B : Type} `{Show A} `{Checkable B}
                  (g : G A) (f : A -> B)
                : Checker :=
  a <- g ;;
  r <- checker (f a) ;;
  match r with
    Success => ret Success
  | Failure b => ret (Failure (a,b))
  end.

(** Note that, rather than just returning [Failure a], we package up
    [a] together with [b], which explains the reason for the failure
    of [f a].  This allows us to write several [forAll]s in sequence
    and capture all of their results in a nested tuple. *)

End CheckerPlayground4.

(*
Sample (CheckerPlayground4.forAll
          (genTreeSized' 3 (choose(0,3)))
          faultyMirrorP).
*)
(**

     ===>
      [Failure: (Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf))
                          (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)), tt),
      Success,
      Failure: (Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf), tt),
      Success, Success, Success,
      Failure: (Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf)))
                         (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))), tt),
      Success,
      Failure: (Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf))
                         (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))), tt),
      Failure: (Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf))
                         (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))), tt),
      Success]
*)

(** The bug is found several times and actual counterexamples are
    reported: nice! *)

(** Sampling repeatedly from a generator is just what the [QuickChick]
    command does, except that, instead of running a fixed number of
    tests and returning their results in a list, it runs tests only
    until the first counterexample is found. *)

(*
QuickChick
  (forAll
     (genTreeSized' 3 (choose(0,3)))
     faultyMirrorP).
*)
(**

     ===>
     QuickChecking (forAll (genTreeSized' 3 (choose (0, 3))) faultyMirrorP)

     Node (0) (Node (0) (Node (2) (Leaf) (Leaf))
                        (Node (1) (Leaf) (Leaf)))
              (Node (1) (Node (0) (Leaf) (Leaf)) (Leaf))

     *** Failed after 1 tests and 0 shrinks. (0 discards)
*)

(** However, these counterexamples themselves still leave something to
    be desired: they are all _much_ larger than is really needed to
    illustrate the bad behavior of [faultyMirrorP].

    This is where _shrinking_ comes in. *)

(* ################################################################# *)
(** * Shrinking *)

(** Shrinking (sometimes known as "delta debugging") is a process
    that, given a counterexample to some property, searches (greedily)
    for smaller counterexamples.

    Given a shrinking function [s] of type [A -> list A] and a value
    [x] of type [A] that is known to falsify some property [P],
    QuickChick tries [P] on all members of [s x] until it finds
    another counterexample.  It repeats this process, starting from
    the new counterexample, until it reaches a point where [x] fails
    property [P] but every element of [s x] succeeds.  This [x] is a
    "locally minimal" counterexample. *)

(** Clearly, this greedy algorithm only work if all elements of
    [s x] are strictly "smaller" than [x] for all [x] -- that is,
    there should be some total order on the type of [x] such that [s]
    is strictly decreasing in this order.  This is the basic
    correctness requirement for a shrinker.  It is guaranteed by all
    the shrinkers that QuickChick derives automatically, but ifyou
    roll your own shrinkers you need to be careful to maintain it. *)

(** Here is a shrinker for [color]s. *)

Instance shrinkColor : Shrink color :=
  {
    shrink c :=
      match c with
      | Red => [ ]
      | Green => [ Red ]
      | Blue => [ Red; Green ]
      | Yellow => [ Red; Green; Blue ]
      end
  }.

(** Most of the time, shrinking functions should try to return
    elements that are "just one step" smaller than the one they are
    given. For example, consider the default shrinking function for
    lists provided by QuickChick. *)

Print shrinkList.
(**

     ===>
       shrinkList =
         fun (A : Type) (H : Shrink A) =>
            {| shrink := shrinkListAux shrink |}
       : forall A : Type, Shrink A -> Shrink (list A)

*)

Print shrinkListAux.
(**

     ===>
       shrinkListAux =
         fix shrinkListAux (A : Type) (shr : A -> list A) (l : list A) :
           list (list A) :=
           match l with
           | [] => []
           | x :: xs =>
               ((xs :: map (fun xs' : list A => x :: xs')
                           (shrinkListAux A shr xs)) ++
                map (fun x' : A => x' :: xs) (shr x))
           end
       : forall A : Type, (A -> list A) -> list A -> list (list A)
*)

(** An empty list cannot be shrunk, as there is no smaller list.  A
    cons cell can be shrunk in three ways: by returning the tail of
    the list, by shrinking the tail of the list and keeping the same
    head, or by shrinking the head and keeping the same tail. By
    induction, this process can generate all smaller lists.

    (Pro tip: One refinement to the advice that shrinkers should
    return "one step smaller" values is that, for potentially large
    data structures, it can sometimes greatly improve performance if a
    shrinker returns not only all the "slightly smaller" structures
    but also one or two "much smaller" structures.  E.g. for a number
    [x] greater than [2], we might shrink to [0; x div 2; pred x].) *)

(** Writing a shrinking instance for trees is equally straightforward:
    we don't shrink [Leaf]s, while for [Node]s we can either return
    the left or right subtree, or shrink the payload, or shrink one of
    the subtrees. *)

Open Scope list.
Fixpoint shrinkTreeAux {A}
              (s : A -> list A) (t : Tree A)
            : list (Tree A) :=
  match t with
    | Leaf => []
    | Node x l r => [l] ++ [r] ++
                    map (fun x' => Node x' l r) (s x) ++
                    map (fun l' => Node x l' r) (shrinkTreeAux s l) ++
                    map (fun r' => Node x l r') (shrinkTreeAux s r)
  end.

Instance shrinkTree {A} `{Shrink A} : Shrink (Tree A) :=
  {| shrink x := shrinkTreeAux shrink x |}.

(** With [shrinkTree] in hand, we can use the [forAllShrink] property
    combinator, a variant of [forAll] that takes a shrinker as an
    additional argument, to test properties like [faultyMirrorP]. *)

(*
  QuickChick
       (forAllShrink
          (genTreeSized' 5 (choose (0,5)))
          shrink
          faultyMirrorP).
*)
(**

     ===>
       Node (0) (Leaf) (Node (0) (Leaf) (Leaf))

       *** Failed! After 1 tests and 8 shrinks
*)

(** We now get a quite simple counterexample (in fact, one of two
    truly minimal ones), from which it is easy to see that the bad
    behavior occurs when the subtrees of a [Node] are different. *)

(* ================================================================= *)
(** ** Exercise: Ternary Trees *)

(** For a comprehensive but still fairly simple exercise involving
    most of what we have seen, let's consider ternary trees, whose
    nodes have three childen instead of two. *)

Inductive TernaryTree A :=
| TLeaf : TernaryTree A
| TNode :
    A -> TernaryTree A -> TernaryTree A -> TernaryTree A -> TernaryTree A.

Arguments TLeaf {A}.
Arguments TNode {A} _ _ _ _.

(** Also consider the following (faulty?) mirror function. We'll want to do some
    testing to see what we can find about this function. *)

Fixpoint tern_mirror {A : Type} (t : TernaryTree A) : TernaryTree A :=
  match t with
    | TLeaf => TLeaf
    | TNode x l m r => TNode x (tern_mirror r) m (tern_mirror l)
  end.

(** **** Exercise: 1 star, standard (show_tern_tree)

    Write a [Show] instance for Ternary Trees. *)

(* FILL IN HERE

    [] *)

(** **** Exercise: 2 stars, standard (gen_tern_tree)

    Write a generator for ternary trees. *)

(* FILL IN HERE *)

(** The following line should generate a bunch of nat ternary trees. *)
(* Sample (@genTernTreeSized nat 3 (choose (0,10))).

    [] *)

(** **** Exercise: 2 stars, standard (shrink_tern_tree)

    Write a shrinker for ternary trees. *)

(* FILL IN HERE

    [] *)

(** From the root node, we can define a path in a ternary tree by first
    defining a direction corresponding to a choice of child tree... *)

Inductive direction := Left | Middle | Right.

(** A direction tells us which child node we wish to visit. The
    [traverse_node] function uses a [direction] to visit the
    corresponding child. *)

Definition traverse_node {A} (t:direction) (l m r: TernaryTree A) :=
  match t with
  | Left => l
  | Middle => m
  | Right => r
  end.

(** A [path] in a ternary tree is a list of [direction]s. *)
Definition path := list direction.

(** We can traverse a path by iterating over the [direction]s in the
    path and traversing the corresponding nodes. *)

Fixpoint traverse_path {A} (p:path) (t: TernaryTree A) :=
  match t with
  | TLeaf =>
    TLeaf
  | TNode x l m r =>
    match p with
    | h :: tl => traverse_path tl (traverse_node h l m r)
    | [] => t
    end
  end.

(** And we can mirror a path by simply swapping left and
    right throughout. *)

Definition path_mirror := map (fun t => match t with
                                     | Left => Right
                                     | Right => Left
                                     | _ => t
                                     end).

(** Before we can state some properties about paths in ternary trees, it's
    useful to have a decidable equality for ternary trees of [nat]s. *)

Instance eq_dec_tern_tree (t1 t2 : TernaryTree nat) : Dec (t1 = t2).
Proof. constructor; dec_eq. Defined.

(** Traversing a path in a tree should be the same as traversing the
    mirror of the path in the mirror of the tree, just with a mirrored
    tree result. *)

Definition tern_mirror_path_flip (t:TernaryTree nat) (p:path) :=
  (  traverse_path p t
   = tern_mirror (traverse_path (path_mirror p) (tern_mirror t))) ?.

(** Before using this property to test [tern_mirror], we'll need to be
    able to generate, show, and shrink paths. To start, we'll derive
    those For [directions]. The [Show] and [G] definitions for
    [direction] are simple to write; the [shrink] will by default go
    left. *)

Instance showDirection : Show direction :=
  {| show x :=
       match x with
       | Left => "Left"
       | Middle => "Middle"
       | Right => "Right"
       end |}.

Definition genDirection : G direction :=
  elems [Left; Middle; Right].

Instance shrinkDirection : Shrink direction :=
  {| shrink d :=
       match d with
       | Left => []
       | Right | Middle => [Left]
       end |}.

(** For generating a list of paths, we'll use the built-in function
    [listOf], which takes a generator for a type and generates lists
    of elements of that type.  We do the same for [show] and [shrink]
    with [showList] and [shrinkList] respectively. *)

Instance showPath : Show path := showList.

Definition genPath : G path :=
  listOf genDirection.

Instance shrinkPath : Shrink path := shrinkList.

(** **** Exercise: 4 stars, standard (bug_finding_tern_tree)

    Using [genTernTreeSized] and [shrinkTernTree] find (and fix!) any
    bugs in [tern_mirror]. *)

(* FILL IN HERE

    [] *)

(* ################################################################# *)
(** * Putting it all Together *)

(** Now we've got pretty much all the basic machinery we need, but the
    way we write properties -- using [forAllShrink] and explicitly
    providing generators and shrinkers -- is still heavier than it
    needs to be.  We can use a bit more typeclass magic to further
    lighten things.

    First, we introduce a typeclass [Gen A] with a single operator
    [arbitrary] of type [G A]. *)

Module DefineGen.

Class Gen (A : Type) :=
  {
    arbitrary : G A
  }.

End DefineGen.

(** Intuitively, [Gen] is a way of uniformly packaging up the
    generators for various types so that we do not need to remember
    their individual names -- we can just call them all
    [arbitrary]. *)

Instance gen_color : Gen color :=
  {
    arbitrary := genColor
  }.

(** Next, for convenience we package [Gen] and [Shrink] together into
    an [Arbitrary] typeclass that is a subclass of both. *)

Module DefineArbitrary.
Import DefineGen.

Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.

(** (The empty "body" of [Arbitrary] is elided.) *)

End DefineArbitrary.

(** We can use the top-level [QuickChick] command on quantified
    propositions with generatable and decidable conclusions, stating
    just the property and letting the typeclass machinery figure out
    the rest.

    For example, suppose we want to test this: *)

Conjecture every_color_is_red : forall c, c = Red.

(** Since we have already defined [Gen] and [Shrink] instances for
    [color], we automatically get an [Arbitrary] instance.  The [Gen]
    part is used by the checker instance for "forall" propositions to
    generate random [color] arguments.

    To show that the conclusion is decidable, we need to define a
    [Dec] instance for equality on colors. *)

Instance eq_dec_color (x y : color) : Dec (x = y).
Proof. dec_eq. Defined.

(** Putting it all together: *)

(*  QuickChick every_color_is_red.

     ===>
       QuickChecking every_color_is_red
       Green
       *** Failed after 1 tests and 1 shrinks. (0 discards)
*)

(* ################################################################# *)
(** * Sized Generators *)

(** Suppose we want to build an [Arbitrary] instance for trees.

    We would like to use [genTreeSized']; however, that generator
    takes an additional [size] argument.

    Fortunately, since the [G] monad itself includes a size argument,
    we can "plumb" this argument into generators like [genTreeSized'].

    In other words, we can define an operator [sized] that takes a
]    sized generator and produces an unsized one. *)

Module DefineSized.
Import DefineG.

Definition sized {A : Type} (f : nat -> G A) : G A :=
  MkG
      (fun n r =>
         match f n with
           MkG g => g n r
         end).

End DefineSized.
(** To streamline assembling generators, it is convenient to introduce
    one more typeclass, [GenSized], whose instances are sized
    generators. *)

Module DefineGenSized.

Class GenSized (A : Type) :=
  {
    arbitrarySized : nat -> G A
  }.

(** We can then define a generic [Gen] instance for types that have a
    [GenSized] instance, using [sized]: *)

Instance GenOfGenSized {A} `{GenSized A} : Gen A :=
  {
    arbitrary := sized arbitrarySized
  }.

End DefineGenSized.

(** Now we can make a [Gen] instance for trees by providing just an
    implementation of [arbitrarySized]. *)

Instance genTree {A} `{Gen A} : GenSized (Tree A) :=
  {| arbitrarySized n := genTreeSized' n arbitrary |}.

(** Finally, with the [Arbitrary] instance for trees, we can supply
    just [faultyMirrorP] to the [QuickChick] command. *)

(* QuickChick faultyMirrorP. *)

(** **** Exercise: 2 stars, standard (tern_tree_typeclasses)

    Add typeclass instances for [GenSized] and [Shrink] so that you
    can [QuickChick tern_mirror_reverse] directly. *)

(* FILL IN HERE *)

(* QuickChick tern_mirror_reverse.

    [] *)

(* ################################################################# *)
(** * Automation *)

(** Writing [Show] and [Arbitrary] instances is usually not hard, but
    it can get tedious when we are testing code that involves many new
    [Inductive] type declarations.  To streamline this process,
    [QuickChick] provides some automation for deriving such instances
    for "plain datatypes" automatically! *)

Derive Arbitrary for Tree.
(**

     ===> GenSizedree is defined
     ===> ShrinkTree is defined
*)
Print GenSizedTree.
Print ShrinkTree.

Derive Show for Tree.
(**
     ===> ShowTree is defined
*)
Print ShowTree.

(* ################################################################# *)
(** * Collecting Statistics *)

(** Earlier in this tutorial we observed that our first definition of
    [genTreeSized] seemed to be producing too many [Leaf]
    constructors.

    In that case, just eyeballing at a few results from [Sample] gave
    us an idea that something was wrong with the distribution of test
    cases, but it's often useful to collect more extensive statistics
    from larger sets of samples.

    This is where [collect], another property combinator, comes in. *)

Check @collect.
(**

     ===>
     @collect
       : forall A prop : Type, Show A -> Checkable prop ->
           A -> prop -> Checker
*)

(** That is, [collect] takes a checkable proposition and returns a new
    [Checker] (for the same proposition).

    On the side, it takes a value from some [Show]able type [A], which
    it remembers internally (in an enriched variant of the [Result]
    structure that we saw above) so that it can be collated and
    displayed at the end. *)

(** For example, suppose we measure the [size] of [Tree]s like this: *)

Fixpoint size {A} (t : Tree A) : nat :=
  match t with
    | Leaf => O
    | Node _ l r => 1 + size l + size r
  end.

(** We can write a dummy property [treeProp] to collect the sizes of
    the trees we are generating. *)

Definition treeProp (g : nat -> G nat -> G (Tree nat)) n :=
  forAll (g n (choose (0,n))) (fun t => collect (size t) true).

(* QuickChick (treeProp genTreeSized 5).

     ===>
       4947 : 0
       1258 : 1
       673 : 2
       464 : 6
       427 : 5
       393 : 3
       361 : 7
       302 : 4
       296 : 8
       220 : 9
       181 : 10
       127 : 11
       104 : 12
       83 : 13
       64 : 14
       32 : 15
       25 : 16
       16 : 17
       13 : 18
       6 : 19
       5 : 20
       2 : 21
       1 : 23

       +++ OK, passed 10000 tests
*)

(** We see that 62.5%% of the tests (4947 + 1258 / 10000) are either
    [Leaf]s or empty [Node]s, while rather few tests have larger
    sizes.  *)

(** Compare this with [genTreeSized'].  *)

(* QuickChick (treeProp genTreeSized' 5).

     ===>
       1624 : 0
       571 : 10
       564 : 12
       562 : 11
       559 : 9
       545 : 8
       539 : 14
       534 : 13
       487 : 7
       487 : 15
       437 : 16
       413 : 6
       390 : 17
       337 : 5
       334 : 1
       332 : 18
       286 : 19
       185 : 4
       179 : 20
       179 : 2
       138 : 21
       132 : 3
       87 : 22
       62 : 23
       19 : 24
       10 : 25
       6 : 26
       2 : 27

       +++ OK, passed 10000 tests
*)

(** This generates far fewer tiny examples, likely leading to more
    efficient testing of interesting properties. However, there are
    still a lot of empty trees being generated.  Can we do something
    about that?
 *)

(** **** Exercise: 2 stars, standard (genTreeSized'')

    Write a generator [genTreeSized''] that generates fewer empty
    trees. Check your results using [collect].
*)

(* FILL IN HERE

    [] *)

(* ################################################################# *)
(** * Dealing with Preconditions *)

(** A large class of properties that are commonly encountered in
    property-based testing are _properties with preconditions_.  The
    default QuickChick approach of generating inputs based on type
    information can be inefficient for such properties, especially for
    those with sparse preconditions (i.e. ones that are satisfied
    rarely with respect to their input domain). *)

Open Scope bool.

(** Consider a function that inserts a natural number into a sorted list. *)

Fixpoint sorted (l : list nat) :=
  match l with
  | [] => true
  | x::xs => match xs with
             | [] => true
             | y :: ys => (x <=? y) && (sorted xs)
             end
  end.

Fixpoint insert (x : nat) (l : list nat) :=
  match l with
  | [] => [x]
  | y::ys => if x <=? y then x :: l
             else y :: insert x ys
  end.

(** We could test [insert] using the following _conditional_ property: *)

Definition insert_spec (x : nat) (l : list nat) :=
  sorted l ==> sorted (insert x l).

Definition test_insert_spec :=
  forAll (choose (0,10)) (fun x =>
  forAll (listOf (choose (0,10))) (fun l =>
  insert_spec x l)).

(* QuickChick test_insert_spec.

     ===>
       QuickChecking test_insert_spec
       +++ Passed 10000 tests (17325 discards)
*)

(** To test this property, QuickChick will try to generate random
    integers [x] and lists [l], _check_ whether the generated [l] is
    sorted, and, if it is, proceed to check the conclusion. If it is
    not, it will discard the generated inputs and try again.

    As we can see, this can lead to many discarded tests (in this
    case, about twice as many as successful ones), which wastes a
    lot of CPU and leads to inefficient testing. *)

(** But the wasted effort is the least of our problems! Let's take a
    peek at the distribution of the lengths of generated lists using
    [collect]. *)

Definition insert_spec' (x : nat) (l : list nat) :=
  collect (List.length l) (insert_spec x l).

Definition test_insert_spec' :=
  forAll (choose (0,10)) (fun x =>
  forAll (listOf (choose (0,10))) (fun l =>
  insert_spec' x l)).

(* QuickChick test_insert_spec'.

     ===>
   QuickChecking insert_spec'
   3652 : (Discarded) 7
   3582 : 0
   3568 : (Discarded) 6
   3542 : 1
   3469 : (Discarded) 5
   3200 : (Discarded) 4
   2830 : (Discarded) 3
   1842 : 2
   1606 : (Discarded) 2
   716 : 3
   248 : 4
   61 : 5
   8 : 6
   1 : 7
   +++ Passed 10000 tests (18325 discards)
*)
(** The vast majority of inputs have length 2 or less, while the larger
    lists are almost always discarded!

    (This explains something you might have found suspicious in the
    previous statistics: that 1/3 of the randomly generated lists were
    already sorted!) *)

(** When dealing with properties with preconditions, it is common
    practice to write custom generators for well-distributed random
    data that satisfy the property. *)

(** For example, we can generate sorted lists with elements between
    [low] and [high] like this... *)

Fixpoint genSortedList (low high : nat) (size : nat)
             : G (list nat) :=
  match size with
  | O => ret []
  | S size' =>
    if high <? low then
      ret []
    else
      freq [ (1, ret []) ;
             (size, x <- choose (low, high);;
                    xs <- genSortedList x high size';;
                    ret (x :: xs)) ] end.

(** We use a [size] parameter as usual to control the length of generated
    lists. *)

(** If [size] is zero, we can only return the empty list which
    is always sorted. If [size] is nonzero, we need to perform an
    additional check whether [high] is less than [low] (in which case
    we also return the empty list).  If it is not, we can proceed to
    choose to generate a cons cell, with its head generated between
    [low] and [high] and its tail generated recursively. *)

(* Sample (genSortedList 0 10 10). *)

(** Finally, we can use [forAllShrink] to define a property using the
    new generator: *)

Definition insert_spec_sorted (x : nat) :=
  forAllShrink
    (genSortedList 0 10 10)
    shrink
    (fun l => insert_spec' x l).

(** Now the distribution of lengths looks much better, and we don't
    discard any tests! *)

QuickChick insert_spec_sorted.
(**

     ===>
       QuickChecking insert_spec_sorted
       947 : 0
       946 : 4
       946 : 10
       938 : 6
       922 : 9
       916 : 2
       900 : 7
       899 : 3
       885 : 8
       854 : 5
       847 : 1
       +++ Passed 10000 tests (0 discards)
*)
(** Does this mean we are happy? *)

(** **** Exercise: 5 stars, standard, optional (uniform_sorted)

    Using "collect", find out whether generating a sorted list of
    numbers between 0 and 5 is uniform in the frequencies with which
    different _numbers_ are found in the generated lists.

    If not, figure out why.  Then write a different generator that
    achieves a more uniform distribution (preserving uniformity in the
    lengths). *)

(* FILL IN HERE

    [] *)

(* ================================================================= *)
(** ** Another Precondition: Binary Search Trees *)

(** To conclude this chapter, let's look at _binary search trees_.

    The [isBST] predicate characterizes trees with elements between
    [low] and [high]. *)

Fixpoint isBST (low high: nat) (t : Tree nat) :=
  match t with
  | Leaf => true
  | Node x l r => (low <? x) && (x <? high)
                  && (isBST low x l) && (isBST x high r)
  end.

(** Here is a (faulty?) insertion function for binary search trees. *)

Fixpoint insertBST (x : nat) (t : Tree nat) :=
  match t with
  | Leaf => Node x Leaf Leaf
  | Node x' l r => if x <? x' then Node x' (insertBST x l) r
                   else Node x' l (insertBST x r)
  end.

(** We would expect that if we insert an element that is within
    the bounds [low] and [high] into a binary search tree, then
    the result is also a binary search tree. *)

Definition insertBST_spec (low high : nat) (x : nat) (t : Tree nat) :=
  (low <? x) ==>
  (x <? high) ==>
  (isBST low high t) ==>
  isBST low high (insertBST x t).

(* QuickChick insertBST_spec.

    ===>
      QuickChecking insertBST_spec
      0
      5
      4
      Node (4) (Leaf) (Leaf)
      *** Failed after 85 tests and 1 shrinks. (1274 discards)
*)

(** We can see that a bug exists when inserting an element into a
    [Node] with the same payload: if the element already exists in the
    binary search tree, we should not change it. *)

(** However we are wasting too much testing effort.  Indeed, if we fix the
    bug ... *)

Fixpoint insertBST' (x : nat) (t : Tree nat) :=
  match t with
  | Leaf => Node x Leaf Leaf
  | Node x' l r => if x <? x' then Node x' (insertBST' x l) r
                   else if x' <? x then Node x' l (insertBST' x r)
                   else t
  end.

Definition insertBST_spec' (low high : nat) (x : nat) (t : Tree nat) :=
  (low <? x) ==> (x <? high) ==> (isBST low high t) ==>
  isBST low high (insertBST' x t).

(** ... and try again... *)

(* QuickChick insertBST_spec'.

     ===>
     QuickChecking insertBST_spec'
     *** Gave up! Passed only 1281 tests
     Discarded: 20000
*)
(** ... we see that 90%% of tests are being discarded. *)

(** **** Exercise: 4 stars, standard (gen_bst)

    Write a generator that produces binary search trees directly, so
    that you run 10000 tests with 0 discards. *)

(* FILL IN HERE

    [] *)

(* 2020-10-14 10:23 *)


(* -------------------------------------------------------------------- *)
Require Import ssreflect ssrbool List.

Set Implicit Arguments.

Axiom todo : forall {A}, A.
Ltac todo := by apply: todo.

(* ==================================================================== *)
(* This template contains incomplete definitions that you have to       *)
(* fill. We always used the keyword `Definition` for all of them but    *)
(* you are free to change for a `Fixpoint` or an `Inductive`.           *)
(*                                                                      *)
(* If needed, it is perfectly fine to add intermediate definitions and  *)
(* local lemmas.                                                        *)

(* ==================================================================== *)
(* In this project, we are going to develop and prove correct an        *)
(* algorithm for deciding the membership of a word w.r.t. a given       *)
(* regular language - all these terms are going to be defined below     *)

(* This project lies in the domain of *formal languages*. The study     *)
(* of formal languages is a branch of theoretical computer science and  *)
(* is about that is interested in the purely syntactical aspects of     *)
(* of languages and as applications in different domains, ranging from  *)
(* the definition of  the grammar of programming languages to the field *)
(* of automated translation.                                            *)

(* As with natural languages, we first need to fix an alphabet. In our  *)
(* case, we are simply going to declare a type `A : Type` - i.e. we     *)
(* will use the same alphabet for all the formal languages we are going *)
(* to study. Inhabitants of `A` are called `letters`.                   *)

Parameter (A : Type).

(* -------------------------------------------------------------------- *)
(* A `word` is then simply a finite sequence of letters of `A`. We      *)
(* denote by A* the set of words over `A`. In Coq, we are going to      *)
(* represent words as lists whose elements are inhabitants of `A`. This *)
(* naturally leads to the following definition:                         *)

Notation word := (list A).

(* -------------------------------------------------------------------- *)
(* In this setting, a `language` is simply a subset of A*. Assuming     *)
(* that `x` & `y` are letters of A, we can define the following         *)
(* languages:                                                           *)
(*                                                                      *)
(*  - the empty language: `L = ∅`;                                      *)
(*                                                                      *)
(*  - the language that contains only the empty word ε (i.e. the only   *)
(*    (word of length 0): L = {ε}`;                                     *)
(*                                                                      *)
(*  - the language that contains all the words solely composed of the   *)
(*    letter `x`: L = { ε, x, xx, xxx, ... } = { xⁿ | n ∈ ℕ } (here,    *)
(*    xⁿ stands for the word x…x, where x is repeated n times);         *)
(*                                                                      *)
(*  - the language that contains all the words of the form xⁿyⁿ:        *)
(*    L = { xⁿyⁿ | n ∈ ℕ };                                             *)
(*                                                                      *)
(*  - if we assume that A contains the letter '[' & ']', we can         *)
(*    define the language of well-balanced words for '[' & ']':         *)
(*    L = { w ∈ { [, ] }* | s.t. P(w) && Q(w) }, where                  *)
(*      - P(w) = any prefix of w contain no more ]'s then ['s           *)
(*      - Q(w) = the number of ['s and ]'s of w are equal.              *)

(* -------------------------------------------------------------------- *)
(* We can also combine languages to form other languages. For example,  *)
(* if L and G are languages, we can define:                             *)
(*                                                                      *)
(*  - the union of L & G            L ∪ G                               *)
(*  - the concatenation of L & G    { w1 · w2 | w1 ∈ L, w2 ∈ G }        *)
(*  - the intersection of L & G     L ∩ G                               *)
(*  - the complement of L           A* \ L                              *)
(*  - the Kleene closure of L       L* = { wⁿ | w ∈ L, n ∈ ℕ }          *)
(*  - the mirror of L               rev(L) = { rev(w) | w ∈ L }         *)

(* -------------------------------------------------------------------- *)
(* To define languages in Coq, we need a way to represent subsets       *)
(* of A*, i.e. subsets of the set of `word`'s. To that end, we are      *)
(* going to represent a set using its indicator function. (We remind    *)
(* that, given a subset F of an ambient set E, the indicator function   *)
(* of F is the function f_E from E to { ⊤, ⊥ } s.t.                     *)
(*                                                                      *)
(*                     f_E(x) = ⊤ iff x ∈ E                             *)

(* In Coq, the codomain of its indicator function is going to be a      *)
(* proposition: given a function `F : E -> Prop`, we say that x belongs *)
(* to `x` iff `f x` holds.                                              *)

Notation language := (word -> Prop).

(* -------------------------------------------------------------------- *)
(* From now use, we assume that L, G, H denote languages, x, y denote   *)
(* letters and that and w denotes a word.                               *)

Implicit Types (L G H : language) (x y : A) (w : word).

(* -------------------------------------------------------------------- *)
(* From there, we can define the following languages                    *)

(* The empty language: no words belong to it.                           *)
(* (its indicator function always return `False`)                       *)
Definition lang0 : language :=
  fun w => False.

(* The language that only contains the empty word.                      *)
Definition lang1 : language :=
  fun w => w = nil.

(* Q1. We now ask you to define the following languages                 *)

(*  Given a word `w0`, the language that only contains the word `w0`.   *)
Definition langW w0 : language :=
  fun w => w = w0.

(* Given a sequence `ws` of words, the language that contains all the   *)
(* the words `ws` and only these words.                                 *)
Definition langF (ws : list word) : language :=
  fun w => (In w ws).

(* Given a letter `x`, the language that only contains the letter `x`   *)
(* seen as a word of length 1.                                          *)
Definition langA x : language :=
  fun w => w = (cons x nil).

(* The union of the two languages `L` and `G`.                          *)
Definition langU L G : language :=
  fun w => (L w) \/ (G w).

(* The intersection of the two languages `L` and `G`.                   *)
Definition langI L G : language :=
  fun w => (L w) /\ (G w).

(* The concatenation of the two languages `L` and `G`.                  *)
Definition langS L G : language :=
  fun w => (exists s c : word, (s ++ c = w) /\ (L s) /\ (G c)).

(* The Kleene closure of the language `L`                               *)
Inductive langK L : language :=
  | kleene0 : (langK L) nil
  | kleeneA : forall w, L w -> langK L w
  | kleeneS : forall s c : word, (langK L) s -> ((langK L) c) -> ((langK L) (s ++ c)).

(* The mirror of the language `L` (You can use the `rev`, that reversed *)
(* a list, from the standard library. *)
Definition langM L : language :=
  fun w => (L (rev w)).

(* -------------------------------------------------------------------- *)
(* Given two languages, we will consider `L` & `G` equal iff they       *)
(* contain the same words:                                              *)

Definition eqL L G := forall w, L w <-> G w.

Infix "=L" := eqL (at level 90).

(* Q2. Prove the following equivalances:                                *)

Lemma concat0L L : langS lang0 L =L lang0.
Proof.
  move => w.
  split.
  move => h.
  case h.
  move => x h1.
  inversion h1.
  move: H => [h2 h3].
  move: h3 => [h4 h5].
  case h4.
  move => h.
  case h.
Qed.

Lemma concatL0 L : langS L lang0 =L lang0.
Proof.
  move => w.
  split.
  move => h.
  case h.
  move => x h1.
  inversion h1.
  move: H => [h2 h3].
  move: h3 => [h4 h5].
  case h5.
  move => h.
  case h.
Qed.

Lemma concat1L L : langS lang1 L =L L.
Proof.
  move => w; split.
  move => h.
  case h.
  move => x h1.
  inversion h1.
  move: H => [h2 h3].
  move: h3 => [h4 h5].
  inversion h4.
  inversion h2.
  rewrite H.
  simpl.
  apply h5.
  move => h.
  exists nil.
  exists w.
  split.
  simpl; reflexivity.
  split.
  reflexivity.
  apply h.
Qed.

Lemma concatL1 L : langS L lang1 =L L.
Proof.
  move => w; split.
  move => h.
  case h.
  move => x h1.
  inversion h1.
  move: H => [h2 h3].
  move: h3 => [h4 h5].
  inversion h5.
  inversion h2.
  rewrite H.
  rewrite app_nil_r.
  apply h4.
  move => H.
  exists w.
  exists nil.
  split.
  apply app_nil_r.
  split.
  apply H.
  reflexivity.
Qed.

Lemma concatA L G H : langS (langS L G) H =L langS L (langS G H).
Proof.
  move => w.
  split.
  move => h.
  inversion h.
  inversion H0.
  move: H1 => [h2 h3].
  move: h3 => [h4 h5].
  inversion h4.
  inversion H1.
  move: H2 => [h6 h7].
  move: h7 => [h8 h9].
  exists x1.
  exists (x2 ++ x0).
  split.
  rewrite app_assoc.
  rewrite h6.
  by rewrite h2.
  split.
  apply h8.
  exists x2.
  exists x0.
  split.
  reflexivity.
  split.
  apply h9.
  apply h5.
  move => h.
  inversion h.
  inversion H0.
  move: H1 => [h2 h3].
  move: h3 => [h4 h5].
  inversion h5.
  inversion H1.
  move: H2 => [h6 h7].
  move: h7 => [h8 h9].
  exists (x ++ x1).
  exists x2.
  split.
  rewrite app_assoc_reverse.
  rewrite h6.
  by rewrite h2.
  split.
  exists x.
  exists x1.
  split.
  trivial.
  split; auto.
  auto.
Qed.

Lemma unionC L G : langU L G =L langU G L.
Proof.
  move => w.
  split.
  move => H.
  inversion H.
  right.
  apply H0.
  left.
  apply H0.
  move => H.
  inversion H.
  right; done.
  left; done.
Qed.

Lemma interC L G : langI L G =L langI G L.
Proof.
  move => w.
  split.
  move => [h1 h2].
  split.
  apply h2.
  apply h1.
  move => [h1 h2].
  split.
  apply h2.
  apply h1.
Qed.

Lemma langKK L : langK (langK L) =L langK L.
Proof.
  move => w.
  split.
  elim.
  apply kleene0.
  move => w0 h.
  apply h.
  move => s c h1 h2 h3 h4.
  apply kleeneS.
  apply h2.
  apply h4.
  move => h.
  apply kleeneA.
  apply h.
Qed.

(* Note that, since languages are represented as indicator functions    *)
(* over `Prop`, we cannot assess that `L =L G` implies `L = G`.         *)

(* ==================================================================== *)
(*                          REGULAR LANGUAGES                           *)

(* We are now interested in a subclass of languages called "regular     *)
(* languages": a language `L` is said to be regular iff one of the      *)
(* following holds:                                                     *)
(*                                                                      *)
(*  - L = ∅ or L = {ε} or L = {x} for some x ∈ A ;                      *)
(*  - L = L1 ∪ L2 for L1, L2 regular languages ;                        *)
(*  - L = L1 · L2 for L1, L2 regular languages ;                        *)
(*  - L = G* for G a regular language.                                  *)

(* This kind of inductive definitions can be encoded in Coq using       *)
(* an inductive predicate `regular : language -> Prop` s.t.             *)
(*                                                                      *)
(*             L is regular iff `regular L` holds                       *)

(* Q3. complete the following definition of the predicate `regular`:    *)

Inductive regular : language -> Prop :=
  (* Any language equivalent to a regular language is regular *)
| REq L G of regular L & G =L L : regular G

  (* The empty language is regular *)
| REmpty : regular lang0
| R1 : regular lang1
| RA : forall x, regular (langA x)
| RUnion : forall L1 L2 : language, regular L1 -> regular L2 -> regular (langU L1 L2)
| RS : forall L1 L2 : language, regular L1 -> regular L2 -> regular (langS L1 L2)
| RKleene : forall L, regular L -> regular (langK L)
.

(* -------------------------------------------------------------------- *)
(* Q4. prove that `langW w` is regular.                                 *)

Lemma equalSaw a w : langW ((cons a nil) ++ w) =L langS (langA a) (langW w).
Proof.
  move => c.
  split.
  move => h.
  exists (a::nil).
  exists w.
  split.
  inversion h.
  reflexivity.
  split.
  reflexivity.
  reflexivity.
  move => h.
  inversion h.
  inversion H.
  move: H0 => [h1 h2].
  move: h2 => [h3 h4].
  inversion h3.
  inversion h4.
  symmetry in h1.
  rewrite h1.
  rewrite H0.
  rewrite H1.
  reflexivity.
Qed.

Lemma regularW w : regular (langW w).
Proof.
  induction w.
  apply R1.
  apply REq with (langS (langA a) (langW w)).
  apply RS.
  apply RA.
  apply IHw.
  apply (equalSaw a w).
Qed.

(* -------------------------------------------------------------------- *)
(* Q5. prove that `langM L` is regular, given that L is regular.        *)

Lemma EqlangM L G: L =L G -> langM L =L langM G.
Proof.
  move => h w.
  split.
  move => h1.
  apply h.
  apply h1.
  move => h1.
  apply h.
  apply h1.
Qed.

Lemma EqlangM0 : langM lang0 =L lang0.
Proof.
  move => w.
  split.
  move => h.
  case h.
  move => h.
  case h.
Qed.

Lemma EqlangM1 : langM lang1 =L lang1.
Proof.
  move => w.
  split.
  move => h.
  inversion h.
  move: (rev_eq_app w nil nil H0) => h1.
  simpl in h1.
  rewrite h1.
  reflexivity.
  move => h.
  inversion h.
  reflexivity.
Qed.

Lemma EqlangMA x: langM (langA x) =L langA x.
Proof.
  move => w.
  split.
  move => h.
  inversion h.
  move: (rev_eq_app w (x :: nil) nil H0) => h1.
  simpl in h1.
  rewrite h1.
  reflexivity.
  move => h.
  inversion h.
  reflexivity.
Qed.

Lemma EqlangMS L1 L2 : langM (langS L1 L2) =L langS (langM L2) (langM L1).
Proof.
  move => w.
  split.
  move => h.
  inversion h.
  inversion H.
  move: H0 => [h1 h2].
  move: h2 => [h3 h4].
  symmetry in h1.
  move: (rev_eq_app (w) x x0 h1) => h5.
  rewrite h5.
  exists (rev x0).
  exists (rev x).
  split.
  reflexivity.
  split.
  rewrite /langM rev_involutive.
  apply h4.
  rewrite /langM rev_involutive.
  apply h3.
  move => h.
  inversion h.
  inversion H.
  move: H0 => [h1 h2].
  move: h2 => [h3 h4].
  symmetry in h1.
  rewrite h1.
  unfold langM.
  exists (rev x0).
  exists (rev x).
  split.
  move: (rev_app_distr x x0) => h5.
  symmetry in h5.
  apply h5.
  split.
  apply h4.
  apply h3.
Qed.

Lemma langKTolangKM L w: langK L w -> langK (langM L) (rev w).
Proof.
  move => h.
  induction h.
  apply kleene0.
  apply kleeneA.
  rewrite /langM rev_involutive.
  apply H.
  rewrite (rev_app_distr s c).
  apply kleeneS.
  apply IHh2.
  apply IHh1.
Qed.

Lemma EqlangKM L : langM (langK L) =L langK (langM L).
Proof.
  move => w.
  split.
  move => h.
  move: (rev_involutive w) => h1.
  symmetry in h1.
  rewrite h1.
  apply langKTolangKM.
  apply h.
  move => h.
  induction h.
  apply kleene0.
  apply kleeneA.
  apply H.
  unfold langM.
  rewrite (rev_app_distr s c).
  apply kleeneS.
  apply IHh2.
  apply IHh1.
Qed.

Lemma regularM L : regular L -> regular (langM L).
Proof.
  move => h.
  induction h.
  apply REq with (langM L).
  apply IHh.
  move: (EqlangM H)=> h1.
  apply h1.
  apply REq with (lang0).
  apply REmpty.
  apply EqlangM0.
  apply REq with (lang1).
  apply R1.
  apply EqlangM1.
  apply REq with (langA x).
  apply RA.
  apply EqlangMA.
  apply RUnion.
  apply IHh1.
  apply IHh2.
  apply REq with (langS (langM L2) (langM L1)).
  apply RS.
  apply IHh2.
  apply IHh1.
  apply EqlangMS.
  apply REq with (langK (langM L)).
  apply RKleene.
  apply IHh.
  apply (EqlangKM L).
Qed.

(* ==================================================================== *)
(*                        REGULAR EXPRESSIONS                           *)

(* Related to regular languages is the notion of regular expressions.   *)
(* A regular expression is a formal, syntactic expression that can      *)
(* latter be interpreted as a regular language. Regular expressions are *)
(* pervasive in computer science, e.g. for searching for some text in   *)
(* a file, as it is possible with the `grep` command line tool.         *)
(*                                                                      *)
(* For instance, the command:                                           *)
(*                                                                      *)
(*    grep -E 'ab*a' foo.txt                                            *)
(*                                                                      *)
(* is going to print all the lines of `foo.txt` that contains a word    *)
(* of the form ab⋯ba (where the letter b can be repeated 0, 1 or more   *)
(* time. I.e., grep is going to find all the lines of `foo.txt` that    *)
(* contains a word that belongs in the formal language:                 *)
(*                                                                      *)
(*    L = { abⁿa | n ∈ ℕ }                                              *)
(*                                                                      *)
(* If you need to convince yourself that L is regular, note that:       *)
(*                                                                      *)
(*    L = { a } ∪ { b }* ∪ { a }                                        *)
(*                                                                      *)
(* In some sense, a regular expression is just a compact way to         *)
(* represent a regular language, and its definition is going to be      *)
(* close to the one of regular languages.                               *)
(*                                                                      *)
(* A regular expression is either:                                      *)
(*                                                                      *)
(*  - the constant ∅ or the constant ε or one letter from A             *)
(*  - the disjunction r1 | r2 of two regular expressions                *)
(*  - the concatenation r1 · r2 of two regular expressions              *)
(*  - the Kleene r* of some regular expression                          *)

(* We can represent regular expressions as a inductive type in Coq.     *)

(* Q6. complete the following definition:                               *)

Inductive regexp : Type :=
| RE_Empty : regexp
| RE_Void  : regexp
| RE_Atom  : A -> regexp
| RE_Cat : regexp -> regexp -> regexp
| RE_Or : regexp -> regexp -> regexp
| RE_Kleene : regexp -> regexp
.

Implicit Types (r : regexp).

(* We now have to formally related regular expressions to regular       *)
(* languages. For that purpose, we are going to interpret a regular     *)
(* expression as a languages. If r is a regular expression, then we     *)
(* denote by language [r] as follows:                                   *)
(*                                                                      *)
(*   - [∅]       = ∅                                                    *)
(*   - [ε]       = ε                                                    *)
(*   - [a]       = { a } for a ∈ A                                      *)
(*   - [r₁ ∪ r₂] = [r₁] ∪ [r₂]                                          *)
(*   - [r₁ · r₂] = [r₁] · [r₂]                                          *)
(*   - [r*]      = [r]*                                                 *)

(* Q7. implement the Coq counterpart of the above definition:           *)

Fixpoint interp (r : regexp) {struct r} : language :=
  match r with
  | RE_Empty => lang0
  | RE_Void => lang1
  | RE_Atom a => langA a
  | RE_Cat r1 r2 => langS (interp r1) (interp r2)
  | RE_Or r1 r2 => langU (interp r1) (interp r2)
  | RE_Kleene r1 => langK (interp r1)
  end.

(* Q8. show that the interpretation of a regular expression is a        *)
(*     regular language:                                                *)

Lemma regular_regexp r : regular (interp r).
Proof.
  induction r.
  apply REmpty.
  apply R1.
  apply RA.
  apply (RS IHr1 IHr2).
  apply (RUnion IHr1 IHr2).
  apply RKleene.
  apply IHr.
Qed.

(* Q9. show that any regular language can be interpreted as a           *)
(*     regular expression:                                              *)

Lemma EqlangU L1 L2 G1 G2 : L1 =L G1 -> L2 =L G2 -> langU L1 L2 =L langU G1 G2.
Proof.
  move => h1 h2.
  move => w.
  split.
  move => [H1 | H2].
  left.
  apply h1.
  apply H1.
  right.
  apply h2.
  apply H2.
  move => [H1 | H2].
  left.
  apply h1.
  apply H1.
  right.
  apply h2.
  apply H2.
Qed.

Lemma EqlangS L1 L2 G1 G2 : L1 =L G1 -> L2 =L G2 -> langS L1 L2 =L langS G1 G2.
Proof.
  move => h1 h2.
  move => w.
  unfold langS.
  split.
  move => h.
  move: h => [s [c [H1 [H2 H3]]]].
  exists s.
  exists c.
  split.
  auto.
  split.
  apply h1.
  apply H2.
  apply h2.
  apply H3.
  move => h.
  move: h => [s [c [H1 [H2 H3]]]].
  exists s.
  exists c.
  split.
  auto.
  split.
  apply h1.
  apply H2.
  apply h2.
  apply H3.
Qed.

Lemma EqlangK L G : L =L G -> langK L =L langK G.
Proof.
  move => H.
  move => w.
  split.
  move => h.
  induction h.
  apply kleene0.
  apply kleeneA.
  apply H.
  apply H0.
  apply kleeneS.
  apply IHh1.
  apply IHh2.
  move => h.
  induction h.
  apply kleene0.
  apply kleeneA.
  apply H.
  apply H0.
  apply kleeneS.
  apply IHh1.
  apply IHh2.
Qed.

Lemma regexp_regular L : regular L -> exists r, L =L interp r.
Proof.
  move => h.
  induction h.
  inversion IHh.
  exists x.
  move => w.
  split.
  move => h1.
  apply H0.
  apply H.
  apply h1.
  move => h1.
  apply H.
  apply H0.
  apply h1.
  exists RE_Empty.
  move => w.
  split.
  move => x.
  case x.
  move => x.
  case x.
  exists RE_Void.
  move => w.
  split.
  move => h.
  apply h.
  move => h.
  apply h.
  exists (RE_Atom x).
  move => w.
  split.
  move => h.
  apply h.
  move => h.
  apply h.
  move: IHh1 => [r1 H1].
  move: IHh2 => [r2 H2].
  exists (RE_Or r1 r2).
  simpl.
  apply (EqlangU H1 H2).
  move: IHh1 => [r1 H1].
  move: IHh2 => [r2 H2].
  exists (RE_Cat r1 r2).
  simpl.
  apply (EqlangS H1 H2).
  move: IHh => [r H].
  exists (RE_Kleene r).
  simpl.
  apply (EqlangK H).
Qed.

(* Of course, it may happen that two regular expressions represent      *)
(* the same language: r1 ~ r2 iff [r1] = [r2].                          *)

(* Q10. write a binary predicate eqR : regexp -> regexp -> Prop s.t.    *)
(*      eqR r1 r2 iff r1 and r2 are equivalent regexp.                  *)

Definition eqR (r1 r2 : regexp) : Prop := interp r1 =L interp r2.

Infix "~" := eqR (at level 90).

(* Q11. state and prove the following regexp equivalence:               *)
(*           (a|b)* ~ ( a*b* )*                                         *)

Lemma KleeneC L G : (forall w, (L w -> G w)) -> (forall w, langK L w -> langK G w).
Proof.
  move => H.
  move => w.
  move => h.
  induction h.
  apply kleene0.
  apply kleeneA.
  apply H.
  apply H0.
  apply kleeneS.
  apply IHh1.
  apply IHh2.
Qed.

Lemma eqExample a b : RE_Kleene (RE_Or (RE_Atom a) (RE_Atom b)) ~ RE_Kleene (RE_Cat (RE_Kleene (RE_Atom a)) (RE_Kleene (RE_Atom b))).
Proof.
  split.
  move => h.
  induction h.
  apply kleene0.
  case : H.
  move => h.
  apply kleeneA.
  exists w.
  exists nil.
  split.
  rewrite app_nil_r.
  reflexivity.
  split.
  apply kleeneA.
  apply h.
  apply kleene0.
  move => h.
  apply kleeneA.
  exists nil.
  exists w.
  split.
  simpl.
  reflexivity.
  split.
  apply kleene0.
  apply kleeneA.
  apply h.
  apply kleeneS.
  apply IHh1.
  apply IHh2.
  move => h.
  induction h.
  apply kleene0.
  case : H.
  move => x.
  move => [c [h1 [h2 h3]]].
  symmetry in h1.
  rewrite h1.
  apply kleeneS.
  case h2.
  apply kleene0.
  move => w0 h.
  apply kleeneA.
  left.
  apply h.
  move => s c0.
  move => H1 H2.
  apply kleeneS.
  apply (@KleeneC (langA a) (langU (langA a) (langA b))).
  move => w0.
  move => H.
  left.
  apply H.
  apply H1.
  apply (@KleeneC (langA a) (langU (langA a) (langA b))).
  move => w0.
  move => H.
  left.
  apply H.
  apply H2.
  apply (@KleeneC (langA b) (langU (langA a) (langA b))).
  move => w0.
  move => H.
  right.
  apply H.
  apply h3.
  apply kleeneS.
  apply IHh1.
  apply IHh2.
Qed.

(* ==================================================================== *)
(*                          REGEXP MATCHING                             *)

(* We now want to write a algorithm for deciding if a given word `w`    *)
(* matches a regular expression `r`, i.e. for deciding wether `w ∈ [r]` *)
(*                                                                      *)
(* For that purpose, we are going to use Brzozowski's derivatives.      *)
(*                                                                      *)
(* The idea of the algorithm is the following:                          *)
(*                                                                      *)
(* Given a letter `x` and an regular expression `r`, the Brzozowski's   *)
(* derivatives of `x` w.r.t. `r` is a regular expression x⁻¹·r s.t.     *)
(*                                                                      *)
(*    x · w ∈ [r] ⇔ w ∈ [x⁻¹·r]                                       *)
(*                                                                      *)
(* Assuming that we can compute a Brzozowski's derivative for any       *)
(* letter `x` and regular expression `r`, one can check that a word `w` *)
(* matches a regexp `r` as follows:                                     *)
(*                                                                      *)
(*   - if w = x · w' for some letter x and word w', we recursively      *)
(*     check that `w` matches `x⁻¹·r`; otherwise                        *)
(*   - if w = ε, then we directly check that [r] contains the empty     *)
(*     word - a property that is deciable.                              *)

(* Q12. write a nullity test `contains0` : regexp -> bool s.t.          *)
(*                                                                      *)
(*      ∀ r, contains0 r ⇔ ε ∈ [e]                                    *)

Fixpoint contains0 (r : regexp) : bool :=
  match r with
  | RE_Empty => false
  | RE_Void => true
  | RE_Atom c => false
  | RE_Cat r1 r2 => (contains0 r1 && contains0 r2)%bool
  | RE_Or r1 r2 => (contains0 r1 || contains0 r2)%bool
  | RE_Kleene r => true
  end.

(* Q13. prove that your definition of `contains0` is correct:           *)

Lemma contains0_ok r : contains0 r <-> interp r nil.
Proof.
  split.
  move => h.
  induction r.
  simpl in h.
  discriminate h.
  simpl.
  reflexivity.
  simpl in h.
  discriminate h.
  simpl in h.
  simpl.
  exists nil.
  exists nil.
  split.
  done.
  move/andP : h => [h1 h2].
  split.
  apply IHr1.
  apply h1.
  apply IHr2.
  apply h2.
  simpl in h.
  move/orP : h => [h1 | h2].
  simpl.
  left.
  apply IHr1.
  apply h1.
  simpl.
  right.
  apply IHr2.
  apply h2.
  apply kleene0.
  move => h.
  induction r.
  case : h.
  simpl.
  trivial.
  simpl in h.
  unfold langA in h.
  discriminate h.
  simpl.
  apply /andP.
  simpl in h.
  move : h => [s [c [h1 [h2 h3]]]].
  move: (app_eq_nil s c h1) => [h4 h5].
  split.
  apply IHr1.
  rewrite h4 in h2.
  apply h2.
  rewrite h5 in h3.
  apply IHr2.
  apply h3.
  simpl.
  apply /orP.
  simpl in h.
  move: h => [h1 | h2].
  left.
  apply IHr1.
  apply h1.
  right.
  apply IHr2.
  apply h2.
  simpl.
  done.
Qed.

(* We give below the definition of the Brzozowski's derivative:         *)
(*                                                                      *)
(*   - x⁻¹ · x         = ε                                              *)
(*   - x⁻¹ · y         = ∅ if x ≠ y                                     *)
(*   - x⁻¹ · ε         = ∅                                                     *)
(*   - x⁻¹ · ∅         = ∅                                                      *)
(*   - x⁻¹ · (r₁ | r₂) = (x⁻¹ · r₁) | (x⁻¹ · r₂)                         *)
(*   - x⁻¹ · (r₁ · r₂) = (x⁻¹ · r₁) · r₂ | E(r₁) · (x⁻¹ · r₂)            *)
(*   - x⁻¹ · r*        = (x⁻¹ · r) · r*                                 *)
(*                                                                      *)
(* where E(r) = ε if ε ∈ [r] & E(r) = ∅ otherwise.                      *)

(* Q14. write a function `Brzozowski` that computes a Brzozowski's      *)
(*      derivative as defined above.                                    *)
(*                                                                      *)
(* For that purpose, you may need to have a decidable equality over     *)
(* `A`. The parameter `Aeq` along with the axioms `Aeq_dec` give        *)
(* you such a decidable equality.                                       *)

Parameter Aeq : A -> A -> bool.

(* Here, `Aeq x y` has to be read as `Aeq x y = true`                   *)
Axiom Aeq_dec : forall (x y : A), Aeq x y <-> x = y.

Notation "a ++ b" := (RE_Cat a b).
Notation "a || b" := (RE_Or a b).

Fixpoint Brzozowski (x : A) (r : regexp) : regexp :=
  match r with
  | RE_Empty => RE_Empty
  | RE_Void => RE_Empty
  | RE_Atom c => match (Aeq c x) with
              | true => RE_Void
              | false => RE_Empty
              end
  | RE_Cat r s => match (contains0 r) with
               | true => ((Brzozowski x r) ++ s) || (Brzozowski x s)
               | false => (Brzozowski x r) ++ s
               end
  | RE_Or r s => (Brzozowski x r) || (Brzozowski x s)
  | RE_Kleene r => (Brzozowski x r) ++ (RE_Kleene r)
end.

Notation "r / x" := (Brzozowski x r).

(* Q15. write a function `rmatch` s.t. `rmatch r w` checks wether a     *)
(*      word `w` matches a given regular expression `r`.                *)

Fixpoint rmatch (r : regexp) (w : word) : bool :=
  match w with
  | nil => contains0 r
  | cons a s => rmatch (r / a) s
  end.

(* Q16. show that the `Brzozowski` function is correct.                 *)

Lemma Brzozowski_correct (x : A) (w : word) (r : regexp) :
  interp (Brzozowski x r) w -> interp r (x :: w).
Proof.
  move : w.
  induction r.
  move => w h.
  simpl in h.
  case : h.
  move => w h.
  simpl in h.
  case : h.
  move => w h.
  case e: (Aeq a x).
  unfold Brzozowski in h.
  rewrite e in h.
  simpl in h.
  unfold lang1 in h.
  rewrite h.
  simpl.
  move : (Aeq_dec a x) => [h1 h2].
  move : (h1 e) => h3.
  symmetry in h3.
  rewrite h3.
  reflexivity.
  unfold Brzozowski in h.
  rewrite e in h.
  case h.
  move => w h.
  simpl in h.
  case e: (contains0 (r1)).
  rewrite e in h.
  simpl.
  move : h => /= [h1 | h2].
  move : h1 => [s [c [h1 [h2 h3]]]].
  exists (x :: s).
  exists c.
  split.
  simpl.
  rewrite h1.
  done.
  split.
  apply IHr1.
  apply h2.
  apply h3.
  exists nil.
  exists (x :: w).
  split.
  simpl.
  done.
  split.
  apply contains0_ok.
  apply e.
  apply IHr2.
  apply h2.
  rewrite e in h.
  move : h => /= [s [c [h1 [h2 h3]]]].
  exists (x :: s).
  exists c.
  split.
  simpl.
  rewrite h1.
  done.
  split.
  apply IHr1.
  apply h2.
  apply h3.
  move => w h.
  move : h => /= [h1 | h2].
  left.
  apply IHr1.
  apply h1.
  right.
  apply IHr2.
  apply h2.
  move => w h.
  move : h => /= [s [c [h1 [h2 h3]]]].
  symmetry in h1.
  rewrite h1.
  rewrite app_comm_cons.
  apply kleeneS.
  apply kleeneA.
  apply IHr.
  apply h2.
  apply h3.
Qed.

(* Q17. show that `rmatch` is correct.                                  *)

Lemma rmatch_correct (r : regexp) (w : word):
  rmatch r w -> interp r w.
Proof.
  move : r.
  induction w.
  move => r h.
  apply contains0_ok.
  apply h.
  move => r h.
  apply Brzozowski_correct.
  apply IHw.
  apply h.
Qed.

(* Q18. (HARD - OPTIONAL) show that `rmatch` is complete.               *)

Lemma Brzozowski_complete (x : A) (w : word) (r : regexp) :
   interp r (x :: w) -> interp (Brzozowski x r) w.
Proof.
  move : w.
  move : x.
  induction r.
  move => x w h.
  case : h.
  move => x w h.
  simpl in h.
  done.
  move => x w h.
  simpl in h.
  move: h => [e1 e2].
  rewrite e1.
  rewrite e2.
  simpl.
  move : (Aeq_dec a a) => e.
  move : e => [h1 h2].
  rewrite h2.
  reflexivity.
  done.
  move => x w h.
  simpl in h.
  move: h => [s [c [h1 [h2 h3]]]].
  simpl.
  case e : (contains0 r1).
  case: s h1 h2.
  simpl.
  move => h1 h2.
  right.
  apply IHr2.
  rewrite h1 in h3.
  apply h3.
  move => a l.
  move => h1 h2.
  simpl in h1.
  case : h1.
  move => h1 h4.
  symmetry in h4.
  rewrite h1 in h2.
  rewrite h4.
  left.
  exists l.
  exists c.
  split.
  done.
  split.
  apply IHr1.
  apply h2.
  apply h3.
  case : s h1 h2.
  simpl.
  move => h h1.
  move : (contains0_ok r1) => [h2 h4].
  move : (h4 h1) => h5.
  rewrite e in h5.
  done.
  move => a l.
  move => h1 h2.
  simpl in h1.
  case : h1.
  move => h1 h4.
  rewrite h1 in h2.
  exists l.
  exists c.
  split.
  apply h4.
  split.
  apply IHr1.
  apply h2.
  apply h3.
  move => x w h.
  move : h => /= [h1 | h2].
  left.
  apply IHr1.
  apply h1.
  right.
  apply IHr2.
  apply h2.
  move => x w h.
  move: {-2}(x :: w) (Logic.eq_refl (x :: w)) h => /= w' w'E h; elim: h x w w'E => {w'} //.
  move => s h.
  move => x w.
  move => e1.
  exists w.
  exists nil.
  split.
  apply app_nil_r.
  split.
  apply IHr.
  symmetry in e1.
  rewrite e1.
  apply h.
  apply kleene0.
  move => s c h.
  move => h1 h2.
  move => h3.
  move => x w.
  move => e1.
  case e : s => [ | a l].
  rewrite e in e1.
  simpl in  e1.
  apply h3.
  apply e1.
  rewrite e in e1.
  simpl in e1.
  case : e1.
  move => e1 e2.
  move: (h1 a l e) => h4.
  move: h4 => [s1 [c1 [e3 [h5 h6]]]].
  exists s1.
  exists (c1 ++ c)%list.
  split.
  rewrite app_assoc.
  rewrite e3.
  rewrite e2.
  done.
  split.
  rewrite e1 in h5.
  apply h5.
  apply kleeneS.
  apply h6.
  apply h2.
Qed.

Lemma rmatch_complete (r : regexp) (w : word):
  interp r w -> rmatch r w.
Proof.
  move : r.
  induction w.
  move => r h.
  simpl.
  apply contains0_ok.
  apply h.
  move => r h.
  simpl.
  apply IHw.
  apply Brzozowski_complete.
  apply h.
Qed.